extra/benchmark/mandel/mandel.factor

   1 IN: benchmark.mandel
   2 USING: arrays io kernel math namespaces sequences strings sbufs
   3 math.functions math.parser io.files colors.hsv ;
   4
   5 : max-color 360 ; inline
   6 : zoom-fact 0.8 ; inline
   7 : width 640 ; inline
   8 : height 480 ; inline
   9 : nb-iter 40 ; inline
  10 : center -0.65 ; inline
  11
  12 : scale 255 * >fixnum ; inline
  13
  14 : scale-rgb ( r g b -- n )
  15     rot scale rot scale rot scale 3array ;
  16
  17 : sat 0.85 ; inline
  18 : val 0.85 ; inline
  19
  20 : <color-map> ( nb-cols -- map )
  21     dup [
  22         360 * swap 1+ / 360 / sat val
  23         hsv>rgb scale-rgb
  24     ] curry* map ;
  25
  26 : iter ( c z nb-iter -- x )
  27     over absq 4.0 >= over zero? or
  28     [ 2nip ] [ 1- >r sq dupd + r> iter ] if ; inline
  29
  30 SYMBOL: cols
  31
  32 : x-inc width 200000 zoom-fact * / ; inline
  33 : y-inc height 150000 zoom-fact * / ; inline
  34
  35 : c ( i j -- c )
  36     >r
  37     x-inc * center real x-inc width 2 / * - + >float
  38     r>
  39     y-inc * center imaginary y-inc height 2 / * - + >float
  40     rect> ; inline
  41
  42 : render ( -- )
  43     height [
  44         width swap [
  45             c 0 nb-iter iter dup zero? [
  46                 drop "\0\0\0"
  47             ] [
  48                 cols get [ length mod ] keep nth
  49             ] if %
  50         ] curry each
  51     ] each ;
  52
  53 : ppm-header ( w h -- )
  54     "P6\n" % swap # " " % # "\n255\n" % ;
  55
  56 : sbuf-size width height * 3 * 100 + ;
  57
  58 : mandel ( -- string )
  59     [
  60         sbuf-size <sbuf> building set
  61         width height ppm-header
  62         nb-iter max-color min <color-map> cols set
  63         render
  64         building get >string
  65     ] with-scope ;
  66
  67 : mandel-main ( file -- )
  68     "mandel.ppm" resource-path <file-writer>
  69     [ mandel write ] with-stream ;
  70
  71 MAIN: mandel-main