81 lines
2.0 KiB
Scheme
81 lines
2.0 KiB
Scheme
;; ---------------------------------------------------------------------
|
|
;; The Great Computer Language Shootout
|
|
;; http://shootout.alioth.debian.org/
|
|
;;
|
|
;; Derived from the Chicken variant, which was
|
|
;; Contributed by Anthony Borla
|
|
|
|
;; Note: as of version 350, this benchmark spends much of
|
|
;; its time GCing; it runs 2 times as fast in mzscheme3m.
|
|
|
|
;; The version that uses complex number is a little
|
|
;; more elegant, but slower:
|
|
;; (define (mandelbrot iterations x y n ci)
|
|
;; (let ((c (+ (- (/ (* 2.0 x) n) 1.5)
|
|
;; (* ci 0.0+1.0i))))
|
|
;; (let loop ((i 0) (z 0.0+0.0i))
|
|
;; (cond
|
|
;; [(> i iterations) 1]
|
|
;; [(> (magnitude z) 2.0) 0]
|
|
;; [else (loop (add1 i) (+ (* z z) c))]))))
|
|
|
|
|
|
(module mandelbrot mzscheme
|
|
|
|
;; -------------------------------
|
|
|
|
(define +limit-sqr+ 4.0)
|
|
|
|
(define +iterations+ 50)
|
|
|
|
;; -------------------------------
|
|
|
|
(define (mandelbrot iterations x y n ci)
|
|
(let ((cr (- (/ (* 2.0 x) n) 1.5)))
|
|
(let loop ((i 0) (zr 0.0) (zi 0.0))
|
|
(if (> i iterations)
|
|
1
|
|
(let ((zrq (* zr zr))
|
|
(ziq (* zi zi)))
|
|
(cond
|
|
((> (+ zrq ziq) +limit-sqr+) 0)
|
|
(else (loop (add1 i) (+ (- zrq ziq) cr) (+ (* 2.0 (* zr zi)) ci)))))))))
|
|
|
|
;; -------------------------------
|
|
|
|
(define (main args)
|
|
(let ((n (string->number (vector-ref args 0)))
|
|
(out (current-output-port)))
|
|
|
|
(fprintf out "P4\n~a ~a\n" n n)
|
|
|
|
(let loop-y ((y 0))
|
|
|
|
(when (< y n)
|
|
|
|
(let ([ci (- (/ (* 2.0 y) n) 1.0)])
|
|
|
|
(let loop-x ((x 0) (bitnum 0) (byteacc 0))
|
|
|
|
(if (< x n)
|
|
(let ([bitnum (add1 bitnum)]
|
|
[byteacc (+ (arithmetic-shift byteacc 1)
|
|
(mandelbrot +iterations+ x y n ci))])
|
|
|
|
(cond
|
|
((= bitnum 8)
|
|
(write-byte byteacc out)
|
|
(loop-x (add1 x) 0 0))
|
|
|
|
[else (loop-x (add1 x) bitnum byteacc)]))
|
|
|
|
(begin
|
|
(when (positive? bitnum)
|
|
(write-byte (arithmetic-shift byteacc (- 8 (bitwise-and n #x7))) out))
|
|
|
|
(loop-y (add1 y))))))))))
|
|
|
|
;; -------------------------------
|
|
|
|
(main (current-command-line-arguments)))
|