Rev | Line | |
---|

[20563] | 1 | ;;; The Computer Language Benchmarks Game |
---|

| 2 | ;;; http://shootout.alioth.debian.org/ |
---|

| 3 | ;;; |
---|

| 4 | ;;; contributed by Anthony Borla |
---|

| 5 | |
---|

| 6 | (use extras) |
---|

| 7 | |
---|

| 8 | (define-constant +limit-sqr+ 4.0) |
---|

| 9 | |
---|

| 10 | (define-constant +iterations+ 50) |
---|

| 11 | |
---|

| 12 | (define (mandelbrot iterations x y n) |
---|

| 13 | (let ((cr (fp- (fp/ (fp* 2.0 x) n) 1.5)) (ci (fp- (fp/ (fp* 2.0 y) n) 1.0))) |
---|

| 14 | (let loop ((i 0) (zr 0.0) (zi 0.0)) |
---|

| 15 | (let ((zrq (fp* zr zr)) (ziq (fp* zi zi))) |
---|

| 16 | (cond |
---|

| 17 | ((fx> i iterations) 1) |
---|

| 18 | ((fp> (fp+ zrq ziq) +limit-sqr+) 0) |
---|

| 19 | (else |
---|

| 20 | (loop (fx+ i 1) |
---|

| 21 | (fp+ (fp- zrq ziq) cr) |
---|

| 22 | (fp+ (fp* 2.0 (fp* zr zi)) ci)))))))) |
---|

| 23 | |
---|

| 24 | (define (main args) |
---|

| 25 | (let ((n (if (null? args) |
---|

| 26 | 1 |
---|

| 27 | (string->number (car args)))) |
---|

| 28 | (bitnum 0) |
---|

| 29 | (byteacc 0)) |
---|

| 30 | (write-line (string-append "P4\n" (number->string n) " " (number->string n))) |
---|

| 31 | (let loop-y ((y 0)) |
---|

| 32 | (when (fx< y n) |
---|

| 33 | (let loop-x ((x 0)) |
---|

| 34 | (when (fx< x n) |
---|

| 35 | (set! bitnum (fx+ bitnum 1)) |
---|

| 36 | (set! byteacc |
---|

| 37 | (fx+ (fx* 2 byteacc) |
---|

| 38 | (mandelbrot |
---|

| 39 | +iterations+ |
---|

| 40 | (exact->inexact x) |
---|

| 41 | (exact->inexact y) |
---|

| 42 | (exact->inexact n)))) |
---|

| 43 | (cond |
---|

| 44 | ((fx= bitnum 8) |
---|

| 45 | (write-char (integer->char byteacc)) |
---|

| 46 | (set! bitnum 0) |
---|

| 47 | (set! byteacc 0)) |
---|

| 48 | ((fx= x (fx- n 1)) |
---|

| 49 | (write-char (integer->char (fxshl byteacc (fx- 8 (fxmod n 8))))) |
---|

| 50 | (set! bitnum 0) |
---|

| 51 | (set! byteacc 0))) |
---|

| 52 | (loop-x (fx+ x 1)))) |
---|

| 53 | (loop-y (fx+ y 1)))))) |
---|

| 54 | |
---|

| 55 | (main (command-line-arguments)) |
---|

**Note:** See

TracBrowser
for help on using the repository browser.