qemu/roms/openbios/forth/testsuite/fract.fs

   1 \ tag: forth fractal example
   2 \
   3 \ Copyright (C) 2002, 2003 Volker Poplawski <volker@poplawski.de>
   4 \                          Stefan Reinauer
   5
   6 \ This example even fits in a signature ;-)
   7
   8 \ hex 4666 dup negate do i 4000 dup 2* negate do 2a 0 dup 2dup 1e 0 do
   9 \ 2swap * d >>a 4 pick + -rot - j + dup dup * e >>a rot dup dup * e >>a
  10 \ rot swap 2dup + 10000 > if 3drop 2drop 20 0 dup 2dup leave then loop
  11 \ 2drop 2drop type 268 +loop cr drop 5de +loop
  12
  13
  14 : fract
  15 4666 dup negate
  16 do
  17     i 4000 dup 2* negate
  18     do
  19         2a 0 dup 2dup 1e 0
  20         do
  21             2swap * d >>a 4 pick +
  22             -rot - j +
  23             dup dup * e >>a rot
  24             dup dup * e >>a rot
  25             swap
  26             2dup + 10000 > if
  27                 3drop 2drop 20 0 dup 2dup leave
  28             then
  29         loop
  30         2drop 2drop
  31         emit
  32     268 +loop
  33     cr drop
  34 5de +loop
  35 ;