├── LICENSE ├── README.md ├── forth_traced.png ├── scene.fs ├── traced.ppm ├── traced002.png ├── traced01.ppm ├── tracer.fs └── vector.fs /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 John Ladan 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # forth-tracer 2 | A ray tracer written in Forth 3 | 4 | ![sample output of 5 spheres](./forth_traced.png) 5 | 6 | [Forth](https://en.wikipedia.org/wiki/Forth_(programming_language)) is a stack-based language from the 70s. I was inspired to write this program in 2012 after ssalbiz gave a tutorial in writing a raytracer at a CSC code party. 7 | 8 | ## Capabilities 9 | It is a quite rudimentary ray tracer, handling 10 | - spheres 11 | - coloured point light sources 12 | - diffuse and specular shading 13 | - shadows 14 | - ambient light 15 | 16 | Looks like I threw in 4x4 anti-aliasing as well (according to the code), but I don't see it in the output. 17 | 18 | ## Running 19 | You can run Forth using [gforth](https://www.gnu.org/software/gforth/gforth.html). Packages are included in most linux distros, and as part of Homebrew on Mac OS X. 20 | 21 | To run the program, 22 | 23 | gforth vector.fs scene.fs tracer.fs 24 | 25 | The rendered file is saved to `traced.ppm` (a ppm file is an easy image format to output). 26 | -------------------------------------------------------------------------------- /forth_traced.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jladan/forth-tracer/cd4269b1f820ab82e3d6b9887260b16bbc682e8d/forth_traced.png -------------------------------------------------------------------------------- /scene.fs: -------------------------------------------------------------------------------- 1 | \ Words for working with scene objects 2 | 3 | \ Spheres 4 | : svariable falign create 4 floats allot ; 5 | 6 | : s! ( sphere -- ) ( f: f f f f -- ) 7 | 0 3 do 8 | dup I set-index 9 | -1 +loop 10 | drop ; 11 | 12 | : s@radius ( sphere -- ) ( f: -- f ) 13 | 3 get-index ; 14 | 15 | 16 | \ Lights ( position and colour ) 17 | : lvariable falign create 6 floats allot ; 18 | 19 | : lcolour ( light_addr -- colour_addr ) 20 | 3 floats + ; 21 | 22 | : l! ( light -- ) ( f: x y z r g b -- ) 23 | dup lcolour v! 24 | v! ; 25 | 26 | : l@ ( light -- ) ( f: x y z r g b -- ) 27 | dup v@ lcolour v@ ; 28 | 29 | \ Materials ( colour, colour, shininess, mirror ) 30 | : mvariable falign create 8 floats allot ; 31 | 32 | : mdiffuse ( material -- colour ) 33 | 0 floats + ; 34 | 35 | : mspecular ( material -- colour ) 36 | 3 floats + ; 37 | 38 | : mshininess ( material -- addr ) 39 | 6 floats + ; 40 | 41 | : mmirror ( material -- addr ) 42 | 7 floats + ; 43 | 44 | : m! ( material [8 floats] -- ) 45 | dup mmirror f! 46 | dup mshininess f! 47 | dup mspecular v! 48 | dup mdiffuse v! 49 | ; 50 | 51 | \ extra stuff 52 | : deg>rad 180e0 f/ 3.14159265e0 f* ; 53 | -------------------------------------------------------------------------------- /traced.ppm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jladan/forth-tracer/cd4269b1f820ab82e3d6b9887260b16bbc682e8d/traced.ppm -------------------------------------------------------------------------------- /traced002.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jladan/forth-tracer/cd4269b1f820ab82e3d6b9887260b16bbc682e8d/traced002.png -------------------------------------------------------------------------------- /traced01.ppm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jladan/forth-tracer/cd4269b1f820ab82e3d6b9887260b16bbc682e8d/traced01.ppm -------------------------------------------------------------------------------- /tracer.fs: -------------------------------------------------------------------------------- 1 | \ scene geometry definition 2 | 3 | vvariable cam_position 4 | 0e0 0e0 800e0 cam_position v! 5 | vvariable cam_direction 6 | 0e0 0e0 -1e0 cam_direction v! 7 | 8 | vvariable ver 9 | 0e0 1e0 0e0 ver v! 10 | vvariable hor 11 | cam_direction ver v-cross hor v! 12 | 13 | 50e0 deg>rad fconstant fov 14 | 15 | vvariable ambient 16 | 0.3e0 0.3e0 0.3e0 ambient v! 17 | 18 | 19 | \ all the spheres 20 | create spheres 5 cells allot 21 | falign 22 | here 0 floats + spheres 0 cells + ! 23 | here 4 floats + spheres 1 cells + ! 24 | here 8 floats + spheres 2 cells + ! 25 | here 12 floats + spheres 3 cells + ! 26 | here 16 floats + spheres 4 cells + ! 27 | 4 floats 5 * allot 28 | 29 | \ lights 30 | create lights 2 cells allot 31 | falign 32 | here 0 floats + lights 0 cells + ! 33 | here 6 floats + lights 1 cells + ! 34 | 6 floats 2 * allot 35 | 36 | \ materials 37 | create mats 5 cells allot 38 | falign 39 | here 0 floats + mats 0 cells + ! 40 | here 8 floats + mats 1 cells + ! 41 | here 16 floats + mats 2 cells + ! 42 | here 24 floats + mats 3 cells + ! 43 | here 32 floats + mats 4 cells + ! 44 | 8 floats 5 * allot 45 | 46 | 47 | 48 | \ Most of the actual tracer 49 | 50 | 51 | \ The tracer settings 52 | 53 | 512 constant width 54 | 512 constant height 55 | 56 | width s>f height s>f f/ fconstant aspect_ratio 57 | 58 | height s>f fov 2e0 f/ ftan f/ 2e0 f/ 59 | fconstant view_len 60 | 61 | 62 | vvariable top_pixel 63 | vvariable ray 64 | vvariable pixel 65 | vvariable vtmp 66 | 67 | vvariable colour 68 | 69 | 1e-6 fconstant epsilon 70 | 71 | variable file-handle 72 | 73 | : write-ppm-header 74 | s" traced.ppm" w/o create-file 75 | 0= if file-handle ! then 76 | s" P6" file-handle @ write-line drop 77 | width s>d <# #s #> file-handle @ write-file drop 78 | 32 file-handle @ emit-file drop 79 | height s>d <# #s #> file-handle @ write-line drop 80 | s" 255" file-handle @ write-line drop 81 | ; 82 | 83 | : p-emit ( colour -- ) 84 | v@ 85 | 1e0 fmin 255e0 f* f>s 86 | 1e0 fmin 255e0 f* f>s 87 | 1e0 fmin 255e0 f* f>s 88 | file-handle @ emit-file drop 89 | file-handle @ emit-file drop 90 | file-handle @ emit-file drop 91 | ; 92 | 93 | \ set the value of top_pixel 94 | : initialize-tracer ( -- ) 95 | 0e0 0e0 -400e0 100e0 spheres 0 cells + @ s! 96 | 200e0 50e0 -100e0 150e0 spheres 1 cells + @ s! 97 | 0e0 -1200e0 -500e0 1000e0 spheres 2 cells + @ s! 98 | -100e0 25e0 -300e0 50e0 spheres 3 cells + @ s! 99 | 0e0 100e0 -250e0 25e0 spheres 4 cells + @ s! 100 | 101 | -100e0 150e0 400e0 7e-1 7e-1 7e-1 lights 0 cells + @ l! 102 | 400e0 100e0 150e0 7e-1 0e0 7e-1 lights 1 cells + @ l! 103 | 104 | 7e-1 1e0 7e-1 5e-1 7e-1 5e-1 25e0 3e-1 mats 0 cells + @ m! 105 | 7e-1 1e0 7e-1 5e-1 7e-1 5e-1 25e0 3e-1 mats 1 cells + @ m! 106 | 5e-1 5e-1 5e-1 5e-1 7e-1 5e-1 25e0 3e-1 mats 2 cells + @ m! 107 | 1e0 6e-1 1e-1 5e-1 7e-1 5e-1 25e0 3e-1 mats 3 cells + @ m! 108 | 7e-1 1e0 7e-1 5e-1 7e-1 5e-1 25e0 3e-1 mats 4 cells + @ m! 109 | 110 | cam_direction view_len vf* top_pixel v! 111 | top_pixel cam_position v+= 112 | ver height s>f f2/ vf* vtmp v! 113 | top_pixel vtmp v+= 114 | hor width s>f f2/ vf* vtmp v! 115 | top_pixel vtmp v-= 116 | ; 117 | 118 | : ray-epsilon-check { normal ray line f: raylen -- flag } 119 | raylen epsilon f> if 120 | ray raylen vf* normal v! \ ray multiplied by root and put in normal 121 | normal line v-= \ line subtracted from result and put in normal 122 | raylen 123 | -1 \ it worked! 124 | else 125 | 0 \ it didn't work :( 126 | then ; 127 | 128 | : quad-roots ( -- numroots ) { f: a f: b f: c -- [f] [f] } 129 | a f0= if 130 | c b f/ fneg \ -c/b 131 | 1 \ one root 132 | else 133 | b fdup f* 134 | a c f2* f2* f* f- ( f: det ) 135 | fdup f0< 0= if 136 | fsqrt 137 | b fneg fover f+ ( f: det -b+det ) 138 | a f/ f2/ fswap ( f: root1 det ) 139 | b fneg fswap f- ( f: det -b-det ) 140 | a f/ f2/ ( f: root1 root2 ) 141 | 2 142 | else 143 | fdrop 144 | 0 145 | then 146 | then ; 147 | 148 | vvariable line 149 | 150 | : intersect-sphere { ray origin sphere normal -- raylen flag } 151 | sphere origin v- line v! 152 | ray ray v-dot 153 | ray line v-dot fneg f2* 154 | line line v-dot sphere s@radius fdup f* f- 155 | 156 | quad-roots 157 | case 158 | 0 of 0 endof 159 | 1 of normal ray line ray-epsilon-check endof 160 | 2 of 161 | fover fover f< if 162 | fdrop 163 | normal ray line ray-epsilon-check 164 | else 165 | fswap fdrop 166 | normal ray line ray-epsilon-check 167 | then 168 | endof 169 | endcase ; 170 | 171 | : intersect-spheres { ray origin normal -- sphere f: raylen flag } 172 | -1 1e10 \ preload sphere = -1, raylen = 10^10 173 | 5 0 do 174 | ray origin spheres i cells + @ vtmp intersect-sphere 175 | if 176 | fover fover f> if \ new raylen is smaller 177 | vtmp v@ normal v! 178 | drop i \ set sphere to current sphere 179 | fswap fdrop \ replace old raylen with new one 180 | endif 181 | endif 182 | loop 183 | dup -1 = if \ we didn't find a sphere 184 | fdrop drop \ clear stacks 185 | 0 \ no intersection 186 | else 187 | -1 \ set flag to true 188 | endif ; 189 | 190 | vvariable diffuse 191 | vvariable specular 192 | vvariable shadow_ray 193 | vvariable normal 194 | vvariable intersection 195 | 196 | : trace { colour ray origin -- } 197 | ray origin normal intersect-spheres 198 | if 199 | 0e0 0e0 0e0 diffuse v! 200 | 0e0 0e0 0e0 specular v! 201 | ray vf* intersection v! 202 | intersection origin v+= 203 | normal v-norm 204 | ray v-norm 205 | 206 | 2 0 do 207 | lights i cells + @ intersection v- shadow_ray v! 208 | shadow_ray intersection vtmp intersect-spheres 209 | if 210 | fdrop drop \ we don't do anything if there's an intersection 211 | else 212 | shadow_ray v-norm 213 | normal shadow_ray v-dot 214 | fdup 215 | fdup f0> if 216 | dup cells mats + @ mdiffuse vf* vtmp v! 217 | vtmp lights i cells + @ lcolour v* vtmp v! 218 | diffuse vtmp v+= 219 | else 220 | fdrop 221 | endif 222 | normal f2* vf* vtmp v! 223 | shadow_ray vtmp v-= 224 | shadow_ray ray v-dot 225 | dup cells mats + @ mshininess f@ f** 226 | fdup f0> if 227 | dup cells mats + @ mspecular vf* vtmp v! 228 | i cells lights + @ lcolour vtmp v* vtmp v! 229 | specular vtmp v+= 230 | else 231 | fdrop \ drop bad specular coefficient 232 | endif 233 | endif 234 | loop 235 | cells mats + @ ambient v* colour v! 236 | colour diffuse v+= 237 | colour specular v+= 238 | else 239 | 0e0 0e0 0e0 colour v! 240 | endif ; 241 | 242 | 243 | : ii R> R> R> R> R> dup >R >R >R >R >R ; 244 | : jj R> R> R> R> R> R> R> dup >R >R >R >R >R >R >R ; 245 | 246 | vvariable sub-pixel 247 | vvariable tmp_colour 248 | 249 | 4 constant naa 250 | 251 | : trace-loop ( -- ) 252 | height 0 do 253 | width 0 do 254 | 0e0 0e0 0e0 colour v! 255 | \ find location of top pixel 256 | hor i s>f vf* pixel v! 257 | ver j s>f fneg vf* vtmp v! 258 | pixel vtmp v+= 259 | pixel top_pixel v+= 260 | \ anti-aliasing 261 | naa 0 do 262 | naa 0 do 263 | hor i s>f naa s>f f/ vf* sub-pixel v! 264 | ver j s>f naa s>f f/ vf* vtmp v! 265 | sub-pixel vtmp v+= 266 | sub-pixel pixel v+= 267 | sub-pixel cam_position v- ray v! 268 | pixel cam_position v- ray v! 269 | tmp_colour ray cam_position trace 270 | colour tmp_colour v+= 271 | loop 272 | loop 273 | naa dup * s>f colour vf/ colour v! 274 | colour p-emit 275 | loop 276 | loop ; 277 | 278 | 279 | initialize-tracer 280 | write-ppm-header 281 | trace-loop 282 | file-handle @ close-file 283 | 284 | bye 285 | -------------------------------------------------------------------------------- /vector.fs: -------------------------------------------------------------------------------- 1 | \ Vector arithmetic library 2 | 3 | : fneg 4 | 0e0 fswap f- ; 5 | 6 | \ makes a 3-vector 7 | \ eg. vvariable x 8 | : vvariable falign create 3 floats allot ; 9 | 10 | \ now for array indexing 11 | : get-index ( vec n --) ( f: -- f) 12 | floats + f@ ; 13 | 14 | : set-index ( vec n --) ( f: f --) 15 | floats + f! ; 16 | 17 | : v@ ( vec --) ( f: -- f f f) 18 | 3 0 do dup I get-index loop drop ; 19 | 20 | : v! ( vec --) ( f: f f f --) 21 | 0 2 do dup I set-index -1 +loop drop ; 22 | 23 | \ vector arithmetic 24 | : v+ ( vec vec --) ( f: -- f f f) 25 | 3 0 26 | do over over I get-index I get-index f+ 27 | loop 28 | drop drop ; 29 | 30 | : v+= ( vec vec -- ) ( f: -- ) 31 | over v+ v! ; 32 | 33 | : v- ( vec vec --) ( f: -- f f f) 34 | swap 35 | 3 0 36 | do 2dup I get-index I get-index f- 37 | loop 38 | drop drop ; 39 | 40 | : v-= ( vec vec -- ) ( f: -- ) 41 | over swap v- v! ; 42 | 43 | : vf* ( vec -- ) ( f: f -- f f f) 44 | 3 0 45 | do fdup dup I get-index f* fswap 46 | loop 47 | fdrop drop ; 48 | 49 | : vf/ ( vec -- f f f ) 50 | 1e0 fswap f/ vf* ; 51 | 52 | : v* ( vec vec --) ( f: -- f f f) 53 | 3 0 54 | do over over I get-index I get-index f* 55 | loop 56 | drop drop ; 57 | 58 | \ dot and cross products 59 | : v-dot ( vec vec -- ) ( f: -- f) 60 | v* f+ f+ ; 61 | 62 | : v-cross ( vec vec --) ( f: -- f f f) 63 | swap 64 | 2dup 2dup 65 | 1 get-index 2 get-index f* 66 | 2 get-index 1 get-index f* 67 | f- 68 | 2dup 2dup 69 | 2 get-index 0 get-index f* 70 | 0 get-index 2 get-index f* 71 | f- 72 | 2dup 73 | 0 get-index 1 get-index f* 74 | 1 get-index 0 get-index f* 75 | f- 76 | ; 77 | 78 | : v-norm ( vec -- ) 79 | dup dup v-dot fsqrt 80 | dup vf/ 81 | v! ; 82 | 83 | \ display vectors 84 | : 3f. ( f: f f f --) 85 | fswap frot f. f. f. ; 86 | 87 | : v. ( vec -- ) 88 | v@ 3f. ; 89 | 90 | --------------------------------------------------------------------------------