source: project/demonstrations/numerical-performance/mandelbrot-scheme-fast.scm @ 20563

Last change on this file since 20563 was 20563, checked in by felix winkelmann, 10 years ago

added mandelbrot benchmark

File size: 1.4 KB
Line 
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.