1 ! Factor port of the raytracer benchmark from
2 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
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.parser make sequences
7 sequences.private words hints classes.struct ;
8 IN: benchmark.raytracer-simd
12 ! Normalized { -1 -3 2 }.
21 CONSTANT: oversampling 4
27 : delta ( -- n ) epsilon sqrt ; inline
29 TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
33 TUPLE: hit { normal double-4 read-only } { lambda float read-only } ;
37 GENERIC: intersect-scene ( hit ray scene -- hit )
39 TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
43 : sphere-v ( sphere ray -- v )
44 [ center>> ] [ orig>> ] bi* v- ; inline
46 : sphere-b ( v ray -- b )
49 : sphere-d ( sphere b v -- d )
50 [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
52 : -+ ( x y -- x-y x+y )
53 [ - ] [ + ] 2bi ; inline
55 : sphere-t ( b d -- t )
57 [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
59 : sphere-b&v ( sphere ray -- b v )
60 [ sphere-v ] [ nip ] 2bi
61 [ sphere-b ] [ drop ] 2bi ; inline
63 : ray-sphere ( sphere ray -- t )
64 [ drop ] [ sphere-b&v ] 2bi
65 [ drop ] [ sphere-d ] 3bi
66 dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
68 : if-ray-sphere ( hit ray sphere quot -- hit )
69 #! quot: hit ray sphere l -- hit
71 [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
73 ] dip [ 3drop ] if ; inline
75 : sphere-n ( ray sphere l -- n )
76 [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
77 swap [ v*n ] dip v- v+ ; inline
79 M: sphere intersect-scene ( hit ray sphere -- hit )
80 [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
82 HINTS: M\ sphere intersect-scene { hit ray sphere } ;
84 TUPLE: group < sphere { objs array read-only } ;
86 : <group> ( objs bound -- group )
87 [ center>> ] [ radius>> ] bi rot group boa ; inline
89 : make-group ( bound quot -- )
90 swap [ { } make ] dip <group> ; inline
92 M: group intersect-scene ( hit ray group -- hit )
93 [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
95 HINTS: M\ group intersect-scene { hit ray group } ;
97 CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
99 : initial-intersect ( ray scene -- hit )
100 [ initial-hit ] 2dip intersect-scene ; inline
102 : ray-o ( ray hit -- o )
103 [ [ orig>> ] [ normal>> delta v*n ] bi* ]
104 [ [ dir>> ] [ lambda>> ] bi* v*n ]
107 : sray-intersect ( ray scene hit -- ray )
108 swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
110 : ray-g ( hit -- g ) normal>> light v. ; inline
112 : cast-ray ( ray scene -- g )
113 2dup initial-intersect dup lambda>> 1/0. = [
116 [ sray-intersect lambda>> 1/0. = ] keep swap
117 [ ray-g neg ] [ drop 0.0 ] if
120 : create-center ( c r d -- c2 )
121 [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
123 DEFER: create ( level c r -- scene )
125 : create-step ( level c r d -- scene )
126 over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
128 : create-offsets ( quot -- )
130 double-4{ -1.0 1.0 -1.0 0.0 }
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 }
136 : create-bound ( c r -- sphere ) 3.0 * <sphere> ;
138 : create-group ( level c r -- scene )
141 [ [ 3dup ] dip create-step , ] create-offsets 3drop
144 : create ( level c r -- scene )
145 pick 1 = [ <sphere> nip ] [ create-group ] if ;
147 : ss-point ( dx dy -- point )
148 [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
150 : ss-grid ( -- ss-grid )
151 oversampling [ oversampling [ ss-point ] with map ] map ;
153 : ray-grid ( point ss-grid -- ray-grid )
155 [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
158 : ray-pixel ( scene point -- n )
159 ss-grid ray-grid [ 0.0 ] 2dip
160 [ [ swap cast-ray + ] with each ] with each ;
162 : pixel-grid ( -- grid )
165 [ size 0.5 * - ] bi@ swap size
170 : pgm-header ( w h -- )
171 "P5\n" % swap # " " % # "\n255\n" % ;
173 : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
175 : ray-trace ( scene -- pixels )
176 pixel-grid [ [ ray-pixel ] with map ] with map ;
179 levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
181 [ [ oversampling sq / pgm-pixel ] each ] each
184 : raytracer-main ( -- )
185 run "raytracer.pnm" temp-file binary set-file-contents ;