# Copyright:    2008-2025 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" * }
    }
    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]
    }
}
