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

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