# simpleTracker.tcl
#
# A Tcl3D widget demo implementing a simple tracking algorithm.
#
# Copyright (C) 2015-2024 Paul Obermeier
# See www.tcl3d.org for the Tcl3D extension.
package require Tk
package require Img
package require tcl3d
# Font to be used in the Tk listbox.
set g_Demo(listFont) {-family {Courier} -size 10}
# Obtain the name of this script file.
set g_Demo(scriptDir) [file dirname [info script]]
# Window size.
set g_Demo(winWidth) 512
set g_Demo(winHeight) 512
# Create a stop watch for time measurement.
set g_Demo(stopWatch) [tcl3dNewSwatch]
set g_Demo(frameCount) 0
set g_Demo(appName) "Tcl3D demo: Simple tracking algorithm"
set g_Demo(numPasses) 0
set g_Demo(outBufferSize) 0
set g_Demo(canvasBuffer) [tcl3dVector GLuint 2]
# Projection matrix.
set g_Demo(projection) [tcl3dVector GLfloat 16]
# ModelView matrix.
set g_Demo(modelview) [tcl3dVector GLfloat 16]
# ModelViewProjection matrix.
set g_Demo(mvp) [tcl3dVector GLfloat 16]
set g_Demo(textures) [tcl3dVector GLuint 2]
set g_Demo(skyTex) [tcl3dVector GLuint 1]
set g_Demo(texCoordOffsets2x2) [list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0]
set g_Demo(posX) -100.0
set g_Demo(posY) -100.0
set g_Demo(fps) 0.0
# Default settings for the redish sphere.
set g_Demo(matAmbient) { 0.1 0.0 0.0 1.0 }
set g_Demo(matSpecular) { 1.0 1.0 1.0 1.0 }
set g_Demo(matShininess) { 100.0 }
set g_Demo(ballon,r) 0.8
set g_Demo(ballon,g) 0.0
set g_Demo(ballon,b) 0.0
set g_Demo(sky,r) 0.0
set g_Demo(sky,g) 0.0
set g_Demo(sky,b) 0.6
set g_Demo(offX) 0.0
set g_Demo(offY) 0.0
set g_Demo(offZ) 5.0
set g_Demo(loopMode) false
set g_Demo(skyMode) false
set g_Demo(ballon,start,x) 5.0
set g_Demo(ballon,start,y) 55.0
set g_Demo(ballon,start,z) 100.0
set g_Demo(ballon,end,x) 0.0
set g_Demo(ballon,end,y) 0.0
set g_Demo(ballon,end,z) 1.4
set g_Demo(sphereSize) 0.4
set g_Demo(numSlices) 15
set g_Demo(numStacks) 15
set g_Demo(skyScale) 5.0
# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
# Print info message into widget at the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
# Print status message into widget at the bottom of the window.
proc PrintStatus { { printToStdout false } } {
global g_Demo
if { [winfo exists .fr.status] } {
set msg [format "Passes: %d FPS: %4.0f (X: %3.2f Y: %3.2f)" \
$g_Demo(numPasses) $g_Demo(fps) $g_Demo(posX) $g_Demo(posY)]
if { $printToStdout } {
puts $msg
} else {
.fr.status configure -text $msg
}
}
}
proc ShowFPS {} {
global g_Demo
set currentTime [tcl3dLookupSwatch $g_Demo(stopWatch)]
# If one second has passed, or if this is the very first frame.
set dt [expr {$currentTime - $g_Demo(lastTime)}]
if { $dt > 1.0 || $g_Demo(frameCount) == 0 } {
set g_Demo(fps) [expr {double($g_Demo(frameCount)) / $dt}]
wm title . [format "%s (%.0f fps)" $g_Demo(appName) $g_Demo(fps)]
set g_Demo(lastTime) $currentTime
set g_Demo(frameCount) 0
}
incr g_Demo(frameCount)
}
proc Animate {} {
global g_Demo
if { $g_Demo(loopMode) } {
incr g_Demo(loopCount)
set incrX [expr { ($g_Demo(ballon,end,x) - $g_Demo(ballon,start,x)) / 1000.0 }]
set incrY [expr { ($g_Demo(ballon,end,y) - $g_Demo(ballon,start,y)) / 1000.0 }]
set incrZ [expr { ($g_Demo(ballon,end,z) - $g_Demo(ballon,start,z)) / 1000.0 }]
if { $g_Demo(loopCount) > 1200 } {
set g_Demo(offX) $g_Demo(ballon,start,x)
set g_Demo(offY) $g_Demo(ballon,start,y)
set g_Demo(offZ) $g_Demo(ballon,start,z)
set g_Demo(loopCount) 0
} elseif { $g_Demo(loopCount) > 1000 } {
} else {
set g_Demo(offX) [expr { $g_Demo(offX) + $incrX }]
set g_Demo(offY) [expr { $g_Demo(offY) + $incrY }]
set g_Demo(offZ) [expr { $g_Demo(offZ) + $incrZ }]
}
}
.fr.toglTrack postredisplay
.fr.toglView postredisplay
set g_Demo(animateId) [tcl3dAfterIdle Animate]
}
proc StartAnimation {} {
global g_Demo
if { ! [info exists g_Demo(animateId)] } {
Animate
tcl3dStartSwatch $g_Demo(stopWatch)
}
}
proc StopAnimation {} {
global g_Demo
if { [info exists g_Demo(animateId)] } {
after cancel $g_Demo(animateId)
unset g_Demo(animateId)
tcl3dStopSwatch $g_Demo(stopWatch)
}
}
proc ToggleLoopMode {} {
global g_Demo
set g_Demo(loopMode) [expr ! $g_Demo(loopMode)]
if { $g_Demo(loopMode) } {
set g_Demo(loopCount) 0
set g_Demo(offX) $g_Demo(ballon,start,x)
set g_Demo(offY) $g_Demo(ballon,start,y)
set g_Demo(offZ) $g_Demo(ballon,start,z)
} else {
set g_Demo(offX) 0.0
set g_Demo(offY) 0.0
set g_Demo(offZ) 5.0
puts "Loop Mode Off"
}
}
proc ToggleSkyMode {} {
global g_Demo
set g_Demo(skyMode) [expr ! $g_Demo(skyMode)]
}
proc ChangeNumPasses { numPasses } {
global g_Demo
set g_Demo(numPasses) $numPasses
if { $g_Demo(numPasses) < 0 } {
set g_Demo(numPasses) 0
}
if { $g_Demo(numPasses) > 9 } {
set g_Demo(numPasses) 9
}
}
proc Pow_wInt { base exp } {
set solution 1.0
for { set i 0 } { $i < [expr {abs($exp) }] } { incr i } {
set solution [expr {$solution * $base}]
}
return $solution
}
proc ComputeCoordinates {} {
global g_Demo
set proxyX 0.0
set proxyY 0.0
set proxyElements 0.0
for { set i 0 } { $i < $g_Demo(outBufferSize) } { incr i 4 } {
set val0 [GLubyte_getitem $g_Demo(outputVec) $i]
if { $val0 != 0 } {
set val1 [GLubyte_getitem $g_Demo(outputVec) [expr {$i + 1}]]
set val2 [GLubyte_getitem $g_Demo(outputVec) [expr {$i + 2}]]
set decodedElements [expr {pow (2, 0.25 * $val2) }]
set proxyX [expr {$proxyX + $val0 * $decodedElements }]
set proxyY [expr {$proxyY + $val1 * $decodedElements }]
set proxyElements [expr {$proxyElements + $decodedElements}]
}
}
if { $proxyElements != 0.0 } {
set g_Demo(posX) [expr {2.0 * $proxyX / $proxyElements}]
set g_Demo(posY) [expr {2.0 * $proxyY / $proxyElements}]
} else {
set g_Demo(posX) -100
set g_Demo(posY) -100
if { $g_Demo(numPasses) > 0 } {
puts "Lost tracking"
}
}
}
proc CreateShader { index vertexShaderFile fragmentShaderFile } {
global g_Demo g_ProgramDict
# Load the source of the vertex shader.
set vertexSource [tcl3dOglReadShaderFile [file join $g_Demo(scriptDir) $vertexShaderFile]]
# Load the source of the fragment shader.
set fragmentSource [tcl3dOglReadShaderFile [file join $g_Demo(scriptDir) $fragmentShaderFile]]
set g_ProgramDict($index) [tcl3dOglBuildProgram $vertexSource "" "" "" $fragmentSource]
set program [dict get $g_ProgramDict($index) program]
return $program
}
proc SetupShaders {} {
global g_Demo
# Create the shader object for the Hue shader.
set program [CreateShader 1 "Hue.vert" "Hue.frag"]
set g_Demo(loc_hue_vertex) [glGetAttribLocation $program "myVertex"]
set g_Demo(loc_hue_texCoords) [glGetAttribLocation $program "myTexCoord"]
set g_Demo(loc_hue_mvp) [glGetUniformLocation $program "mvp"]
set g_Demo(loc_hue_texMap) [glGetUniformLocation $program "texMap"]
# Create the shader object for the Tracking shader.
set program [CreateShader 2 "Hue.vert" "CenterOfMass.frag"]
set g_Demo(loc_CoM_vertex) [glGetAttribLocation $program "myVertex"]
set g_Demo(loc_CoM_texCoords) [glGetAttribLocation $program "myTexCoord"]
set g_Demo(loc_CoM_mvp) [glGetUniformLocation $program "mvp"]
set g_Demo(loc_CoM_texMap) [glGetUniformLocation $program "texMap"]
set g_Demo(loc_CoM_texCoordOffset) [glGetUniformLocation $program "offsets2x2"]
}
proc SetupGeometry {} {
global g_Demo
set vertList {
-1.0 -1.0 0.0
1.0 -1.0 0.0
-1.0 1.0 0.0
1.0 1.0 0.0
}
set vertVec [tcl3dVectorFromList GLfloat $vertList]
set vertVecSize [expr [llength $vertList] * [$vertVec elemsize]]
set uvList {
0.0 0.0
1.0 0.0
0.0 1.0
1.0 1.0
}
set uvVec [tcl3dVectorFromList GLfloat $uvList]
set uvVecSize [expr [llength $uvList] * [$uvVec elemsize]]
glGenBuffers 2 $g_Demo(canvasBuffer)
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 0]
glBufferData GL_ARRAY_BUFFER $vertVecSize $vertVec GL_STATIC_DRAW
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 1]
glBufferData GL_ARRAY_BUFFER $uvVecSize $uvVec GL_STATIC_DRAW
}
proc LoadTexture { imgName } {
global g_Demo
set img [tcl3dReadImg [file join $g_Demo(scriptDir) $imgName] true]
glBindTexture GL_TEXTURE_2D [$g_Demo(skyTex) get 0]
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
glTexImage2D GL_TEXTURE_2D 0 [dict get $img format] \
[dict get $img width] [dict get $img height] 0 \
[dict get $img format] GL_UNSIGNED_BYTE [dict get $img data]
[dict get $img data] delete
}
proc SetupTexturesTrack {} {
global g_Demo
glGenTextures 2 $g_Demo(textures)
}
proc SetupTexturesView {} {
global g_Demo
glGenTextures 1 $g_Demo(skyTex)
LoadTexture "Sky.png"
}
proc CopyTexture {} {
global g_Demo
glActiveTexture GL_TEXTURE0
glBindTexture GL_TEXTURE_2D [$g_Demo(textures) get 0]
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
glPixelStorei GL_UNPACK_ALIGNMENT 1
glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA $g_Demo(winWidth) $g_Demo(winHeight) \
0 GL_RGBA GL_UNSIGNED_BYTE $g_Demo(imageVec)
glBindTexture GL_TEXTURE_2D [$g_Demo(textures) get 1]
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_REPEAT
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_NEAREST
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_NEAREST
}
proc CreateCallbackTrack { toglwin } {
global g_Demo
SetupShaders
SetupGeometry
SetupTexturesTrack
glClearColor 0.0 0.0 0.0 1.0
tcl3dResetSwatch $g_Demo(stopWatch)
tcl3dStartSwatch $g_Demo(stopWatch)
set g_Demo(lastTime) [tcl3dLookupSwatch $g_Demo(stopWatch)]
}
proc CreateCallbackView { toglwin } {
global g_Demo
set ambient { 0.0 0.0 0.0 1.0 }
set diffuse { 1.0 1.0 1.0 1.0 }
set position { 0.0 3.0 2.0 0.0 }
set lmodel_ambient { 0.2 0.2 0.2 1.0 }
set local_view { 0.0 }
glClearColor $g_Demo(sky,r) $g_Demo(sky,g) $g_Demo(sky,b) 1.0
glEnable GL_DEPTH_TEST
glEnable GL_TEXTURE_2D
glLightfv GL_LIGHT0 GL_AMBIENT $ambient
glLightfv GL_LIGHT0 GL_DIFFUSE $diffuse
glLightfv GL_LIGHT0 GL_POSITION $position
glLightModelfv GL_LIGHT_MODEL_AMBIENT $lmodel_ambient
glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER $local_view
glEnable GL_LIGHTING
glEnable GL_LIGHT0
SetupTexturesView
}
# Calculate distance between two texels in x- and y-direction.
proc AdaptTexIncrement { w h } {
global g_Demo
set xInc [expr {1.0 / $w}]
set yInc [expr {1.0 / $h}]
for { set i 0 } { $i < 2 } { incr i } {
for { set j 0 } { $j < 2 } { incr j } {
lset g_Demo(texCoordOffsets2x2) [expr {((($i*2)+$j)*2)+0}] [expr {$i * $xInc}]
lset g_Demo(texCoordOffsets2x2) [expr {((($i*2)+$j)*2)+1}] [expr {$j * $yInc}]
}
}
}
proc ReshapeCallbackTrack { toglwin { w -1 } { h -1 } } {
global g_Demo
set w [$toglwin width]
set h [$toglwin height]
glViewport 0 0 $w $h
tcl3dOrtho -1.0 1.0 -1.0 1.0 -5.0 5.0 $g_Demo(projection)
tcl3dMatfIdentity $g_Demo(modelview)
AdaptTexIncrement $w $h
}
proc ReshapeCallbackView { toglwin { w -1 } { h -1 } } {
global g_Demo
set w [$toglwin width]
set h [$toglwin height]
# The image data read from the window of the rendered sphere.
# Whenever there is a window size change, we also have to adapt
# the pixel buffer vector.
if { [info exists g_Demo(imageVec)] } {
$g_Demo(imageVec) delete
}
set g_Demo(imageVec) [tcl3dVector GLubyte [expr {$w * $h * 4}]]
set g_Demo(winWidth) $w
set g_Demo(winHeight) $h
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective 60.0 [expr double($w)/double($h)] 1.0 2000.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 5.0 0.0 0.0 0.0 0.0 1.0 0.0
}
proc DisplayCallbackTrack { toglwin } {
global g_Demo g_ProgramDict
set width $g_Demo(winWidth)
set height $g_Demo(winHeight)
CopyTexture
glViewport 0 0 $g_Demo(winWidth) $g_Demo(winHeight)
glClear GL_COLOR_BUFFER_BIT
glBindTexture GL_TEXTURE_2D [$g_Demo(textures) get 0]
glUseProgram [dict get $g_ProgramDict(1) program]
glUniform1i $g_Demo(loc_hue_texMap) 0
tcl3dMatfMult $g_Demo(projection) $g_Demo(modelview) $g_Demo(mvp)
set mvpAsList [tcl3dVectorToList $g_Demo(mvp) 16]
glUniformMatrix4fv $g_Demo(loc_hue_mvp) 1 GL_FALSE $mvpAsList
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 0]
glEnableVertexAttribArray $g_Demo(loc_hue_vertex)
glVertexAttribPointer $g_Demo(loc_hue_vertex) 3 GL_FLOAT GL_FALSE 0 "NULL"
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 1]
glEnableVertexAttribArray $g_Demo(loc_hue_texCoords)
glVertexAttribPointer $g_Demo(loc_hue_texCoords) 2 GL_FLOAT GL_FALSE 0 "NULL"
glDrawArrays GL_TRIANGLE_STRIP 0 4
# Calculate center of mass.
for { set pass 0 } { $pass < $g_Demo(numPasses) } { incr pass } {
glBindTexture GL_TEXTURE_2D [$g_Demo(textures) get 1]
set width [expr {int ($g_Demo(winWidth) / [Pow_wInt 2.0 $pass]) }]
set height [expr {int ($g_Demo(winHeight) / [Pow_wInt 2.0 $pass]) }]
# Copy original scene to texture
glCopyTexImage2D GL_TEXTURE_2D 0 GL_RGB 0 0 $width $height 0
AdaptTexIncrement $width $height
glViewport 0 0 [expr {$width/2}] [expr {$height/2}]
glClear GL_COLOR_BUFFER_BIT
glUseProgram [dict get $g_ProgramDict(2) program]
glUniform1i $g_Demo(loc_CoM_texMap) 0
glUniform2fv $g_Demo(loc_CoM_texCoordOffset) 4 $g_Demo(texCoordOffsets2x2)
glUniformMatrix4fv $g_Demo(loc_hue_mvp) 1 GL_FALSE $mvpAsList
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 0]
glEnableVertexAttribArray $g_Demo(loc_CoM_vertex)
glVertexAttribPointer $g_Demo(loc_CoM_vertex) 3 GL_FLOAT GL_FALSE 0 "NULL"
glBindBuffer GL_ARRAY_BUFFER [$g_Demo(canvasBuffer) get 1]
glEnableVertexAttribArray $g_Demo(loc_CoM_texCoords)
glVertexAttribPointer $g_Demo(loc_CoM_texCoords) 2 GL_FLOAT GL_FALSE 0 "NULL"
glDrawArrays GL_TRIANGLE_STRIP 0 4
}
if { $g_Demo(numPasses) > 0 } {
if { [info exists g_Demo(outputVec)] } {
$g_Demo(outputVec) delete
}
set g_Demo(outBufferSize) [expr {(($width/2) * ($height/2)) * 4}]
set g_Demo(outputVec) [tcl3dVector GLubyte $g_Demo(outBufferSize)]
glReadPixels 0 0 [expr {int($width/2)}] [expr {int($height/2)}] \
GL_RGBA GL_UNSIGNED_BYTE $g_Demo(outputVec)
}
$toglwin swapbuffer
ComputeCoordinates
if { [info exists g_Demo(animateId)] } {
ShowFPS
} else {
wm title . [format "%s (Stopped)" $g_Demo(appName)]
}
PrintStatus
}
proc DrawCross { posX posY r g b halfSize } {
glColor3f $r $g $b
set posX [expr {int($posX)}]
set posY [expr {int($posY)}]
glBegin GL_LINES
glVertex2i [expr {$posX - $halfSize}] $posY
glVertex2i [expr {$posX + $halfSize}] $posY
glEnd
glBegin GL_LINES
glVertex2i $posX [expr {$posY - $halfSize}]
glVertex2i $posX [expr {$posY + $halfSize}]
glEnd
}
proc DrawSky {} {
global g_Demo
set sc $g_Demo(skyScale)
glDisable GL_LIGHTING
glNormal3f 0 0 1
glColor3f 1 1 1
glBindTexture GL_TEXTURE_2D [$g_Demo(skyTex) get 0]
glBegin GL_QUADS
glTexCoord2f 0 0 ; glVertex3f -$sc -$sc 0.0
glTexCoord2f 0 1 ; glVertex3f -$sc $sc 0.0
glTexCoord2f 1 1 ; glVertex3f $sc $sc 0.0
glTexCoord2f 1 0 ; glVertex3f $sc -$sc 0.0
glEnd
glEnable GL_LIGHTING
}
proc MoveSphere { toglwin dx dy dz } {
global g_Demo
set g_Demo(offX) [expr {$g_Demo(offX) + $dx}]
set g_Demo(offY) [expr {$g_Demo(offY) + $dy}]
set g_Demo(offZ) [expr {$g_Demo(offZ) + $dz}]
$toglwin postredisplay
}
proc DrawSphere {} {
global g_Demo
set matDiffuse [list $g_Demo(ballon,r) $g_Demo(ballon,g) $g_Demo(ballon,b) 1.0]
glMaterialfv GL_FRONT GL_DIFFUSE $matDiffuse
glMaterialfv GL_FRONT GL_AMBIENT $g_Demo(matAmbient)
glMaterialfv GL_FRONT GL_SPECULAR $g_Demo(matSpecular)
glMaterialfv GL_FRONT GL_SHININESS $g_Demo(matShininess)
set quadObj [gluNewQuadric]
gluQuadricDrawStyle $quadObj GLU_FILL
gluQuadricNormals $quadObj GLU_SMOOTH
gluSphere $quadObj $g_Demo(sphereSize) $g_Demo(numSlices) $g_Demo(numStacks)
gluDeleteQuadric $quadObj
}
proc DisplayCallbackView { toglwin } {
global g_Demo
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
glUseProgram 0
# 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]
glLoadIdentity
glPushMatrix
glTranslatef $g_Demo(offX) $g_Demo(offY) [expr {-1.0 * $g_Demo(offZ)}]
DrawSphere
if { $g_Demo(skyMode) } {
glTranslatef 0.0 0.0 -$g_Demo(sphereSize)
DrawSky
}
glPopMatrix
glFlush
glReadPixels 0 0 $g_Demo(winWidth) $g_Demo(winHeight) \
GL_RGBA GL_UNSIGNED_BYTE $g_Demo(imageVec)
if { $g_Demo(numPasses) > 0 } {
# Draw the tracking cross in ortho mode.
glMatrixMode GL_PROJECTION
glPushMatrix
glLoadIdentity
glOrtho 0 $g_Demo(winWidth) 0 $g_Demo(winHeight) 0 1
glMatrixMode GL_MODELVIEW
glLoadIdentity
glDisable GL_LIGHTING
DrawCross $g_Demo(posX) $g_Demo(posY) 0.0 1.0 0.0 30
glEnable GL_LIGHTING
glMatrixMode GL_PROJECTION
glPopMatrix
glMatrixMode GL_MODELVIEW
}
$toglwin swapbuffers
}
proc Cleanup {} {
global g_Demo g_ProgramDict
if { [info exists g_Demo(canvasBuffer)] } {
glDeleteBuffers 2 [$g_Demo(canvasBuffer) get 0]
$g_Demo(canvasBuffer) delete
}
glDeleteTextures 2 [$g_Demo(textures) get 0]
glDeleteTextures 1 [$g_Demo(skyTex) get 0]
tcl3dOglDestroyProgram $g_ProgramDict(1)
tcl3dOglDestroyProgram $g_ProgramDict(2)
tcl3dDeleteSwatch $g_Demo(stopWatch)
foreach var [info globals g_*] {
uplevel #0 unset $var
}
}
# Put all exit related code here.
proc ExitProg {} {
exit
}
proc PostRedisplay { w args } {
global g_Demo
glClearColor $g_Demo(sky,r) $g_Demo(sky,g) $g_Demo(sky,b) 1.0
$w postredisplay
}
# Create the OpenGL windows and some Tk helper widgets.
proc CreateWindows {} {
global g_Demo
frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglTrack -width $g_Demo(winWidth) -height $g_Demo(winHeight) \
-double true -depth true \
-createcommand CreateCallbackTrack \
-reshapecommand ReshapeCallbackTrack \
-displaycommand DisplayCallbackTrack
togl .fr.toglView -width $g_Demo(winWidth) -height $g_Demo(winHeight) \
-double true -depth true \
-createcommand CreateCallbackView \
-reshapecommand ReshapeCallbackView \
-displaycommand DisplayCallbackView
listbox .fr.usage -font $g_Demo(listFont) -height 8
label .fr.status
label .fr.info
frame .fr.scalefr
grid .fr.toglTrack -row 0 -column 0 -sticky news
grid .fr.toglView -row 0 -column 1 -sticky news
grid .fr.status -row 1 -column 0 -sticky news
grid .fr.usage -row 2 -column 0 -sticky news
grid .fr.scalefr -row 1 -column 1 -sticky news -rowspan 2
grid .fr.info -row 3 -column 0 -sticky news -columnspan 2
# Currently we do not allow any resizing of the togl windows, as the tracking algorithm
# does not take that into account.
# grid rowconfigure .fr 1 -weight 1
# grid columnconfigure .fr 0 -weight 1
# grid columnconfigure .fr 1 -weight 1
labelframe .fr.scalefr.sky -text "Sky colors"
labelframe .fr.scalefr.ballon -text "Ballon colors"
eval pack [winfo children .fr.scalefr] -side left -anchor w
scale .fr.scalefr.ballon.r -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(ballon,r) \
-command { PostRedisplay .fr.toglView }
scale .fr.scalefr.ballon.g -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(ballon,g) \
-command { PostRedisplay .fr.toglView }
scale .fr.scalefr.ballon.b -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(ballon,b) \
-command { PostRedisplay .fr.toglView }
eval pack [winfo children .fr.scalefr.ballon] -side top -anchor w
scale .fr.scalefr.sky.r -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(sky,r) \
-command { PostRedisplay .fr.toglView }
scale .fr.scalefr.sky.g -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(sky,g) \
-command { PostRedisplay .fr.toglView }
scale .fr.scalefr.sky.b -from 0.0 -to 1.0 -length 200 -resolution 0.05 \
-orient horiz -showvalue true -variable g_Demo(sky,b) \
-command { PostRedisplay .fr.toglView }
eval pack [winfo children .fr.scalefr.sky] -side top -anchor w
wm title . $g_Demo(appName)
# Watch for Esc key and Quit messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
bind . <Key-0> "ChangeNumPasses 0"
bind . <Key-1> "ChangeNumPasses 1"
bind . <Key-2> "ChangeNumPasses 2"
bind . <Key-3> "ChangeNumPasses 3"
bind . <Key-4> "ChangeNumPasses 4"
bind . <Key-5> "ChangeNumPasses 5"
bind . <Key-6> "ChangeNumPasses 6"
bind . <Key-7> "ChangeNumPasses 7"
bind . <Key-8> "ChangeNumPasses 8"
bind . <Key-9> "ChangeNumPasses 9"
bind . <Key-p> "PrintStatus true"
bind . <Key-t> "ToggleLoopMode"
bind . <Key-s> "ToggleSkyMode"
bind . <Key-Left> "MoveSphere .fr.toglView -0.1 0.0 0.0"
bind . <Key-Right> "MoveSphere .fr.toglView 0.1 0.0 0.0"
bind . <Key-Up> "MoveSphere .fr.toglView 0.0 0.1 0.0"
bind . <Key-Down> "MoveSphere .fr.toglView 0.0 -0.1 0.0"
bind . <Key-plus> "MoveSphere .fr.toglView 0.0 0.0 -0.1"
bind . <Key-minus> "MoveSphere .fr.toglView 0.0 0.0 0.1"
bind .fr.toglTrack <1> "StartAnimation"
bind .fr.toglTrack <2> "StopAnimation"
bind .fr.toglTrack <3> "StopAnimation"
bind .fr.toglTrack <Control-Button-1> "StopAnimation"
bind .fr.toglView <1> "StartAnimation"
bind .fr.toglView <2> "StopAnimation"
bind .fr.toglView <3> "StopAnimation"
bind .fr.toglView <Control-Button-1> "StopAnimation"
.fr.usage insert end "Key-Escape Exit"
.fr.usage insert end "Key-0..9 Set number of passes"
.fr.usage insert end "Key-p Print status information onto stdout"
.fr.usage insert end "Key-t Toogle loop mode"
.fr.usage insert end "Key-s Toogle sky display"
.fr.usage insert end "Key-Arrows Move ballon left/right/up/down"
.fr.usage insert end "Key-+- Move ballon towards/backwards"
.fr.usage insert end "Mouse-L|MR Start|Stop animation"
}
CreateWindows
PrintInfo [tcl3dOglGetInfoString]
if { [file tail [info script]] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then start animation.
update
StartAnimation
}
|
