extra/benchmark/raytracer/raytracer.factor

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