1 ! Factor port of the raytracer benchmark from
2 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
4 USING: arrays accessors float-arrays io io.files
5 io.encodings.binary kernel math math.functions math.vectors
6 math.parser make sequences sequences.private words ;
7 IN: benchmark.raytracer
11 #! Normalized { -1 -3 2 }.
18 : oversampling 4 ; inline
24 : delta 1.4901161193847656E-8 ; inline
26 TUPLE: ray { orig float-array read-only } { dir float-array read-only } ;
30 TUPLE: hit { normal float-array read-only } { lambda float read-only } ;
34 GENERIC: intersect-scene ( hit ray scene -- hit )
36 TUPLE: sphere { center float-array read-only } { radius float read-only } ;
40 : sphere-v ( sphere ray -- v )
41 swap center>> swap orig>> v- ; inline
43 : sphere-b ( ray v -- b ) swap dir>> v. ; inline
45 : sphere-disc ( sphere v b -- d )
46 sq swap norm-sq - swap radius>> sq + ; inline
48 : -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
50 : sphere-b/d ( b d -- t )
52 [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
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 ;
59 : sphere-n ( ray sphere l -- n )
60 pick dir>> n*v swap center>> v- swap orig>> v+ ;
63 : if-ray-sphere ( hit ray sphere quot -- hit )
64 #! quot: hit ray sphere l -- hit
66 pick lambda>> [ 2dup swap ray-sphere dup ] dip >=
70 M: sphere intersect-scene ( hit ray sphere -- hit )
71 [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
73 TUPLE: group < sphere { objs array read-only } ;
75 : <group> ( objs bound -- group )
76 [ center>> ] [ radius>> ] bi rot group boa ; inline
78 : make-group ( bound quot -- )
79 swap [ { } make ] dip <group> ; inline
81 M: group intersect-scene ( hit ray group -- hit )
84 objs>> [ [ tuck ] dip intersect-scene swap ] each
88 : initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline
90 : initial-intersect ( ray scene -- hit )
91 initial-hit -rot intersect-scene ; inline
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
98 : sray-intersect ( ray scene hit -- ray )
99 swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
101 : ray-g ( hit -- g ) normal>> light v. ; inline
103 : cast-ray ( ray scene -- g )
104 2dup initial-intersect dup lambda>> 1.0/0.0 = [
107 [ sray-intersect lambda>> 1.0/0.0 = ] keep swap
108 [ ray-g neg ] [ drop 0.0 ] if
111 : create-center ( c r d -- c2 )
112 [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
114 DEFER: create ( level c r -- scene )
116 : create-step ( level c r d -- scene )
117 over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
119 : create-offsets ( quot -- )
127 : create-bound ( c r -- sphere ) 3.0 * <sphere> ;
129 : create-group ( level c r -- scene )
132 [ [ 3dup ] dip create-step , ] create-offsets 3drop
135 : create ( level c r -- scene )
136 pick 1 = [ <sphere> nip ] [ create-group ] if ;
138 : ss-point ( dx dy -- point )
139 [ oversampling /f ] bi@ 0.0 3float-array ;
141 : ss-grid ( -- ss-grid )
142 oversampling [ oversampling [ ss-point ] with map ] map ;
144 : ray-grid ( point ss-grid -- ray-grid )
146 [ v+ normalize F{ 0.0 0.0 -4.0 } swap <ray> ] with map
149 : ray-pixel ( scene point -- n )
150 ss-grid ray-grid 0.0 -rot
151 [ [ swap cast-ray + ] with each ] with each ;
153 : pixel-grid ( -- grid )
156 [ size 0.5 * - ] bi@ swap size
161 : pgm-header ( w h -- )
162 "P5\n" % swap # " " % # "\n255\n" % ;
164 : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
166 : ray-trace ( scene -- pixels )
167 pixel-grid [ [ ray-pixel ] with map ] with map ;
170 levels F{ 0.0 -1.0 0.0 } 1.0 create ray-trace [
172 [ [ oversampling sq / pgm-pixel ] each ] each
175 : raytracer-main ( -- )
176 run "raytracer.pnm" temp-file binary set-file-contents ;