extra/benchmark/raytracer-simd/raytracer-simd.factor

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