diff --git a/contrib/mandel.factor b/contrib/mandel.factor index 240fd7cba0..a7b75a23f7 100644 --- a/contrib/mandel.factor +++ b/contrib/mandel.factor @@ -1,40 +1,100 @@ -! Based on lisp code from newsgroup discussion in -! comp.lang.lisp +! Graphical mandelbrot fractal renderer. +! 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 -! (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 "~%")) +IN: mandel +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 ? ) - >r dupd sq + dup abs 2 < [ - r> pred dup CHAR: \s > +: scale 255 * >fixnum ; + +: 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 ; + +: ( 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 -- ) - [ ?mandel-step ] [ ] while >char write 2drop ; +: max-color 360 ; -: mandel-x ( x y -- ) - rect> dup CHAR: ~ mandel-step ; +SYMBOL: zoom-fact +SYMBOL: x-inc +SYMBOL: y-inc +SYMBOL: nb-iter +SYMBOL: cols +SYMBOL: center -: mandel-y ( y -- ) - 150 [ dupd 50 / 2 - >float swap mandel-x ] times* drop ; +: init-mandel ( -- ) + width get 200000 zoom-fact get * / x-inc set + height get 150000 zoom-fact get * / y-inc set + nb-iter get max-color min 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-loop + SDL_Quit ; + +mandel