# Copyright: 2008-2024 Paul Obermeier (obermeier@tcl3d.org)
#
# See the file "Tcl3D_License.txt" for information on
# usage and redistribution of this file, and for a
# DISCLAIMER OF ALL WARRANTIES.
#
# Module: Tcl3DSpecificDemos
# Filename: rtVis.tcl
#
# Author: Paul Obermeier
#
# Description: Ray Tracing visualization program.
# The comments of the rtvis* procedures explain how to
# use the ray-tracing visualization commands.
set auto_path [linsert $auto_path 0 [file dirname [info script]]]
package require Tk
package require tcl3d
# Define virtual events for OS independent mouse handling.
tcl3dAddEvents
# Font to be used in the Tk listbox.
set g_listFont {-family {Courier} -size 10}
# Create a photo image to hold the pixel color values.
set g_Photo [image create photo]
set g_WinWidth 512
set g_WinHeight 512
# Determine the directory of this script.
set g_ScriptDir [file dirname [info script]]
set g_LastDir $g_ScriptDir
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
# Draw a textured box with style "type". Type can be GL_QUADS or GL_LINE_LOOPS.
# The box is specified by the lower-left and upper-right corners.
# A C version of this proc called tcl3dBox was introduced after version 0.3.3.
proc tcl3dBoxTcl { lowerLeft upperRight type } {
set llx [lindex $lowerLeft 0]
set lly [lindex $lowerLeft 1]
set llz [lindex $lowerLeft 2]
set urx [lindex $upperRight 0]
set ury [lindex $upperRight 1]
set urz [lindex $upperRight 2]
# Front Face
glBegin $type
glNormal3f 0.0 0.0 0.5
glTexCoord2f 0.0 0.0 ; glVertex3f $llx $lly $urz
glTexCoord2f 1.0 0.0 ; glVertex3f $urx $lly $urz
glTexCoord2f 1.0 1.0 ; glVertex3f $urx $ury $urz
glTexCoord2f 0.0 1.0 ; glVertex3f $llx $ury $urz
glEnd
# Back Face
glBegin $type
glNormal3f 0.0 0.0 -0.5
glTexCoord2f 1.0 0.0 ; glVertex3f $llx $lly $llz
glTexCoord2f 1.0 1.0 ; glVertex3f $llx $ury $llz
glTexCoord2f 0.0 1.0 ; glVertex3f $urx $ury $llz
glTexCoord2f 0.0 0.0 ; glVertex3f $urx $lly $llz
glEnd
# Top Face
glBegin $type
glNormal3f 0.0 0.5 0.0
glTexCoord2f 0.0 1.0 ; glVertex3f $llx $ury $llz
glTexCoord2f 0.0 0.0 ; glVertex3f $llx $ury $urz
glTexCoord2f 1.0 0.0 ; glVertex3f $urx $ury $urz
glTexCoord2f 1.0 1.0 ; glVertex3f $urx $ury $llz
glEnd
# Bottom Face
glBegin $type
glNormal3f 0.0 -0.5 0.0
glTexCoord2f 1.0 1.0 ; glVertex3f $llx $lly $llz
glTexCoord2f 0.0 1.0 ; glVertex3f $urx $lly $llz
glTexCoord2f 0.0 0.0 ; glVertex3f $urx $lly $urz
glTexCoord2f 1.0 0.0 ; glVertex3f $llx $lly $urz
glEnd
# Right Face
glBegin $type
glNormal3f 0.5 0.0 0.0
glTexCoord2f 1.0 0.0 ; glVertex3f $urx $lly $llz
glTexCoord2f 1.0 1.0 ; glVertex3f $urx $ury $llz
glTexCoord2f 0.0 1.0 ; glVertex3f $urx $ury $urz
glTexCoord2f 0.0 0.0 ; glVertex3f $urx $lly $urz
glEnd
# Left Face
glBegin $type
glNormal3f -0.5 0.0 0.0
glTexCoord2f 0.0 0.0 ; glVertex3f $llx $lly $llz
glTexCoord2f 1.0 0.0 ; glVertex3f $llx $lly $urz
glTexCoord2f 1.0 1.0 ; glVertex3f $llx $ury $urz
glTexCoord2f 0.0 1.0 ; glVertex3f $llx $ury $llz
glEnd
}
# C-based tcl3dBox function introduced in Tcl3D version 0.4.0.
if { [info commands tcl3dBox] eq "" } {
rename tcl3dBoxTcl tcl3dBox
}
# Print message into info widget at the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
# Print message into status widget at the bottom of the window.
proc PrintOut { msg } {
global g_Gui
$g_Gui(out) insert end "$msg\n"
$g_Gui(out) see end
update
}
proc InitVars {} {
global g_Img g_Cur g_Gui g_Args g_Draw g_AccStructs
catch {$g_Img(canvas) delete "Patches"}
catch {$g_Gui(out) delete 1.0 end}
catch {$g_Gui(aabb,lbox) delete 0 end}
catch {unset g_Img}
catch {unset g_Cur}
catch {unset g_Draw}
catch {unset g_AccStructs}
set g_Draw(bbox,xmin) 1.0E10
set g_Draw(bbox,ymin) 1.0E10
set g_Draw(bbox,zmin) 1.0E10
set g_Draw(bbox,xmax) -1.0E10
set g_Draw(bbox,ymax) -1.0E10
set g_Draw(bbox,zmax) -1.0E10
set g_Draw(camDist) 5.0
set g_AccStructs(curAsList) [list]
set g_Args(ray,prim,color) [list 1 1 1]
set g_Args(ray,refl,color) [list 1 1 0]
set g_Args(ray,shad,color) [list 0 1 1]
set g_Args(geom,1,color) [list 1 0.0 0.0]
set g_Args(geom,0,color) [list 1 0.5 0.0]
set g_Args(aabb,0,color) [list 0 1 0.0]
set g_Args(aabb,1,color) [list 0 1 0.5]
set g_Args(thread,maxThreads) 5
set g_Args(thread,numThreadColumns) 5
set g_Args(thread,0,color) "red"
set g_Args(thread,1,color) "green"
set g_Args(thread,2,color) "blue"
set g_Args(thread,3,color) "yellow"
for { set thread 0 } { $thread < $g_Args(thread,maxThreads) } { incr thread } {
set g_Args(thread,$thread,show) 1
}
set g_Args(patches,show) 1
# Variables to select which types of objects should be drawn.
set g_Args(ray,show) 1
set g_Args(ray,prim,show) 1
set g_Args(ray,refl,show) 1
set g_Args(ray,shad,show) 1
set g_Args(geom,show) 1
set g_Args(geom,showStatic) 1
set g_Args(geom,showDynamic) 1
set g_Args(geom,useLines) 1
set g_Args(lgt,show) 1
set g_Args(lgt,useLines) 1
set g_Args(aabb,maxLevels) 25
set g_Args(aabb,numLevelColumns) 5
set g_Args(aabb,show) 1
set g_Args(aabb,useLines) 1
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
set g_Args(aabb,$level,show) 1
}
set g_Args(ray,cutoff) 1000
set g_Args(fov) 60.0
}
proc InitPhoto { w h } {
global g_Photo g_Gui
$g_Photo configure -width $w -height $h
$g_Photo blank
$g_Gui(canvas) configure -width $w -height $w
}
proc ResetTfms {} {
global g_Gui
set g_Gui(tx) 0.0
set g_Gui(ty) 0.0
set g_Gui(tz) 0.0
set g_Gui(rx) 0.0
set g_Gui(ry) 0.0
set g_Gui(rz) 0.0
set g_Gui(rotCenX) 0.0
set g_Gui(rotCenY) 0.0
set g_Gui(rotCenZ) 0.0
}
proc SetViewPoint { type } {
global g_Gui g_Draw g_Args
ResetTfms
if { $type eq "origin" } {
set g_Draw(camDist) 5.0
} else {
set xsize [expr {$g_Draw(bbox,xmax) - $g_Draw(bbox,xmin)}]
set ysize [expr {$g_Draw(bbox,ymax) - $g_Draw(bbox,ymin)}]
set zsize [expr {$g_Draw(bbox,zmax) - $g_Draw(bbox,zmin)}]
set maxSize 0.0
set maxSize [Max $maxSize $xsize]
set maxSize [Max $maxSize $ysize]
set maxSize [Max $maxSize $zsize]
set g_Draw(camDist) [expr {0.5 * $maxSize / \
tan (3.1415926 / 180.0 * (0.5 * $g_Args(fov)))}]
set g_Gui(rotCenX) [expr {-1.0 * ($g_Draw(bbox,xmin) + $xsize * 0.5)}]
set g_Gui(rotCenY) [expr {-1.0 * ($g_Draw(bbox,ymin) + $ysize * 0.5)}]
set g_Gui(rotCenZ) [expr {-1.0 * ($g_Draw(bbox,zmin) + $zsize * 0.5)}]
}
$g_Gui(toglwin) postredisplay
}
proc UpdateViewPoint {} {
global g_Gui
SetViewPoint $g_Gui(viewPoint)
}
proc RotX { w angle } {
global g_Gui
set g_Gui(rx) [expr {$g_Gui(rx) + $angle}]
$w postredisplay
}
proc RotY { w angle } {
global g_Gui
set g_Gui(ry) [expr {$g_Gui(ry) + $angle}]
$w postredisplay
}
proc RotZ { w angle } {
global g_Gui
set g_Gui(rz) [expr {$g_Gui(rz) + $angle}]
$w postredisplay
}
proc HandleRot {x y win} {
global cx cy
RotY $win [expr {180.0 * (double($x - $cx) / [winfo width $win])}]
RotX $win [expr {180.0 * (double($y - $cy) / [winfo height $win])}]
set cx $x
set cy $y
}
proc IncrTransScale { val } {
global g_Gui
set g_Gui(transScale) [expr $g_Gui(transScale) + $val]
if { $g_Gui(transScale) <= 0.0 } {
set g_Gui(transScale) 0.1
}
}
proc HandleTrans {axis x y win} {
global cx cy
global g_Gui
if { $axis != "Z" } {
set g_Gui(tx) [expr {$g_Gui(tx) + $g_Gui(transScale) * double($x - $cx)}]
set g_Gui(ty) [expr {$g_Gui(ty) - $g_Gui(transScale) * double($y - $cy)}]
} else {
set g_Gui(tz) [expr {$g_Gui(tz) + $g_Gui(transScale) * (double($cy - $y))}]
}
set cx $x
set cy $y
$win postredisplay
}
proc CalcBBox { v } {
global g_Draw
set x [lindex $v 0]
set y [lindex $v 1]
set z [lindex $v 2]
if { $x > $g_Draw(bbox,xmax) } {
set g_Draw(bbox,xmax) $x
}
if { $x < $g_Draw(bbox,xmin) } {
set g_Draw(bbox,xmin) $x
}
if { $y > $g_Draw(bbox,ymax) } {
set g_Draw(bbox,ymax) $y
}
if { $y < $g_Draw(bbox,ymin) } {
set g_Draw(bbox,ymin) $y
}
if { $z > $g_Draw(bbox,zmax) } {
set g_Draw(bbox,zmax) $z
}
if { $z < $g_Draw(bbox,zmin) } {
set g_Draw(bbox,zmin) $z
}
}
#
# Utility procedures for drawing the Ray-Tracing information.
#
# Draw a triangle given by it's vertices (v1, v2, v3) with color "color".
# If the global flag "useLines" is true, the triangle is drawn
# in line mode; otherwise it is rendered solid.
# v1, v2, v3 and color are 3D vectors supplied as Tcl lists.
proc DrawTriangle { v1 v2 v3 color } {
global g_Args
if { $g_Args(geom,useLines) } {
glBegin GL_LINE_LOOP
} else {
glBegin GL_TRIANGLES
}
glColor3fv $color
glVertex3fv $v1
glVertex3fv $v2
glVertex3fv $v3
glEnd
}
# Draw a quad given by it's vertices (v1, v2, v3, v4) with color "color".
# If the global flag "useLines" is true, the quad is drawn
# in line mode; otherwise it is rendered solid.
# v1, v2, v3, v4 and color are 3D vectors supplied as Tcl lists.
proc DrawQuad { v1 v2 v3 v4 color } {
global g_Args
if { $g_Args(geom,useLines) } {
glBegin GL_LINE_LOOP
} else {
glBegin GL_QUADS
}
glColor3fv $color
glVertex3fv $v1
glVertex3fv $v2
glVertex3fv $v3
glVertex3fv $v4
glEnd
}
# Draw a single ray starting at origin "org" looking into direction "dir".
# The ray is drawn as a line with length "len" and color "color".
# org, dir and color are 3D vectors supplied as Tcl lists.
proc DrawRay { org dir len color } {
glBegin GL_LINES
glColor3fv $color
glVertex3fv $org
set endPoint [list 0.0 0.0 0.0]
lset endPoint 0 [expr {[lindex $org 0] + $len * [lindex $dir 0]}]
lset endPoint 1 [expr {[lindex $org 1] + $len * [lindex $dir 1]}]
lset endPoint 2 [expr {[lindex $org 2] + $len * [lindex $dir 2]}]
glVertex3fv $endPoint
glEnd
}
# Draw a box given by it's lower-left (ll) and upper-right corner "ur"
# with color "color".
# If the global flag "useLines" is true, the box is drawn
# in line mode; otherwise it is rendered solid.
# ll, ur and color are 3D vectors supplied as Tcl lists.
proc DrawBox { ll ur color } {
global g_Args
glColor3fv $color
if { $g_Args(aabb,useLines) } {
tcl3dBox $ll $ur $::GL_LINE_LOOP
} else {
tcl3dBox $ll $ur $::GL_QUADS
}
}
# Draw a sphere at position "pos" with radius "radius". The color of the
# sphere is given with "color". If the global flag "useLines" is true,
# the sphere is drawn in line mode; otherwise it is rendered solid.
# pos and color are 3D vectors supplied as Tcl lists.
proc DrawSphere { pos radius color } {
global g_Args
glPushMatrix
glColor3fv $color
glTranslatef [lindex $pos 0] [lindex $pos 1] [lindex $pos 2]
if { $g_Args(lgt,useLines) } {
glutWireSphere $radius 7 7
} else {
glutSolidSphere $radius 7 7
}
glPopMatrix
}
# Draw a point light at position "pos" with radius "radius" emitting into
# all directions. The color of the light is given with "color".
# If the global flag "useLines" is true, the light sphere is drawn in line mode;
# otherwise it is rendered solid.
# pos, dir and color are 3D vectors supplied as Tcl lists.
proc DrawPointLgt { pos radius color } {
DrawSphere $pos $radius $color
}
# Draw a spot light at position "pos" with radius "radius" emitting into
# direction "dir". The color of the light is given with "color".
# If the global flag "useLines" is true, the light sphere is drawn in line mode;
# otherwise it is rendered solid.
# pos, dir and color are 3D vectors supplied as Tcl lists.
proc DrawSpotLgt { pos dir radius color } {
DrawPointLgt $pos $radius $color
DrawRay $pos $dir [expr {$radius*5.0}] $color
}
#
# Procedures to supply data about Ray-Tracing information.
#
# Announce the image size of the rendered image.
# width and height specify the number of pixels of the image.
# This command must be specified before any of the rtvisPixel
# or rtvisPatch commands.
proc rtvisImageSize { width height } {
global g_Img
# puts "rtvisImageSize $width $height"
set g_Img(width) $width
set g_Img(height) $height
InitPhoto $width $height
}
# Bounding box of the patch rendered by thread "thread".
proc rtvisPatch { thread xmin ymin xmax ymax } {
global g_Img
# puts "rtvisPatch $thread $xmin $ymin $xmax $ymax"
lappend g_Img(patches,coords) [list $xmin $ymin $xmax $ymax]
lappend g_Img(patches,thread) $thread
set g_Img(patches,threadNums,$thread) 1
}
# Announce the rendering of pixel (x, y) by thread "thread".
proc rtvisPixel { thread x y } {
global g_Cur g_Img
# puts "rtvisPixel $thread $x $y"
set g_Cur(x) $x
set g_Cur(y) $y
set g_Cur(thread) $thread
}
# Rendering of pixel (x, y) by thread "thread" results in color (r, g, b, a).
# The color values must be specified as floats in the range of [0, 1].
proc rtvisPixelValue { thread x y r g b a } {
global g_Img g_Photo
# puts "rtvisPixelValue $thread $x $y $r $g $b $a"
if { $r > 1.0 } {
set r 1.0
}
if { $g > 1.0 } {
set g 1.0
}
if { $b > 1.0 } {
set b 1.0
}
set g_Img($x,$y,color) [list $r $g $b $a]
set g_Img($x,$y,thread) $thread
$g_Photo put [tcl3dRgbf2Name $r $g $b] -to $x [expr $g_Img(height) - $y]
}
# Announce a ray rendered by thread "thread" starting at origin "org" looking
# into direction "dir". The intersection point of the ray with an object is
# "len" units away from the origin.
# The ray is of type "type":
# Primary ray : 0
# Reflected ray : 1
# Shadow ray : 2
# org and dir are 3D vectors supplied as Tcl lists.
proc rtvisRay { thread type org dir len } {
global g_Args g_Cur g_Draw g_Img
# puts "rtvisRay $thread $type $org $dir $len"
if { $len > $g_Args(ray,cutoff) } {
return
}
if { $type == 0 } {
set type "prim"
} elseif { $type == 1 } {
set type "refl"
} elseif { $type == 2 } {
set type "shad"
} else {
PrintOut "Error: Unknown ray type $type"
}
lappend g_Img(rays,$g_Cur(x),$g_Cur(y)) \
"DrawRay \{$org\} \{$dir\} $len \{$g_Args(ray,$type,color)\}"
lappend g_Draw(ray,$type,cmd) \
"DrawRay \{$org\} \{$dir\} $len \{$g_Args(ray,$type,color)\}"
}
# Announce a point lightsource located at position "pos" with radius "radius".
# The lightsource emits light of color "color".
# "castShadow" specifies, if this lightsource can cast shadows onto objects.
# pos and color are 3D vectors supplied as Tcl lists.
# The color values must be specified as floats in the range of [0, 1].
proc rtvisLgtPoint { pos color radius castShadow } {
global g_Draw
# puts "rtvisLgtPoint $pos $color $radius $castShadow"
lappend g_Draw(lgt,cmd) \
"DrawPointLgt \{$pos\} $radius \{$color\}"
}
# Announce a spot lightsource located at position "pos" emitting into
# direction "dir". The lightsource has radius "radius".
# The lightsource emits light of color "color".
# "castShadow" specifies, if this lightsource can cast shadows onto objects.
# pos, dir and color are 3D vectors supplied as Tcl lists.
# The color values must be specified as floats in the range of [0, 1].
proc rtvisLgtSpot { pos dir color radius castShadow } {
global g_Draw
# puts "rtvisLgtSpot $pos $dir $color $radius $castShadow"
lappend g_Draw(lgt,cmd) \
"DrawSpotLgt \{$pos\} \{$dir\} $radius \{$color\}"
}
# Announce a geometry object of type triangle.
# The vertices of the triangle are given with "v1", "v2" and "v3".
# v1, v2, v3 are 3D vectors supplied as Tcl lists.
# The optional parameter "isStatic" specifies, if the triangle belongs
# to the static world (1), or to the dynamic world (0).
proc rtvisTriangle { v1 v2 v3 { isStatic 1 } } {
global g_Args g_Draw
CalcBBox $v1
CalcBBox $v2
CalcBBox $v3
# puts "rtvisTriangle $v1 $v2 $v3 $isStatic"
lappend g_Draw(geom,$isStatic,cmd) \
"DrawTriangle \{$v1\} \{$v2\} \{$v3\} \{$g_Args(geom,$isStatic,color)\}"
}
# Announce a geometry object of type quad.
# The vertices of the quad are given with "v1", "v2", "v3" and "v4".
# v1, v2, v3, v4 are 3D vectors supplied as Tcl lists.
# The optional parameter "isStatic" specifies, if the quad belongs
# to the static world (1), or to the dynamic world (0).
proc rtvisQuad { v1 v2 v3 v4 { isStatic 1 } } {
global g_Args g_Draw
CalcBBox $v1
CalcBBox $v2
CalcBBox $v3
CalcBBox $v4
# puts "rtvisQuad $v1 $v2 $v3 $v4 $isStatic"
lappend g_Draw(geom,$isStatic,cmd) \
"DrawQuad \{$v1\} \{$v2\} \{$v3\} \{$v4\} \{$g_Args(geom,$isStatic,color)\}"
}
# Announce a geometry object of type box.
# The box is specified by it's lower-left (ll) and upper-right corners "ur".
# ll and ur are 3D vectors supplied as Tcl lists.
# The optional parameter "isStatic" specifies, if the box belongs
# to the static world (1), or to the dynamic world (0).
proc rtvisBox { ll ur { isStatic 1 } } {
global g_Args g_Draw
CalcBBox $ll
CalcBBox $ur
# puts "rtvisBox $ll $ur $isStatic"
lappend g_Draw(geom,$isStatic,cmd) \
"DrawBox \{$ll\} \{$ur\} \{$g_Args(geom,$isStatic,color)\}"
}
# Announce an AABB cell at level "level".
# Note: Level numbering must start at 1 !!
# The lower-left and upper-right corner of the cell are given with "ll" and "ur".
# ll and ur are 3D vectors supplied as Tcl lists.
# If using multiple acceleration structures, an identifier can be specified
# as optional parameter "asId". This identifier can be any string.
proc rtvisAABB { level ll ur { asId "AS" } } {
global g_Args g_Draw g_AccStructs
# puts "rtvisAABB $level $ll $ur $asId"
if { ! [info exists g_AccStructs($asId,as)] } {
set g_AccStructs($asId,as) 1
lappend g_AccStructs(asList) $asId
if { [llength $g_AccStructs(asList)] == 1 } {
set g_AccStructs($asId,color) $g_Args(aabb,0,color)
} else {
set g_AccStructs($asId,color) $g_Args(aabb,1,color)
}
}
lappend g_Draw(aabb,$asId,$level,cmd) \
"DrawBox \{$ll\} \{$ur\} \{$g_AccStructs($asId,color)\}"
}
# Announce a bounding sphere at level "level".
# Note: Level numbering must start at 1 !!
# The center of the sphere is specified with "pos", it's radius with
# parameter "radius".
# pos is a 3D vectors supplied as a Tcl list.
# If using multiple acceleration structures, an identifier can be specified
# as optional parameter "asId". This identifier can be any string.
proc rtvisBS { level pos radius { asId "AS" } } {
global g_Args g_Draw g_AccStructs
# puts "rtvisBS $level $pos $radius $asId"
if { ! [info exists g_AccStructs($asId,as)] } {
set g_AccStructs($asId,as) 1
lappend g_AccStructs(asList) $asId
if { [llength $g_AccStructs(asList)] == 1 } {
set g_AccStructs($asId,color) $g_Args(aabb,0,color)
} else {
set g_AccStructs($asId,color) $g_Args(aabb,1,color)
}
}
lappend g_Draw(aabb,$asId,$level,cmd) \
"DrawSphere \{$pos\} \{$radius\} \{$g_AccStructs($asId,color)\}"
}
proc Max { a b } {
if { $a > $b } {
return $a
} else {
return $b
}
}
proc LoadScriptFile { fileName } {
global g_Args g_Draw g_Gui g_Img g_AccStructs
InitVars
ResetTfms
PrintOut "Loading script file $fileName ..."
uplevel #0 source [list $fileName]
UpdateViewPoint
PrintOut "Creating display lists ..."
CreateDisplayLists
foreach asId $g_AccStructs(asList) {
$g_Gui(aabb,lbox) insert end $asId
}
$g_Gui(aabb,lbox) selection set 0
set g_AccStructs(curAsList) [lindex $g_AccStructs(asList) 0]
UpdateAABBLevelBtns
for { set thread 0 } { $thread < $g_Args(thread,maxThreads) } { incr thread } {
if { [info exists g_Img(patches,threadNums,$thread)] } {
$g_Gui(thread,$thread,cb) configure -state normal
} else {
$g_Gui(thread,$thread,cb) configure -state disabled
}
}
UpdateTogl
if { [info exists g_Draw(geom,1,cmd)] } {
PrintOut "Number of static triangles : [llength $g_Draw(geom,1,cmd)]"
}
if { [info exists g_Draw(geom,0,cmd)] } {
PrintOut "Number of dynamic triangles: [llength $g_Draw(geom,0,cmd)]"
}
if { [info exists g_Draw(lgt,cmd)] } {
PrintOut "Number of lightsources : [llength $g_Draw(lgt,cmd)]"
}
if { [info exists g_Draw(ray,prim,cmd)] } {
PrintOut "Number of primary rays : [llength $g_Draw(ray,prim,cmd)]"
}
if { [info exists g_Draw(ray,refl,cmd)] } {
PrintOut "Number of reflected rays : [llength $g_Draw(ray,refl,cmd)]"
}
if { [info exists g_Draw(ray,shad,cmd)] } {
PrintOut "Number of shadow rays : [llength $g_Draw(ray,shad,cmd)]"
}
if { [info exists g_AccStructs(asList)] } {
foreach asId $g_AccStructs(asList) {
set sumCells 0
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
if { [info exists g_Draw(aabb,$asId,$level,cmd)] } {
PrintOut "$asId tree level $level has [llength $g_Draw(aabb,$asId,$level,cmd)] cells"
incr sumCells [llength $g_Draw(aabb,$asId,$level,cmd)]
}
}
PrintOut "$asId tree total number of cells: $sumCells"
}
}
}
proc DrawPatchRays { patchNum } {
global g_Img g_Draw
set coords [lindex $g_Img(patches,coords) $patchNum]
set xmin [lindex $coords 0]
set ymin [lindex $coords 1]
set xmax [lindex $coords 2]
set ymax [lindex $coords 3]
set ymin [expr $g_Img(height) - $ymin]
set ymax [expr $g_Img(height) - $ymax]
if { [info exists g_Draw(pixel,dl)] } {
glDeleteLists $g_Draw(pixel,dl) 1
}
set g_Draw(pixel,dl) [glGenLists 1]
glNewList $g_Draw(pixel,dl) GL_COMPILE
for { set x $xmin } { $x <= $xmax } { incr x } {
for { set y $ymax } { $y <= $ymin } { incr y } {
if { [info exists g_Img(rays,$x,$y)] } {
foreach cmd $g_Img(rays,$x,$y) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
}
}
}
glEndList
}
proc DrawPixelRays { x y } {
global g_Img g_Draw
set y [expr $g_Img(height) - $y]
# puts "DrawPixelRays $x $y"
if { [info exists g_Draw(pixel,dl)] } {
glDeleteLists $g_Draw(pixel,dl) 1
}
if { [info exists g_Img(rays,$x,$y)] } {
set g_Draw(pixel,dl) [glGenLists 1]
glNewList $g_Draw(pixel,dl) GL_COMPILE
foreach cmd $g_Img(rays,$x,$y) {
# puts "\t$cmd"
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
}
proc UpdateAABBLevelBtns {} {
global g_Gui g_Args g_Draw g_AccStructs
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
$g_Gui(aabb,$level,cb) configure -state disabled
}
foreach asId $g_AccStructs(curAsList) {
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
if { [info exists g_Draw(aabb,$asId,$level,cmd)] } {
$g_Gui(aabb,$level,cb) configure -state normal
}
}
}
}
proc GetListboxEntry { wid } {
global g_AccStructs
set indList [$wid curselection]
if { [llength $indList] > 0 } {
set g_AccStructs(curAsList) [list]
foreach ind $indList {
set val [$wid get $ind]
lappend g_AccStructs(curAsList) $val
}
}
UpdateAABBLevelBtns
UpdateTogl
}
proc CreateDisplayLists {} {
global g_Args g_Draw g_AccStructs
foreach rayType { "prim" "refl" "shad" } {
if { [info exists g_Draw(ray,$rayType,cmd)] } {
if { [info exists g_Draw(ray,$rayType,dl)] } {
glDeleteLists $g_Draw(ray,$rayType,dl) 1
}
set g_Draw(ray,$rayType,dl) [glGenLists 1]
glNewList $g_Draw(ray,$rayType,dl) GL_COMPILE
foreach cmd $g_Draw(ray,$rayType,cmd) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
}
# Draw static geometry
if { [info exists g_Draw(geom,1,cmd)] } {
if { [info exists g_Draw(geom,1,dl)] } {
glDeleteLists $g_Draw(geom,1,dl) 1
}
set g_Draw(geom,1,dl) [glGenLists 1]
glNewList $g_Draw(geom,1,dl) GL_COMPILE
foreach cmd $g_Draw(geom,1,cmd) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
# Draw dynamic geometry
if { [info exists g_Draw(geom,0,cmd)] } {
if { [info exists g_Draw(geom,0,dl)] } {
glDeleteLists $g_Draw(geom,0,dl) 1
}
set g_Draw(geom,0,dl) [glGenLists 1]
glNewList $g_Draw(geom,0,dl) GL_COMPILE
foreach cmd $g_Draw(geom,0,cmd) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
if { [info exists g_Draw(lgt,cmd)] } {
if { [info exists g_Draw(lgt,dl)] } {
glDeleteLists $g_Draw(lgt,dl) 1
}
set g_Draw(lgt,dl) [glGenLists 1]
glNewList $g_Draw(lgt,dl) GL_COMPILE
foreach cmd $g_Draw(lgt,cmd) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
if { [info exists g_AccStructs(asList)] } {
foreach asId $g_AccStructs(asList) {
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
if { [info exists g_Draw(aabb,$asId,$level,cmd)] } {
if { [info exists g_Draw(aabb,$asId,$level,dl)] } {
glDeleteLists $g_Draw(aabb,$asId,$level,dl) 1
}
set g_Draw(aabb,$asId,$level,dl) [glGenLists 1]
glNewList $g_Draw(aabb,$asId,$level,dl) GL_COMPILE
foreach cmd $g_Draw(aabb,$asId,$level,cmd) {
set retVal [catch {eval $cmd} errMsg]
if { $retVal != 0 } {
PrintOut "Error eval $cmd: $errMsg"
}
}
glEndList
}
}
}
}
}
proc CreateCallback { toglwin } {
glClearColor 0.0 0.1 0.1 0
glEnable GL_DEPTH_TEST
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
global g_Args g_Draw
set w [$toglwin width]
set h [$toglwin height]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective $g_Args(fov) [expr double($w)/double($h)] 0.1 2000.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 $g_Draw(camDist) 0.0 0.0 0.0 0.0 1.0 0.0
}
proc DisplayCallback { toglwin } {
global g_Args g_Draw g_Gui g_AccStructs
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
# Viewport command is not really needed, but has been inserted for
# Mac OSX. Presentation framework (Tk) does not send a reshape event,
# when switching from one demo to another.
glViewport 0 0 [$toglwin width] [$toglwin height]
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 $g_Draw(camDist) 0.0 0.0 0.0 0.0 1.0 0.0
glPushMatrix
glTranslatef $g_Gui(tx) $g_Gui(ty) [expr {-1.0 * $g_Gui(tz)}]
glRotatef $g_Gui(rx) 1.0 0.0 0.0
glRotatef $g_Gui(ry) 0.0 1.0 0.0
glRotatef $g_Gui(rz) 0.0 0.0 1.0
glTranslatef $g_Gui(rotCenX) $g_Gui(rotCenY) $g_Gui(rotCenZ)
if { $g_Args(ray,show) } {
if { $g_Args(ray,prim,show) && [info exists g_Draw(ray,prim,dl)] } {
glCallList $g_Draw(ray,prim,dl)
}
if { $g_Args(ray,refl,show) && [info exists g_Draw(ray,refl,dl)] } {
glCallList $g_Draw(ray,refl,dl)
}
if { $g_Args(ray,shad,show) && [info exists g_Draw(ray,shad,dl)] } {
glCallList $g_Draw(ray,shad,dl)
}
}
if { $g_Args(geom,show) } {
if { $g_Args(geom,showStatic) && [info exists g_Draw(geom,1,dl)] } {
glCallList $g_Draw(geom,1,dl)
}
if { $g_Args(geom,showDynamic) && [info exists g_Draw(geom,0,dl)] } {
glCallList $g_Draw(geom,0,dl)
}
}
if { $g_Args(lgt,show) } {
if { [info exists g_Draw(lgt,dl)] } {
glCallList $g_Draw(lgt,dl)
}
}
if { $g_Args(aabb,show) } {
foreach asId $g_AccStructs(curAsList) {
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
if { $g_Args(aabb,$level,show) && [info exists g_Draw(aabb,$asId,$level,dl)] } {
glCallList $g_Draw(aabb,$asId,$level,dl)
}
}
}
}
if { [info exists g_Draw(pixel,dl)] } {
glCallList $g_Draw(pixel,dl)
}
glPopMatrix
$toglwin swapbuffers
}
proc UpdateTogl { { rebuildDisplayLists false } } {
global g_Args g_Gui g_Img
if { $rebuildDisplayLists } {
CreateDisplayLists
}
DisplayCallback $g_Gui(toglwin)
catch { $g_Gui(canvas) delete "Patches" }
if { $g_Args(patches,show) && [info exists g_Img(patches,coords)] } {
set patchNum 0
foreach coords $g_Img(patches,coords) thread $g_Img(patches,thread) {
if { $g_Args(thread,$thread,show) } {
$g_Gui(canvas) create rectangle $coords \
-tags [list "Patches" "P_$patchNum" "T_$thread"]
$g_Gui(canvas) bind "P_$patchNum" <1> "DrawPatchRays $patchNum ; UpdateTogl"
}
incr patchNum
}
foreach key [array names g_Img "patches,threadNums,*"] {
set thread [lindex [split $key ","] 2]
$g_Gui(canvas) itemconfigure "T_$thread" \
-outline $g_Args(thread,$thread,color)
}
}
}
proc ToggleAABBLevels { onOff } {
global g_Args
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
set g_Args(aabb,$level,show) $onOff
}
UpdateTogl
}
# Trigger loading of a default ray-trace file when running from the presentation framework.
proc StartAnimation {} {
global g_ScriptDir g_Gui g_Args
LoadScriptFile [file join $g_ScriptDir "as-Teapot.rt"]
set g_Gui(tz) 10.0
set g_Args(ray,prim,show) 0
UpdateTogl
}
proc Cleanup { { fullCleanup true } } {
global g_Gui g_Photo
InitVars
if { $fullCleanup } {
if { [info exists g_Photo] } {
image delete $g_Photo
}
foreach var [info globals g_*] {
uplevel #0 unset $var
}
}
}
proc ExitProg {} {
exit
}
proc AskOpen {} {
set fileTypes {
{ "RT files" "*.rt" }
{ "All files" * }
}
if { $::tcl_platform(os) eq "Darwin" && [info exists ::starkit::topdir] } {
set fileName [::tk::dialog::file:: open -filetypes $fileTypes \
-initialdir $::g_LastDir]
} else {
set fileName [tk_getOpenFile -filetypes $fileTypes \
-initialdir $::g_LastDir]
}
if { $fileName != "" } {
set ::g_LastDir [file dirname $fileName]
LoadScriptFile $fileName
}
}
# Start of main program.
InitVars
ResetTfms
set g_Gui(viewPoint) "geometry"
set g_Gui(transScale) 0.1
frame .fr
pack .fr -expand 1 -fill both
# Create the main widgets and frames.
set g_Gui(toglwin) .fr.toglwin
togl $g_Gui(toglwin) -width $g_WinWidth -height $g_WinHeight \
-swapinterval 0 \
-double true -depth true \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback \
-createcommand CreateCallback
frame .fr.btns
frame .fr.imgs
frame .fr.out
label .fr.info
grid $g_Gui(toglwin) -row 0 -column 0 -sticky news
grid .fr.btns -row 0 -column 1 -sticky new
grid .fr.imgs -row 1 -column 0 -sticky new -columnspan 2
grid .fr.info -row 2 -column 0 -sticky news -columnspan 2
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
# Fill the btns frame.
frame .fr.btns.frLoad
pack .fr.btns.frLoad -side top -expand true -fill x
radiobutton .fr.btns.frLoad.oriView -text "CoR: Origin" -variable g_Gui(viewPoint) \
-value "origin" -command UpdateViewPoint
radiobutton .fr.btns.frLoad.midView -text "CoR: Geometry" -variable g_Gui(viewPoint) \
-value "geometry" -command UpdateViewPoint
tcl3dToolhelpAddBinding .fr.btns.frLoad.oriView "Set center of rotation to origin"
tcl3dToolhelpAddBinding .fr.btns.frLoad.midView "Set center of rotation to center of geometry"
button .fr.btns.frLoad.open -text "Load script ..." -command AskOpen
eval pack [winfo children .fr.btns.frLoad] -side left -anchor w -expand 1 -fill x
# - Checkboxes to choose the types of information being displayed.
frame .fr.btns.frRays
pack .fr.btns.frRays -side top -expand true -fill x
frame .fr.btns.frRays.frMain
frame .fr.btns.frRays.frOpts
eval pack [winfo children .fr.btns.frRays] -side top -anchor w -expand 1 -fill x
checkbutton .fr.btns.frRays.frMain.showRays -variable g_Args(ray,show) \
-text "Show rays" -anchor w -bg gray -command UpdateTogl
eval pack [winfo children .fr.btns.frRays.frMain] -side top -anchor w -expand 1 -fill x
checkbutton .fr.btns.frRays.frOpts.showPrim -variable g_Args(ray,prim,show) \
-text "Primary" -anchor w -command UpdateTogl
checkbutton .fr.btns.frRays.frOpts.showRefl -variable g_Args(ray,refl,show) \
-text "Reflected" -anchor w -command UpdateTogl
checkbutton .fr.btns.frRays.frOpts.showShad -variable g_Args(ray,shad,show) \
-text "Shadow" -anchor w -command UpdateTogl
eval pack [winfo children .fr.btns.frRays.frOpts] -side left -anchor w -expand 1 -fill x
frame .fr.btns.frGeom
pack .fr.btns.frGeom -side top -expand true -fill x
frame .fr.btns.frGeom.frMain
frame .fr.btns.frGeom.frOpts
eval pack [winfo children .fr.btns.frGeom] -side top -anchor w -expand 1 -fill x
checkbutton .fr.btns.frGeom.frMain.showGeom -variable g_Args(geom,show) \
-text "Show geometry" -anchor w -bg gray -command UpdateTogl
eval pack [winfo children .fr.btns.frGeom.frMain] -side top -anchor w -expand 1 -fill x
checkbutton .fr.btns.frGeom.frOpts.showGeom1 -variable g_Args(geom,showStatic) \
-text "Static" -anchor w -command "UpdateTogl"
checkbutton .fr.btns.frGeom.frOpts.showGeom0 -variable g_Args(geom,showDynamic) \
-text "Dynamic" -anchor w -command "UpdateTogl"
checkbutton .fr.btns.frGeom.frOpts.useLines -variable g_Args(geom,useLines) \
-text "Lines" -anchor w -command "UpdateTogl true"
eval pack [winfo children .fr.btns.frGeom.frOpts] -side left -anchor w -expand 1 -fill x
frame .fr.btns.frLgt
pack .fr.btns.frLgt -side top -expand true -fill x
checkbutton .fr.btns.frLgt.showLgt -variable g_Args(lgt,show) \
-text "Show lightsources" -anchor w -bg gray -command UpdateTogl
checkbutton .fr.btns.frLgt.useLines -variable g_Args(lgt,useLines) \
-text "Lines" -anchor w -command "UpdateTogl true"
eval pack [winfo children .fr.btns.frLgt] -side top -anchor w -expand 1 -fill x
frame .fr.btns.frAABB
pack .fr.btns.frAABB -side top -expand true -fill x
checkbutton .fr.btns.frAABB.showAABB -variable g_Args(aabb,show) \
-text "Show acc. structures" -anchor w -bg gray -command UpdateTogl
checkbutton .fr.btns.frAABB.useLines -variable g_Args(aabb,useLines) \
-text "Lines" -anchor w -command "UpdateTogl true"
frame .fr.btns.frAABB.frLB
eval pack [winfo children .fr.btns.frAABB] -side top -anchor w -expand 1 -fill x
set g_Gui(aabb,lbox) [tcl3dCreateScrolledListbox \
.fr.btns.frAABB.frLB "" -height 3 -selectmode extended \
-exportselection false]
bind $g_Gui(aabb,lbox) <<ListboxSelect>> "GetListboxEntry $g_Gui(aabb,lbox)"
labelframe .fr.btns.frLev -text "Levels"
pack .fr.btns.frLev -side top -expand true -fill x
set row 0
set col 0
for { set level 1 } { $level <= $g_Args(aabb,maxLevels) } { incr level } {
checkbutton .fr.btns.frLev.cb_$row$col -variable g_Args(aabb,$level,show) \
-text $level -anchor w -state disabled -command UpdateTogl
set g_Gui(aabb,$level,cb) .fr.btns.frLev.cb_$row$col
grid .fr.btns.frLev.cb_$row$col -row $row -column $col
incr col
if { $col % $g_Args(aabb,numLevelColumns) == 0 } {
incr row
set col 0
}
}
button .fr.btns.frLev.b_on -text "All on" -command "ToggleAABBLevels 1"
button .fr.btns.frLev.b_off -text "All off" -command "ToggleAABBLevels 0"
grid .fr.btns.frLev.b_on -row $row -column 0 -columnspan 2 -sticky nwe
grid .fr.btns.frLev.b_off -row $row -column 2 -columnspan 2 -sticky nwe
frame .fr.btns.frPatches
pack .fr.btns.frPatches -side top -expand true -fill x
checkbutton .fr.btns.frPatches.showPatches -variable g_Args(patches,show) \
-text "Show patches" -anchor w -bg gray -command UpdateTogl
eval pack [winfo children .fr.btns.frPatches] -side top -anchor w -expand 1 -fill x
labelframe .fr.btns.frThreads -text "Threads"
pack .fr.btns.frThreads -side top -expand true -fill x
set row 0
set col 0
for { set thread 0 } { $thread < $g_Args(thread,maxThreads) } { incr thread } {
checkbutton .fr.btns.frThreads.cb_$row$col -variable g_Args(thread,$thread,show) \
-text $thread -anchor w -state disabled -command UpdateTogl
set g_Gui(thread,$thread,cb) .fr.btns.frThreads.cb_$row$col
grid .fr.btns.frThreads.cb_$row$col -row $row -column $col -sticky nwe
incr col
if { $col % $g_Args(thread,numThreadColumns) == 0 } {
incr row
set col 0
}
}
# - A canvas for displaying the rendered image.
# - Checkboxes to choose thread dependent patch (tile) display.
set g_Gui(canvas) .fr.imgs.c
canvas $g_Gui(canvas) -borderwidth 0 -relief flat -highlightthickness 0 \
-width 100 -height 100
$g_Gui(canvas) create image 0 0 -image $g_Photo -anchor nw -tags "Image"
eval pack [winfo children .fr.imgs] -side left -anchor w -expand 1
frame .fr.imgs.frOut
pack .fr.imgs.frOut -side top -expand true -fill both
set g_Gui(out) [tcl3dCreateScrolledText .fr.imgs.frOut "Output messages" \
-height 10 -borderwidth 1]
$g_Gui(canvas) bind "Image" <1> "DrawPixelRays %x %y ; UpdateTogl"
if { $::tcl_platform(os) eq "Darwin" } {
bind .fr.toglwin <1> {set cx %x; set cy %y}
bind .fr.toglwin <3> {set cx %x; set cy %y}
bind .fr.toglwin <2> {set cx %x; set cy %y}
bind .fr.toglwin <B1-Motion> {HandleRot %x %y %W}
bind .fr.toglwin <B3-Motion> {HandleTrans X %x %y %W}
bind .fr.toglwin <B2-Motion> {HandleTrans Z %x %y %W}
} else {
bind .fr.toglwin <1> {set cx %x; set cy %y}
bind .fr.toglwin <2> {set cx %x; set cy %y}
bind .fr.toglwin <3> {set cx %x; set cy %y}
bind .fr.toglwin <B1-Motion> {HandleRot %x %y %W}
bind .fr.toglwin <B2-Motion> {HandleTrans X %x %y %W}
bind .fr.toglwin <B3-Motion> {HandleTrans Z %x %y %W}
}
bind . <Key-plus> "IncrTransScale 0.1"
bind . <Key-minus> "IncrTransScale -0.1"
wm title . "Tcl3D demo: Ray-Tracing visualization"
# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
PrintInfo [tcl3dOglGetInfoString]
if { [file tail [info script]] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then check for commandline parameters.
if { $argc >= 1 } {
LoadScriptFile [lindex $argv 0]
}
}
|
