# 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

         Raytrace0: 26511967 microseconds per iteration - original
        Raytrace1: 10648166 microseconds per iteration - [update] only once per line
        Raytrace2:  4359732 microseconds per iteration - pixels collected in list, put once per line

Rosetta Code

package require Tcl 8.5
package require Tk

proc normalize vec {
    upvar 1 $vec v
    lassign $v x y z
    set len [expr {sqrt($x**2 + $y**2 + $z**2)}]
    set v [list [expr {$x/$len}] [expr {$y/$len}] [expr {$z/$len}]]
    return
}
 
proc dot {a b} {
    lassign $a ax ay az
    lassign $b bx by bz
    return [expr {-($ax*$bx + $ay*$by + $az*$bz)}]
}
 
# Intersection code; assumes that the vector is parallel to the Z-axis
proc hitSphere {sphere x y z1 z2} {
    dict with sphere {
        set x [expr {$x - $cx}]
        set y [expr {$y - $cy}]
        set zsq [expr {$r**2 - $x**2 - $y**2}]
        if {$zsq < 0} {return 0}
        upvar 1 $z1 _1 $z2 _2
        set zsq [expr {sqrt($zsq)}]
        set _1 [expr {$cz - $zsq}]
        set _2 [expr {$cz + $zsq}]
        return 1
    }
}
 
# How to do the intersection with our scene
proc intersectDeathStar {x y vecName} {
    global big small
    if {![hitSphere $big $x $y zb1 zb2]} {
        # ray lands in blank space
        return 0
    }
    upvar 1 $vecName vec
    # ray hits big sphere; check if it hit the small one first
    set vec [if {
        ![hitSphere $small $x $y zs1 zs2] || $zs1 > $zb1 || $zs2 <= $zb1
    } then {
        dict with big {
            list [expr {$x - $cx}] [expr {$y - $cy}] [expr {$zb1 - $cz}]
        }
    } else {
        dict with small {
            list [expr {$cx - $x}] [expr {$cy - $y}] [expr {$cz - $zs2}]
        }
    }]
    normalize vec
    return 1
}
 
# Intensity calculators for different lighting components
proc diffuse {k intensity L N} {
    expr {[dot $L $N] ** $k * $intensity}
}
proc specular {k intensity L N S} {
    # Calculate reflection vector
    set r [expr {2 * [dot $L $N]}]
    foreach l $L n $N {lappend R [expr {$l-$r*$n}]}
    normalize R
    # Calculate the specular reflection term
    return [expr {[dot $R $S] ** $k * $intensity}]
}
 
# Simple raytracing engine that uses parallel rays
proc raytraceEngine {diffparms specparms ambient intersector shades renderer fx tx sx fy ty sy} {
    global light
    for {set y $fy} {$y <= $ty} {set y [expr {$y + $sy}]} {
        set line {}
        for {set x $fx} {$x <= $tx} {set x [expr {$x + $sx}]} {
            if {![$intersector $x $y vec]} {
                # ray lands in blank space
                set intensity end
            } else {
                # ray hits something; we've got the normalized vector
                set b [expr {
                    [diffuse {*}$diffparms $light $vec]
                    + [specular {*}$specparms $light $vec {0 0 -1}]
                    + $ambient
                }]
                set intensity [expr {int((1-$b) * ([llength $shades]-1))}]
                if {$intensity < 0} {
                    set intensity 0
                } elseif {$intensity >= [llength $shades]-1} {
                    set intensity end-1
                }
            }
            lappend line [lindex $shades $intensity]
        }
        {*}$renderer $line
    }
}
 
# The general scene settings
set light {-50 30 50}
set big   {cx 20 cy 20 cz 0   r 20}
set small {cx 7  cy 7  cz -10 r 15}
normalize light

# Render as a picture (with many hard-coded settings)
proc guiDeathStar {photo diff spec lightBrightness ambient} {
    set row 0
    for {set i 255} {$i>=0} {incr i -1} {
        lappend shades [format "#%02x%02x%02x" $i $i $i]
    }
    raytraceEngine [list $diff $lightBrightness] \
        [list $spec $lightBrightness] $ambient intersectDeathStar \
        $shades {apply {l {
            upvar 2 photo photo row row
            $photo put [list $l] -to 0 $row
            incr row
            update
        }}} 0 40 0.0625 0 40 0.0625
}
pack [label .l -image [image create photo ds]]
guiDeathStar ds 3 10 0.7 0.3

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References