Simple Ray Tracer (on a sphere object)
FROM: http://wiki.tcl.tk/10857
(imaged on 2009 mar 19)


 # ray.tcl
 # Author:      Gerard Sookahet
 # Date:        06 Feb 2004
 # Description: Simple raytracer with sphere object

 proc Main {wd ht} {

  set w .ray
  catch {destroy $w}
  toplevel $w
  wm withdraw .
  wm title $w "Raytracing"

  pack [canvas $w.c -width $wd -height $ht -bg white]
  $w.c delete all
  set pix [image create photo]
  $w.c create image 0 0 -anchor nw -image $pix

  set f1 [frame $w.f1 -relief sunken -borderwidth 2]
  pack $f1 -fill x
  button $f1.bcreate -text Render -command "Raytrace $wd $ht $pix"
  button $f1.bq -text Quit -command exit
  eval pack [winfo children $f1] -side left
 }

 proc Raytrace {wd ht pix} {
  for {set y 0} {$y <= $ht} {incr y} {
     set line {}
     for {set x 0} {$x <= $wd} {incr x} {
        set color [IntersectSphere $x $y $wd $ht]
        set R [expr {round([lindex $color 0])}]
        set V [expr {round([lindex $color 1])}]
        set B [expr {round([lindex $color 2])}]
        lappend line [format "#%02X%02X%02X" $R $V $B]
     }
     # 'put' and update once per line for best speed / visual response
     $pix put [list $line] -to 0 $y
     update idletasks
  }
 }

 proc IntersectSphere {x y wd ht} {
 # Center of the sphere
  set cx 0.0
  set cy 0.0
  set cz 0.0
  set radius 1.2
 # Point of view
  set from_x 0.0
  set from_y 0.0
  set from_z 6.0
  set tmin 1000000.0; # Closest intersection distance arbitrarly large

  set to_x [expr {double($x)/double($wd) - $from_x/$wd - 0.5}]
  set to_y [expr {double($y)/double($ht) - $from_y/$ht - 0.5}]
  set to_z [expr {4.0 - $from_z}]

  foreach {to_x to_y to_z} [VectNormalize $to_x $to_y $to_z] {}

  set vect_x [expr {$cx - $from_x}]
  set vect_y [expr {$cy - $from_y}]
  set vect_z [expr {$cz - $from_z}]
 # Solve the ray and sphere intersection equation
  set b [DotProduct $to_x $to_y $to_z $vect_x $vect_y $vect_z]
  set c [DotProduct $vect_x $vect_y $vect_z $vect_x $vect_y $vect_z]
  set c [expr {$c - $radius*$radius}]
  set d [expr {$b*$b - $c}]
  if {$d < 0} then {return [list 0 0 0]}; # No ray intersection
  set dsqrt [expr {sqrt($d)}]
  set t1 [expr {$b + $dsqrt}]
  set t2 [expr {$b - $dsqrt}]
  if {$t1 < 0} then {return [list 0 0 0]}; # Object is behind the point of view
  if {$t2 > 0.0} then {set t $t2} else {set t $t1}
  if {$tmin > $t} then {set tmin $t}
  if {$tmin >= 1000000.0} then {return [list 0 0 0]}
 # Return a color since the ray intersect the sphere
  return [Shading $tmin $from_x $from_y $from_z $to_x $to_y $to_z $cx $cy $cz]
 }

 proc Shading {t from_x from_y from_z to_x to_y to_z cx cy cz} {
 # Normalized light vector <-1,-1,1>
  set l_x -0.577
  set l_y -0.577
  set l_z  0.577
 # Color of the object
  set color_x 0
  set color_y 0
  set color_z 255
 # Ambient light color
  set amb_x 20
  set amb_y 20
  set amb_z 20

  set t_x [expr {$to_x*$t}]
  set t_y [expr {$to_y*$t}]
  set t_z [expr {$to_z*$t}]

  set c_x [expr {$from_x + $t_x - $cx}]
  set c_y [expr {$from_y + $t_y - $cy}]
  set c_z [expr {$from_z + $t_z - $cz}]

  foreach {c_x c_y c_z} [VectNormalize $c_x $c_y $c_z] {}

  set angle [DotProduct $c_x $c_y $c_z $l_x $l_x $l_z]
  if {$angle < 0.0} then {set angle 0.0}
 # Lambert's law light intensity plus an attenuation factor
  set c_x [expr {$color_x*$angle + $amb_x}]
  set c_y [expr {$color_y*$angle + $amb_y}]
  set c_z [expr {$color_z*$angle + $amb_z}]

  set c_x [expr {$c_x > 255 ? 255 : $c_x}]
  set c_y [expr {$c_y > 255 ? 255 : $c_y}]
  set c_z [expr {$c_z > 255 ? 255 : $c_z}]

  return [list $c_x $c_y $c_z]
 }

 proc DotProduct {ax ay az bx by bz} {
  return [expr {$ax*$bx + $ay*$by + $az*$bz}]
 }

 proc VectNormalize {vx vy vz} {
  set d [expr {sqrt($vx*$vx + $vy*$vy + $vz*$vz)}]
  return [list [expr {$vx/$d}] [expr {$vy/$d}] [expr {$vz/$d}]]
 }
 # Size of the screen
 Main 200 200