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