mandelbrot.fs

vocabulary mandelbrot.fs also mandelbrot.fs

require sdl.fs
also sdl.fs

\ z = z^2 + c
\ z = x0 + iy0
\ z^2 = (x + iy)(x + iy)
\     = x^2 + 2xiy + (iy)^2
\     = x^2 + 2xiy - y^2
\     = x^2 - y^2 + 2xyi
\ c = x1 + iy1

20 constant max-iter

: complex! ( addr -- ) ( F: x0 y0 -- ) dup f! cell + f! ;
: complex@ ( addr -- ) ( -- x0 y0 )    dup cell + f@ f@ ;
: complex+ ( F: x0 y0 x1 y1 -- x2 y2 ) frot f+ frot frot f+ fswap ;
: complex-abs^2 ( F: x0 y0 -- u )      fdup f* fswap fdup f* f+ ;

variable x
variable y
: complex^2 ( x0 y0 -- x1 y1) \ x^2 - y^2 + 2xyi
  y f! x f!

  x f@ fdup f* \ x^2
  x f@ y f@ 2e f* f* \ 2xiy
  y f@ fdup f* \ y^2
  frot fswap f- fswap
;

: x-scale ( u1 -- ) ( F: f -- ) 0 d>f #width 0 d>f f/ 3.5e f* -2.5e f+ ;
: y-scale ( u1 -- ) ( F: f -- ) 0 d>f #height 0 d>f f/ 2e f* -1.e f+ ;

2variable z
2variable c
variable in-set?
variable counter
variable x
variable y
: plot-mandel ( x y -- )
  y ! x !
  x @ x-scale
  y @ y-scale
  c complex!
  0e 0e z complex!
  false in-set? !
  0 counter !

  max-iter 0 do
    z complex@ complex^2
    c complex@ complex+
    z complex! \ z = z^2 + c
    counter @ 1+ counter !

    \ if |z| > 2
    z complex@ complex-abs^2 4e f> if
      true in-set? !
      leave
    then
  loop
  in-set? @ 0<> if
    counter @ 0 d>f
    max-iter 0 d>f f/ 255e f* f>d drop
    2 mod 255 *
    dup dup set-color
    x @ y @ put-pixel
  then
;

: render
  init-sdl
  #height 1- 0 do #width 1- 0 do i j plot-mandel loop flip-screen loop
  wait-key
  sdl-quit
;

render

bye

previous definitions

sdl.fs

[undefined] sdl.fs [if]

c-library sdl
s" SDL" add-lib

\c #include <SDL/SDL.h>

c-function sdl-init             SDL_Init            n -- n
c-function sdl-set-video-mode	SDL_SetVideoMode	n n n n -- a
c-function sdl-flip             SDL_Flip            a -- n
c-function sdl-quit             SDL_Quit            -- void
c-function sdl-delay            SDL_Delay           n -- void
c-function sdl-poll-event       SDL_PollEvent       a -- void

end-c-library

vocabulary sdl.fs also sdl.fs definitions

$00000000	constant SDL_SWSURFACE
$80000000   constant SDL_FULLSCREEN
$00000020	constant SDL_INIT_VIDEO
$0000FFFF	constant SDL_INIT_EVERYTHING
$00000002	constant SDL_KEYDOWN

32          constant sdl-pixels-offset
24          constant sdl-event-type-size

1024 constant #width
768 constant #height

#width 4 * constant #stride

variable color 3 cells allot
variable surface
variable pixels

variable sdl-event sdl-event-type-size allot

: wait-key 
  begin
    sdl-event sdl-poll-event
    sdl-event c@ SDL_KEYDOWN =
  until
;

: set-color ( b g r -- )
  color c!
  color 1 + c!
  color 2 + c!
;

: get-pixel-addr ( x y -- addr )
  pixels @ -rot #stride * swap 4 * + +
;

: set-pixel ( addr -- )
  dup color     c@ swap c!
  dup color 1 + c@ swap 1 + c!
      color 2 + c@ swap 2 + c!
;

: put-pixel ( x y -- )
  get-pixel-addr set-pixel
;

: pixel-off? ( x y -- t )
  dup #height >= swap 0 < or swap
  dup #width >= swap 0 < or
  or
;

: clear-screen ( -- )
  #stride #height * pixels @ + pixels @ do
    0 i c!
  loop
;

: init-sdl
  SDL_INIT_EVERYTHING sdl-init
  0<> if ." Error sdl-init" exit then

  #width #height 32 SDL_SWSURFACE sdl-set-video-mode
  dup 0< if ." Error sdl-set-video-mode" exit then surface !

  \ save screen buffer address
  surface @ sdl-pixels-offset + @ pixels !
;

: flip-screen surface @ sdl-flip throw ;

previous definitions

[then]