Keskustelu: Projektit: Simple Toy Ray Tracer

\
\ Simple toy ray tracer
\
true app:isgui !

var gui

: WIDTH  512 ;
: HEIGHT 512 ;

WIDTH HEIGHT img:new var, imgbuf

: SPHERE 0 ;
: PLANE  1 ;

[ 0.0, 0.0, 0.0 ] [1,3] mat:new var, origin
[ -0.6, 0.9, 3.1 ] [1,3] mat:new var, point-light

0.1 var, ambient


[ { type:0, xyz:[ -0.2, -0.8, 3.8 ], radius:0.7, color:[ 210, 50, 50 ], mirror:false },
  { type:0, xyz:[ 0.6, 0.5, 3.5 ], radius:0.5, color:[ 255, 255, 255 ], mirror:true },
  { type:1, axis:0, distance:1.5, color:[ 100, 100, 255 ], mirror:false },
  { type:1, axis:1, distance:-1.5, color:[ 100, 255, 100 ], mirror:false },
  { type:1, axis:0, distance:-1.5, color:[ 100, 100, 100 ], mirror:false },
  { type:1, axis:1, distance:1.5, color:[ 100, 255, 255 ], mirror:false },
  { type:1, axis:2, distance:5.0, color:[ 255, 100, 255 ], mirror:false }
] var, primitives


: magnitude  \ mat -- mat
  mat:data nip
  ' n:sqr a:map
  ' n:+ 0 a:reduce
  n:sqrt ;


: normalize  \  mat -- mat
  dup magnitude >r
  mat:data nip
  ( r@ n:/ ) a:map
  rdrop
  [1,3] mat:new ;


: dot3  \ m1 m2 -- n
  mat:trans
  mat:*
  0 mat:get-n nip ;


: sub3  \ m1 m2 -- m3
  mat:data nip ' n:neg a:map [1,3] mat:new mat:+ ;


: sphere-normal  \ point  -- point
  primitives @ "index" t:@ a:@ nip "xyz" m:@ nip [1,3] mat:new sub3
  normalize ;


: plane-normal \ point -- point
  primitives @ "index" t:@ a:@ nip "axis" m:@ nip n:int >r
  [ 0.0, 0.0, 0.0 ] const
  swap mat:data nip r@ a:@ nip primitives @ "index" t:@ a:@ nip "distance" m:@ nip n:-
  r> swap
  a:! [1,3] mat:new
  normalize ;


: light-diffuse  \ normal point -- n
  point-light @ swap sub3
  normalize
  dot3 ;


: light-sphere  \ -- n
  "point" t:@ sphere-normal
  "point" t:@ light-diffuse ;


: light-plane  \ -- n
  point-light @ plane-normal
  "point" t:@ light-diffuse ;


: light-primitive
  primitives @ "index" t:@ a:@ nip "type" m:@ nip
  [ ' light-sphere , ' light-plane ] swap
  caseof
  ambient @ n:max 1.0 swap n:min ;


: reflect  \ ray -- ray
  >r
  primitives @ "index" t:@ a:@ nip "type" m:@ nip 0 n:= if
    "point" t:@ sphere-normal
  else
    origin @ plane-normal
  then
  dup r@ swap dot3 2 n:* mat:n* r> swap sub3 normalize ;


: check-distance  \ distance index
  swap dup >r "distance" t:@ n:< r@ 0.0 n:> and if
    "index" t:!
    r@ "distance" t:!
    true "intersect" t:!
  else
    drop
  then
  rdrop ;


locals:
: ray-sphere  \ origin ray index  --
  dup "index" w:! swap
  >r
  primitives @ swap a:@ nip "xyz" m:@ nip [1,3] mat:new swap sub3 "s" w:!

  r@ r@ dot3 "A" w:!
  -2.0 "s" w:@ r> dot3 n:* "B" w:!
  "s" w:@ dup dot3 primitives @ "index" w:@ a:@ nip "radius" m:@ nip dup n:* n:- "C" w:!
  "B" w:@ dup n:* 4.0 "A" w:@ n:* "C" w:@ n:* n:- "D" w:!

  "D" w:@ 0.0 n:> if
    "C" w:@ -0.00001 n:< if
      1.0
    else
      -1.0
    then \ sign on TOS
    "D" w:@ n:sqrt n:* "B" w:@ n:neg n:+ 2.0 "A" w:@ n:* n:/
    "index" w:@
    check-distance
  then ;


locals:
: ray-plane  \ origin ray index  --
  "index" w:!
  "ray" w:!

  primitives @ "index" w:@ a:@ nip "axis" m:@ nip n:int >r
  "ray" w:@ mat:data nip r@ a:@ nip 0.0 n:= not if
    primitives @ "index" w:@ a:@ nip "distance" m:@ nip
    swap
    mat:data nip r@ a:@ nip
    n:-
    "ray" w:@ mat:data nip r@ a:@ nip n:/
    "index" w:@
    check-distance
  else
    drop
  then
  rdrop ;


: ray-primitive  \ origin ray index --
  dup primitives @ swap a:@ nip "type" m:@ nip
  [ ' ray-sphere , ' ray-plane ] swap
  caseof ;


: raytrace \ origin ray  --
  false "intersect" t:!
  999999.9 "distance" t:!

  ( >r 2dup r> ray-primitive ) 0 primitives @ a:len nip n:1- loop 2drop ;


: compute-pixel-color  \  origin ray  -- color
  dup >r raytrace "intersect" t:@ if
    r@ const "distance" t:@ mat:n* "point" t:!

    \ Test if ray hit mirror object.
    \ Reflect ray off the surface and follow the reflected ray.
    primitives @ "index" t:@ a:@ nip "mirror" m:@ nip if
      r@ reflect dup
      "point" t:@ swap raytrace
      "intersect" t:@ if
        "distance" t:@ mat:n* "point" t:@ mat:+ "point" t:!
      else
        drop
      then
    then

    \ We follow the ray from
    \ point light into the object. If it hits some other object first,
    \ we know we are in shadow (use ambient color of original object).
    \ Else we need to compute the lighting (diffuse + ambient).
    "index" t:@ >r
    point-light @ "point" t:@ point-light @ sub3 raytrace
    r@ "index" t:@ n:= if
      light-primitive
    else
      ambient @
    then
    dup dup 3 a:close primitives @ r> a:@ nip "color" m:@ nip ( n:* n:int ) a:2map 255 a:push
  else
    ambient @ dup dup 3 a:close [ 255, 255, 255 ] ( n:* n:int ) a:2map 255 a:push
  then
  rdrop ;


: render
  -1 sleep
  (
    imgbuf lock drop
    (
      dup >r WIDTH n:/ 0.5 n:-
      over HEIGHT n:/ 0.5 n:- n:neg
      1.0 3 a:close

      [1,3] mat:new origin @ swap
      compute-pixel-color >r imgbuf @
      over r> r> swap img:pix! drop
    ) 0 WIDTH n:1- loop
    imgbuf unlock drop
    gui @ g:invalidate 2drop

    \ wait for the draw to complete before resuming
    -1 sleep
  ) 0 HEIGHT n:1- loop ;


: notify-renderer \ gui --
  "task" g:m@ nip t:notify ;


: do-draw
  imgbuf lock @ 0 0 g:image-at imgbuf unlock drop
  notify-renderer ;


: app:main
  \ Start the update task, but it will sleep until the GUI is ready:
  ' render t:task
  \ Define our GUI...
  {
    kind: "win",
    title: "Simple Toy Ray Tracer",
    wide: 512,
    high: 512,
    nobg: true,
    center: true,
    resizable: false,
    font: "Arial 10",
    \ Gets invoked when the GUI is present.  Save the new gui handle, and start
    \ the update task (outside this callback):
    init: ( gui ! notify-renderer ) ,
    draw: "do-draw"
  }
  \ And save the task in our GUI map:
  "task" rot m:!
  \ Create the GUI (don't have to save the gui item, we do that in 'init'):
  g:new ;