new, graphical contrib/mandel.factor

contrib/mandel.factor

@@ -1,40 +1,100 @@
-! Based on lisp code from newsgroup discussion in
+! Graphical mandelbrot fractal renderer.
-! comp.lang.lisp
+! To run this code, start your interpreter like so:
+!
+! ./f -library:sdl=libSDL.so -library:sdl-gfx=libSDL_gfx.so
+!
+! Then, enter this at the interpreter prompt:
+!
+! "contrib/mandel.factor" run-file
 
-!  (loop for y from -1 to 1.1 by 0.1 do
+IN: mandel
-!        (loop for x from -2 to 1 by 0.04 do
-!              (let* ((c 126)
-!                     (z (complex x y))
-!                     (a z))
-!                (loop while (< (abs
-!                                (setq z (+ (* z z) a)))
-!                               2)
-!                  while (> (decf c) 32)) 
-!                (princ (code-char c))))
-!        (format t "~%"))
 
+USE: alien
 USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
 USE: math
-USE: prettyprint
+USE: namespaces
+USE: sdl
 USE: stack
+USE: vectors
+USE: prettyprint
 USE: stdio
-USE: strings
+USE: test
 
-: ?mandel-step ( a z c -- a z c ? )
+: scale 255 * >fixnum ;
-    >r dupd sq + dup abs 2 < [
+
-        r> pred dup CHAR: \s >
+: scale-rgba ( r g b -- n )
+    scale
+    swap scale 8 shift bitor
+    swap scale 16 shift bitor
+    swap scale 24 shift bitor ;
+
+: sat 0.85 ;
+: val 0.85 ;
+
+: <color-map> ( nb-cols -- map )
+    [,
+        dup [
+            360 * over succ / 360 / sat val
+            hsv>rgb 1.0 scale-rgba ,
+        ] times*
+    ,] list>vector nip ;
+
+: absq >rect swap sq swap sq + ;
+
+: iter ( c z nb-iter -- x )
+    over absq 4 >= over 0 = or [
+        nip nip
     ] [
-        r> f
+        pred >r sq dupd + r> iter
     ] ifte ;
 
-: mandel-step ( a z c -- )
+: max-color 360 ;
-    [ ?mandel-step ] [ ] while >char write 2drop ;
 
-: mandel-x ( x y -- )
+SYMBOL: zoom-fact
-    rect> dup CHAR: ~ mandel-step ;
+SYMBOL: x-inc
+SYMBOL: y-inc
+SYMBOL: nb-iter
+SYMBOL: cols
+SYMBOL: center
 
-: mandel-y ( y -- )
+: init-mandel ( -- )
-    150 [ dupd 50 / 2 - >float swap mandel-x ] times* drop ;
+    width get 200000 zoom-fact get * / x-inc set
+    height get 150000 zoom-fact get * / y-inc set
+    nb-iter get max-color min <color-map> cols set ;
+
+: c ( #{ i j } -- c )
+    >rect >r
+    x-inc get * center get real x-inc get width get 2 / * - + >float
+    r>
+    y-inc get * center get imaginary y-inc get height get 2 / * - + >float
+    rect> ;
+
+: render ( -- )
+    init-mandel
+    width get height get [
+        c 0 nb-iter get iter dup 0 = [
+            drop 0
+        ] [
+            cols get [ vector-length mod ] keep vector-nth
+        ] ifte
+    ] with-pixels ;
 
 : mandel ( -- )
-    42 [ 20 / 1 - >float mandel-y terpri ] times* ;
+    640 480 32 SDL_HWSURFACE SDL_SetVideoMode drop
+
+    [
+        1 zoom-fact set
+        -0.65 center set
+        50 nb-iter set
+        [ render ] time
+        "Done." print flush
+    ] with-surface
+
+    <event> event-loop
+    SDL_Quit ;
+
+mandel