Ticket #755: mandelbrot.scm

File mandelbrot.scm, 1.8 KB (added by felix winkelmann, 10 years ago)
Line 
1;;; The Computer Language Benchmarks Game
2;;; http://shootout.alioth.debian.org/
3;;
4;;; Derived from the Chicken Scheme variant by Anthony Borla
5;;; contributed by Matthew Flatt
6;;
7;; ... then ported back to CHICKEN by felix
8
9
10(use extras)
11
12 
13(define +limit-sqr+ 4.0)
14(define +iterations+ 50)
15
16;; -------------------------------
17
18(: mandelbrot (fixnum fixnum fixnum float -> fixnum))
19
20(define (mandelbrot x y n ci)
21  (let ((cr (fp- (fp/ (fp* 2.0 (exact->inexact x)) (exact->inexact n)) 1.5)))
22    (let loop ((i 0) (zr 0.0) (zi 0.0))
23      (if (> i +iterations+)
24          1
25          (cond
26           ((fp> (fp+ (fp* zr zr) (fp* zi zi)) +limit-sqr+) 0)
27           (else (loop (fx+ 1 i) 
28                       (fp+ (fp- (fp* zr zr) (fp* zi zi)) cr) 
29                       (fp+ (fp* 2.0 (fp* zr zi)) ci))))))))
30
31;; -------------------------------
32
33(define (main n)
34  (let ((out (current-output-port)))
35    (fprintf out "P4\n~a ~a\n" n n)
36    (let loop-y ((y 0))
37      (when (fx< y n)
38        (let ((ci (fp- (fp/ (fp* 2.0 (exact->inexact y)) (exact->inexact n)) 1.0)))
39          (let loop-x ((x 0) (bitnum 0) (byteacc 0))
40            (if (fx< x n)
41                (let ((bitnum (fx+ 1 bitnum))
42                      (byteacc (+ (fxshl byteacc 1) 
43                                  (mandelbrot x y n ci))))
44                  (cond
45                   ((= bitnum 8)
46                    (write-byte byteacc out)
47                    (loop-x (fx+ 1 x) 0 0))
48                   (else (loop-x (fx+ 1 x) bitnum byteacc))))
49                (begin
50                  (when (positive? bitnum)
51                    (write-byte (fxshl byteacc 
52                                       (fx- 8 (fxand n #x7))) 
53                                out))
54                  (loop-y (fx+ y 1))))))))))
55
56;; -------------------------------
57
58(time (main (string->number (car (command-line-arguments)))))