apps/raytracer.factor

   1 ! Factor port of the raytracer benchmark from
   2 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
   3
   4 USING: arrays compiler generic io kernel math namespaces
   5 sequences test words ;
   6 IN: ray
   7
   8 ! parameters
   9 : light
  10     #! Normalized { -1 -3 2 }.
  11     { -0.2672612419124244 -0.8017837257372732 0.5345224838248488 } ; inline
  12
  13 : oversampling 4 ; inline
  14
  15 : levels 3 ; inline
  16
  17 : size 200 ; inline
  18
  19 : delta 1.4901161193847656E-8 ; inline
  20
  21 TUPLE: ray orig dir ;
  22
  23 TUPLE: hit normal lambda ;
  24
  25 GENERIC: intersect-scene ( hit ray scene -- hit )
  26
  27 TUPLE: sphere center radius ;
  28
  29 : sphere-v ( sphere ray -- v )
  30     swap sphere-center swap ray-orig v- ; inline
  31
  32 : sphere-b ( ray v -- b ) swap ray-dir v. ; inline
  33
  34 : sphere-disc ( sphere v b -- d )
  35     sq swap norm-sq - swap sphere-radius sq + ; inline
  36
  37 : -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
  38
  39 : sphere-b/d ( b d -- t )
  40     -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
  41
  42 : ray-sphere ( sphere ray -- t )
  43     2dup sphere-v tuck sphere-b [ sphere-disc ] keep
  44     over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
  45     inline
  46
  47 : sphere-n ( ray sphere l -- n )
  48     pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
  49     inline
  50
  51 : if-ray-sphere ( hit ray sphere quot -- hit )
  52     #! quot: hit ray sphere l -- hit
  53     >r pick hit-lambda >r 2dup swap ray-sphere dup r> >=
  54     [ 3drop ] r> if ; inline
  55
  56 M: sphere intersect-scene ( hit ray sphere -- hit )
  57     [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
  58
  59 TUPLE: group objs ;
  60
  61 C: group ( objs bound -- group )
  62     [ set-delegate ] keep [ set-group-objs ] keep ;
  63
  64 : make-group ( bound quot -- )
  65     swap >r { } make r> <group> ; inline
  66
  67 M: group intersect-scene ( hit ray group -- hit )
  68     [
  69         drop
  70         group-objs [ >r tuck r> intersect-scene swap ] each
  71         drop
  72     ] if-ray-sphere ;
  73
  74 : initial-hit T{ hit f { 0.0 0.0 0.0 } 1.0/0.0 } ; inline
  75
  76 : initial-intersect ( ray scene -- hit )
  77     initial-hit -rot intersect-scene ; inline
  78
  79 : ray-o ( ray hit -- o )
  80     over ray-dir over hit-lambda v*n
  81     swap hit-normal delta v*n v+
  82     swap ray-orig v+ ; inline
  83
  84 : sray-intersect ( ray scene hit -- ray )
  85     swap >r ray-o light vneg <ray> r> initial-intersect ; inline
  86
  87 : ray-g ( hit -- g ) hit-normal light v. ; inline
  88
  89 : cast-ray ( ray scene -- g )
  90     2dup initial-intersect dup hit-lambda 1.0/0.0 = [
  91         3drop 0.0
  92     ] [
  93         dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
  94         [ r> neg ] [ r> drop 0.0 ] if
  95     ] if ; inline
  96
  97 : create-center ( c r d -- c2 )
  98     >r 3.0 12.0 sqrt / * r> n*v v+ ; inline
  99
 100 DEFER: create ( level c r -- scene )
 101
 102 : create-step ( level c r d -- scene )
 103     over >r create-center r> 2.0 / >r >r 1 - r> r> create ;
 104
 105 : create-offsets ( quot -- )
 106     {
 107         { -1.0 1.0 -1.0 }
 108         { 1.0 1.0 -1.0 }
 109         { -1.0 1.0 1.0 }
 110         { 1.0 1.0 1.0 }
 111     } swap each ; inline
 112
 113 : create-bound ( c r -- sphere ) 3.0 * <sphere> ;
 114
 115 : create-group ( level c r -- scene )
 116     2dup create-bound [
 117         2dup <sphere> ,
 118         [ >r 3dup r> create-step , ] create-offsets 3drop
 119     ] make-group ;
 120
 121 : create ( level c r -- scene )
 122     pick 1 = [ <sphere> nip ] [ create-group ] if ;
 123
 124 : ss-point ( dx dy -- point )
 125     [ oversampling /f ] 2apply 0.0 3array ;
 126
 127 : ss-grid ( -- ss-grid )
 128     oversampling [ oversampling [ ss-point ] map-with ] map ;
 129
 130 : ray-grid ( point ss-grid -- ray-grid )
 131     [
 132         [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] map-with
 133     ] map-with ;
 134
 135 : ray-pixel ( scene point -- n )
 136     ss-grid ray-grid 0.0 -rot
 137     [ [ swap cast-ray + ] each-with ] each-with ;
 138
 139 : pixel-grid ( -- grid )
 140     size reverse [
 141         size [
 142             [ size 0.5 * - ] 2apply swap size >float 3array
 143         ] map-with
 144     ] map ;
 145
 146 : pgm-header ( w h -- )
 147     "P5\n" % swap # " " % # "\n255\n" % ;
 148
 149 : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
 150
 151 : ray-trace ( scene -- pixels )
 152     pixel-grid [ [ ray-pixel ] map-with ] map-with ;
 153
 154 : run ( -- string )
 155     levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
 156         size size pgm-header
 157         [ [ oversampling sq / pgm-pixel ] each ] each
 158     ] "" make ;
 159
 160 : run>file ( file -- )
 161     "Generating " write dup write "..." print
 162     <file-writer> [ run write ] with-stream ;
 163
 164 PROVIDE: apps/raytracer ;
 165
 166 MAIN: apps/raytracer [ "raytracer.pnm" run>file ] time ;