1 ! Factor port of the raytracer benchmark from
2 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
4 USING: float-arrays compiler generic io io.files kernel math
5 math.functions math.vectors math.parser namespaces sequences
6 sequences.private words io.encodings.binary ;
7 IN: benchmark.raytracer
11 #! Normalized { -1 -3 2 }.
18 : oversampling 4 ; inline
24 : delta 1.4901161193847656E-8 ; inline
30 TUPLE: hit normal lambda ;
34 GENERIC: intersect-scene ( hit ray scene -- hit )
36 TUPLE: sphere center radius ;
40 : sphere-v ( sphere ray -- v )
41 swap sphere-center swap ray-orig v- ; inline
43 : sphere-b ( ray v -- b ) swap ray-dir v. ; inline
45 : sphere-disc ( sphere v b -- d )
46 sq swap norm-sq - swap sphere-radius sq + ; inline
48 : -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
50 : sphere-b/d ( b d -- t )
51 -+ dup 0.0 < [ 2drop 1.0/0.0 ] [ >r [ 0.0 > ] keep r> ? ] if ; inline
53 : ray-sphere ( sphere ray -- t )
54 2dup sphere-v tuck sphere-b [ sphere-disc ] keep
55 over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
58 : sphere-n ( ray sphere l -- n )
59 pick ray-dir n*v swap sphere-center v- swap ray-orig v+ ;
62 : if-ray-sphere ( hit ray sphere quot -- hit )
63 #! quot: hit ray sphere l -- hit
64 >r pick hit-lambda >r 2dup swap ray-sphere dup r> >=
65 [ 3drop ] r> if ; inline
67 M: sphere intersect-scene ( hit ray sphere -- hit )
68 [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
72 : <group> ( objs bound -- group )
73 { set-group-objs set-delegate } group construct ;
75 : make-group ( bound quot -- )
76 swap >r { } make r> <group> ; inline
78 M: group intersect-scene ( hit ray group -- hit )
81 group-objs [ >r tuck r> intersect-scene swap ] each
85 : initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline
87 : initial-intersect ( ray scene -- hit )
88 initial-hit -rot intersect-scene ; inline
90 : ray-o ( ray hit -- o )
91 over ray-dir over hit-lambda v*n
92 swap hit-normal delta v*n v+
93 swap ray-orig v+ ; inline
95 : sray-intersect ( ray scene hit -- ray )
96 swap >r ray-o light vneg <ray> r> initial-intersect ; inline
98 : ray-g ( hit -- g ) hit-normal light v. ; inline
100 : cast-ray ( ray scene -- g )
101 2dup initial-intersect dup hit-lambda 1.0/0.0 = [
104 dup ray-g >r sray-intersect hit-lambda 1.0/0.0 =
105 [ r> neg ] [ r> drop 0.0 ] if
108 : create-center ( c r d -- c2 )
109 >r 3.0 12.0 sqrt / * r> n*v v+ ; inline
111 DEFER: create ( level c r -- scene )
113 : create-step ( level c r d -- scene )
114 over >r create-center r> 2.0 / >r >r 1 - r> r> create ;
116 : create-offsets ( quot -- )
124 : create-bound ( c r -- sphere ) 3.0 * <sphere> ;
126 : create-group ( level c r -- scene )
129 [ >r 3dup r> create-step , ] create-offsets 3drop
132 : create ( level c r -- scene )
133 pick 1 = [ <sphere> nip ] [ create-group ] if ;
135 : ss-point ( dx dy -- point )
136 [ oversampling /f ] bi@ 0.0 3float-array ;
138 : ss-grid ( -- ss-grid )
139 oversampling [ oversampling [ ss-point ] with map ] map ;
141 : ray-grid ( point ss-grid -- ray-grid )
143 [ v+ normalize { 0.0 0.0 -4.0 } swap <ray> ] with map
146 : ray-pixel ( scene point -- n )
147 ss-grid ray-grid 0.0 -rot
148 [ [ swap cast-ray + ] with each ] with each ;
150 : pixel-grid ( -- grid )
153 [ size 0.5 * - ] bi@ swap size
158 : pgm-header ( w h -- )
159 "P5\n" % swap # " " % # "\n255\n" % ;
161 : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
163 : ray-trace ( scene -- pixels )
164 pixel-grid [ [ ray-pixel ] with map ] with map ;
167 levels { 0.0 -1.0 0.0 } 1.0 create ray-trace [
169 [ [ oversampling sq / pgm-pixel ] each ] each
172 : raytracer-main ( -- )
173 run "raytracer.pnm" temp-file binary set-file-contents ;