Ticket #755: mandelbrot.scm

;;; The Computer Language Benchmarks Game
;;; http://shootout.alioth.debian.org/
;;
;;; Derived from the Chicken Scheme variant by Anthony Borla
;;; contributed by Matthew Flatt
;;
;; ... then ported back to CHICKEN by felix


(use extras)

 
(define +limit-sqr+ 4.0)
(define +iterations+ 50)

;; -------------------------------

(: mandelbrot (fixnum fixnum fixnum float -> fixnum))

(define (mandelbrot x y n ci)
  (let ((cr (fp- (fp/ (fp* 2.0 (exact->inexact x)) (exact->inexact n)) 1.5)))
    (let loop ((i 0) (zr 0.0) (zi 0.0))
      (if (> i +iterations+)
          1
          (cond
           ((fp> (fp+ (fp* zr zr) (fp* zi zi)) +limit-sqr+) 0)
           (else (loop (fx+ 1 i) 
                       (fp+ (fp- (fp* zr zr) (fp* zi zi)) cr) 
                       (fp+ (fp* 2.0 (fp* zr zi)) ci))))))))

;; -------------------------------

(define (main n)
  (let ((out (current-output-port)))
    (fprintf out "P4\n~a ~a\n" n n)
    (let loop-y ((y 0))
      (when (fx< y n)
        (let ((ci (fp- (fp/ (fp* 2.0 (exact->inexact y)) (exact->inexact n)) 1.0)))
          (let loop-x ((x 0) (bitnum 0) (byteacc 0))
            (if (fx< x n)
                (let ((bitnum (fx+ 1 bitnum))
                      (byteacc (+ (fxshl byteacc 1) 
                                  (mandelbrot x y n ci))))
                  (cond
                   ((= bitnum 8)
                    (write-byte byteacc out)
                    (loop-x (fx+ 1 x) 0 0))
                   (else (loop-x (fx+ 1 x) bitnum byteacc))))
                (begin
                  (when (positive? bitnum)
                    (write-byte (fxshl byteacc 
                                       (fx- 8 (fxand n #x7))) 
                                out))
                  (loop-y (fx+ y 1))))))))))

;; -------------------------------

(time (main (string->number (car (command-line-arguments)))))