# Copyright (c) 2007, Libero Spagnolini
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# * Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# * Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# * Neither the name of the authors nor the names of its contributors
# may be used to endorse or promote products derived from this software
# without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# Modified for Tcl3D by Paul Obermeier 2007/04/14
# See www.tcl3d.org for the Tcl3D extension.
#
# The demo has been modified to allow up to 2 parameters to be changed
# interactively via a slider.
# The parameter range of the two sliders can be provided as comment lines
# at the top of the shader source files.
# Further enhancements include:
# Loading of image files of any size via the "Load image" button. All image files
# with an extension of .jpg or .tga in the directory of the script are automatically
# recognized and inserted into the "Images" labelframe.
# Add your own shader without modifying the Tcl script by adding a new file with extension
# .frag in the directory of the script.
#
# A description of the effect shaders and the original sources are
# available at http://dem.ocracy.org/libero/photobooth/
package require Tk
catch {package require Img}
package require tcl3d
# Texture stuff: Size and texture identifier.
set sizeTexX 512
set sizeTexY 512
set g_texId [tcl3dVector GLuint 1]
set g_HaveShaderLang(GLSL) 1
set ::g_isProgramLoaded false
set g_lastDir [pwd]
# Create a stop watch for time measurement.
set g_stopwatch [tcl3dNewSwatch]
set g_frameCount 0
# Determine the directory of this script.
set g_scriptDir [file dirname [info script]]
# 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 a the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
proc GetFPS { { elapsedFrames 1 } } {
set currentTime [tcl3dLookupSwatch $::g_stopwatch]
set fps [expr $elapsedFrames / ($currentTime - $::g_lastTime)]
set ::g_lastTime $currentTime
return $fps
}
proc DisplayFPS {} {
incr ::g_frameCount
if { $::g_frameCount == 50 } {
set msg [format "%s (%.0f fps)" $::appName [GetFPS $::g_frameCount]]
wm title . $msg
set ::g_frameCount 0
}
}
proc PostRedisplay { w args } {
$w postredisplay
}
proc ShowAnimation { w } {
if { $::animStarted == 0 } {
return
}
set ::g_current(Param,1) [expr {$::g_current(Param,1) + $::g_paramSett(inc,1)}]
if { $::g_current(Param,1) >= $::g_paramSett(max,1) } {
set ::g_current(Param,1) $::g_paramSett(min,1)
}
$w postredisplay
set ::animId [tcl3dAfterIdle ShowAnimation $w]
}
proc StartAnimation {} {
set ::g_lastTime [tcl3dLookupSwatch $::g_stopwatch]
set ::g_frameCount 0
ShowAnimation .fr.toglwin
}
proc StopAnimation {} {
if { [info exists ::animId] } {
after cancel $::animId
set ::animStarted 0
}
}
proc TimedAnimation { toglwin } {
tcl3dResetSwatch $::g_stopwatch
set startTime [tcl3dLookupSwatch $::g_stopwatch]
$toglwin postredisplay
update
set checkTime [tcl3dLookupSwatch $::g_stopwatch]
set fps [expr 1.0 / ($checkTime - $startTime)]
if { $fps < $::g_TimeTestMinFps } {
return $fps
}
for { set i 0 } { $i < $::g_TimeTestNumLoops } { incr i } {
set ::g_current(Param,1) [expr {$::g_current(Param,1) + $::g_paramSett(inc,1)}]
if { $::g_current(Param,1) >= $::g_paramSett(max,1) } {
set ::g_current(Param,1) $::g_paramSett(min,1)
}
$toglwin postredisplay
update
if { $::timeTestStarted == 0 } {
break
}
}
set endTime [tcl3dLookupSwatch $::g_stopwatch]
set fps [expr $::g_TimeTestNumLoops / ($endTime - $startTime)]
return $fps
}
proc PerformTimeTest { toglwin shaderLang } {
set ::g_ShaderLang $shaderLang
set effectList $::g_Effects($shaderLang)
set apprList [array names ::g_timeTest "$shaderLang,*"]
foreach effect $effectList {
foreach { key appr } [array get ::g_timeTest "$shaderLang,*"] {
if { $appr ne "" } {
if { $::timeTestStarted == 0 } {
return
}
set ::g_current(Effect) $effect
set ::g_current(Approximation) $appr
Update $toglwin true
LoadApprTextures
set effectStr [file rootname [file tail $effect]]
set apprStr [file rootname [file tail $appr]]
PrintTimeTestLog "set fps($shaderLang,$effectStr,$apprStr) "
set fps [TimedAnimation $toglwin]
PrintTimeTestLog [format "%.1f\n" $fps]
}
}
}
}
proc TimeTest { toglwin } {
set savedLang $::g_ShaderLang
set savedEffect $::g_current(Effect)
set savedAppr $::g_current(Approximation)
if { $::timeTestStarted } {
PrintTimeTestLog "set info(os) \"$::tcl_platform(os)\"\n"
PrintTimeTestLog "set info(gpu) \"[glGetString GL_RENDERER]\"\n"
PrintTimeTestLog "set info(gl) \"[glGetString GL_VERSION]\"\n"
PrintTimeTestLog "set info(minFps) $::g_TimeTestMinFps\n"
PrintTimeTestLog "set info(numLoops) $::g_TimeTestNumLoops\n"
}
DestroyToglWin $toglwin
CreateToglWin $toglwin
if { $::g_HaveShaderLang(GLSL) } {
PerformTimeTest $toglwin "GLSL"
}
DestroyToglWin $toglwin
CreateToglWin $toglwin
DestroyToglWin $toglwin
CreateToglWin $toglwin
set ::timeTestStarted 0
set ::g_ShaderLang $savedLang
set ::g_current(Effect) $savedEffect
set ::g_current(Approximation) $savedAppr
Update $toglwin true
}
proc OpenTimeTestWin { toglwin } {
set ::g_TimeTestNumLoops 100
set ::g_TimeTestMinFps 10
set textFont {-family {Courier} -size 10}
set tw ".tcl3d_PhotoBooth_TimeTest"
if { [winfo exists $tw] } {
tcl3dWinRaise $tw
return
}
toplevel $tw
wm title $tw "Timing tests"
frame $tw.fr -relief sunken -borderwidth 1
pack $tw.fr -side top -fill both -expand 1
set col 0
foreach shaderLang [list "GLSL"] {
if { ! $::g_HaveShaderLang($shaderLang) } {
continue
}
set curFrame $tw.fr.fr$shaderLang
labelframe $curFrame -text $shaderLang
grid $curFrame -row 0 -column $col -sticky news
foreach apprFile $::g_ApprFiles($shaderLang) {
set apprName [file rootname [file tail $apprFile]]
set ::g_timeTest($shaderLang,$apprName) $apprFile
checkbutton $curFrame.b$apprName \
-anchor w \
-indicatoron 1 \
-text $apprName \
-onvalue $apprFile \
-offvalue "" \
-variable ::g_timeTest($shaderLang,$apprName)
pack $curFrame.b$apprName -side top -fill x
}
incr col
}
frame $tw.fr.frOpts
frame $tw.fr.frExec
grid $tw.fr.frOpts -row 1 -column 0 -columnspan $col -sticky w
grid $tw.fr.frExec -row 2 -column 0 -columnspan $col -sticky news
set loopFrame $tw.fr.frOpts.frLoops
set fpsFrame $tw.fr.frOpts.frFps
frame $loopFrame
frame $fpsFrame
pack $loopFrame $fpsFrame -side top -expand 1 -fill both
label $loopFrame.lLoops -text "Number of test loops: " -font $textFont
entry $loopFrame.eLoops -textvariable ::g_TimeTestNumLoops -width 4
pack $loopFrame.lLoops $loopFrame.eLoops -side left
label $fpsFrame.lFps -text "Minimum fps for loops: " -font $textFont
entry $fpsFrame.eFps -textvariable ::g_TimeTestMinFps -width 4
pack $fpsFrame.lFps $fpsFrame.eFps -side left
set ::g_timeTestLogWidget \
[tcl3dCreateScrolledText $tw.fr.frExec "Test results" \
-font $textFont -wrap none -height 10 -width 50]
checkbutton $tw.fr.frExec.timeTest -text "Execute test" \
-indicatoron 0 \
-variable ::timeTestStarted \
-command { TimeTest .fr.toglwin }
set resultFile [format "OS_%s_GL_%s.tcl" \
$::tcl_platform(os) \
[glGetString GL_VERSION]]
button $tw.fr.frExec.save \
-text "Save results" \
-command "TextWidgetToFile $::g_timeTestLogWidget [list $resultFile]"
pack $tw.fr.frExec.timeTest $tw.fr.frExec.save -side left
grid rowconfigure $tw.fr 2 -weight 1
grid rowconfigure $tw.fr 3 -weight 1
for { set i 0 } { $i < $col } { incr i } {
grid columnconfigure $tw.fr $i -weight 1
}
}
proc PrintTimeTestLog { msg } {
$::g_timeTestLogWidget insert end $msg
$::g_timeTestLogWidget see end
}
proc PrintLog { msg } {
$::g_shaderInfoWidget insert end $msg
$::g_shaderInfoWidget see end
}
proc PrintGLSLLog { obj } {
set infoStr [tcl3dOglGetInfoLogARB $obj]
if { $infoStr ne "" } {
set msg [format "%s-%s:\n" \
[file tail [file rootname $::g_current(Effect)]] \
[file tail [file rootname $::g_current(Approximation)]]]
$::g_shaderInfoWidget insert end $msg
$::g_shaderInfoWidget insert end "$infoStr"
$::g_shaderInfoWidget insert end "\n"
$::g_shaderInfoWidget see end
}
}
proc LoadFileIntoTextWidget { w fileName } {
set retVal [catch {open $fileName r} fp]
if { $retVal != 0 } {
error "Could not open file $fileName for reading."
}
$w delete 1.0 end
while { ![eof $fp] } {
$w insert end [read $fp 2048]
}
close $fp
}
proc TextWidgetToFile { w fileName } {
set fileTypes {
{"All files" "*"}
{"GLSL files" ".frag"}
{"Log files" ".tcl"}
}
if { [info exists ::starkit::topdir] && \
[file isdirectory $::starkit::topdir] } {
set dumpDir [file dirname $::starkit::topdir]
} else {
set dumpDir [file dirname $fileName]
}
set dumpFile [file tail $fileName]
set saveName [tk_getSaveFile -filetypes $fileTypes \
-initialfile $dumpFile -initialdir $dumpDir \
-title "Save Tcl script to file system"]
if { $saveName != "" } {
set retVal [catch {open $saveName w} fp]
if { $retVal != 0 } {
error "Could not open file $saveName for writing."
}
puts -nonewline $fp [$w get 1.0 end]
close $fp
}
}
proc AddMenuCmd { menu label acc cmd } {
$menu add command -label $label -accelerator $acc -command $cmd
}
proc ShowEditor { fileName { textStr "" } } {
global gPres
# Font to be used in the text widget.
set textFont {-family {Courier} -size 10}
if { ! [info exists gPres(editCount)] } {
set gPres(editCount) 0
} else {
incr gPres(editCount)
}
set titleStr "$::g_ShaderLang shader: [file tail $fileName]"
set tw ".poTextEdit_$gPres(editCount)"
toplevel $tw
wm title $tw $titleStr
frame $tw.workfr -relief sunken -borderwidth 1
pack $tw.workfr -side top -fill both -expand 1
set hMenu $tw.menufr
menu $hMenu -borderwidth 2 -relief sunken
$hMenu add cascade -menu $hMenu.file -label File -underline 0
set textId [tcl3dCreateScrolledText $tw.workfr "$fileName" -font $textFont]
set fileMenu $hMenu.file
menu $fileMenu -tearoff 0
AddMenuCmd $fileMenu "Save as ..." "Ctrl+S" "TextWidgetToFile $textId [list $fileName]"
AddMenuCmd $fileMenu "Close" "Ctrl+W" "destroy $tw"
bind $tw <Control-s> "TextWidgetToFile $textId [list $fileName]"
bind $tw <Control-w> "destroy $tw"
bind $tw <Escape> "destroy $tw"
wm protocol $tw WM_DELETE_WINDOW "destroy $tw"
$tw configure -menu $hMenu
if { $textStr eq "" } {
LoadFileIntoTextWidget $textId $fileName
} else {
$textId delete 1.0 end
$textId insert end $textStr
}
$textId configure -state disabled -cursor top_left_arrow
focus $tw
}
proc ViewShaderFile {} {
StopAnimation
ShowEditor $::g_current(Effect)
}
proc ViewShaderSource {} {
StopAnimation
set titleStr [format "%s-%s.frag" \
[file rootname [file tail $::g_current(Effect)]] \
[file rootname [file tail $::g_current(Approximation)]]]
ShowEditor $titleStr $::g_current(ShaderSource)
}
proc AskOpen { lbox } {
global gPo
StopAnimation
set fileTypes {
{ "All files" * }
}
set imgName [tk_getOpenFile -filetypes $fileTypes \
-initialdir $::g_lastDir]
if { $imgName != "" } {
set ::g_lastDir [file dirname $imgName]
# Check, if a button with the short file name already exists.
# If yes, do not load the image.
set shortName [file rootname [file tail $imgName]]
if { ! [winfo exists .fr.btns.frImages.b$shortName] } {
ReadImg $imgName
set ::g_current(Texture) $imgName
$lbox selection clear 0 end
AddTexToList $lbox $imgName true
$lbox see end
} else {
PrintLog "Texture $shortName already loaded\n"
}
}
}
proc GetBestSquare { w h } {
if { $w > $h } {
set val $w
} else {
set val $h
}
set sqrList { 1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 }
foreach sqr $sqrList {
if { $val <= $sqr } {
return $sqr
}
}
}
proc ReadImg { filename } {
set retVal [catch {set phImg [image create photo -file $filename]} err1]
if { $retVal != 0 } {
error "Error reading image $filename ($err1)"
} else {
set w [image width $phImg]
set h [image height $phImg]
set n [tcl3dPhotoChans $phImg]
set sqr [GetBestSquare $w $h]
set ::g_texScaleS [expr double ($w) / $sqr]
set ::g_texScaleT [expr double ($h) / $sqr]
set sqrImg [image create photo -width $sqr -height $sqr]
$sqrImg copy $phImg -from 0 0 $w $h -to 0 [expr $sqr -$h]
set texData [tcl3dVectorFromPhoto $sqrImg]
image delete $phImg
image delete $sqrImg
}
glActiveTexture GL_TEXTURE0
glGenTextures 1 $::g_texId
glBindTexture GL_TEXTURE_2D [$::g_texId get 0]
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
if {$n == 4 } {
glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA \
$sqr $sqr 0 GL_RGBA GL_UNSIGNED_BYTE $texData
} else {
glTexImage2D GL_TEXTURE_2D 0 $::GL_RGB \
$sqr $sqr 0 GL_RGB GL_UNSIGNED_BYTE $texData
}
$texData delete
}
proc InitFileLists {} {
# Take care, if the script is running from within a Starpack.
set realPath [tcl3dGetExtFile $::g_scriptDir]
# Get a list of all available GLSL shader program files.
set ::g_Effects(GLSL) [lsort [glob -directory $realPath "*.frag"]]
# Get a list of all available GLSL approximation files.
set ::g_ApprFiles(GLSL) [lsort [glob -directory $realPath "*.appr"]]
# Get a list of all available texture images.
set jpgFiles [glob -directory $realPath "*.jpg"]
set tgaFiles [glob -directory $realPath "*.tga"]
set ::g_Textures [lsort [concat $jpgFiles $tgaFiles]]
# Variables for holding current settings.
set ::g_current(Texture) [lindex $::g_Textures 0]
set ::g_current(Effect) [lindex $::g_Effects($::g_ShaderLang) 0]
set ::g_current(Param,1) 0
set ::g_current(Param,2) 0
set ind [lsearch -glob $::g_ApprFiles($::g_ShaderLang) "*None.appr*"]
if { $ind < 0 } {
error "Dummy approximation file None.appr missing."
}
set ::g_current(Approximation) [lindex $::g_ApprFiles($::g_ShaderLang) $ind]
}
proc InitExtensions { toglwin } {
if { ![tcl3dOglHaveExtension $toglwin "GL_ARB_vertex_shader"] } {
set ::g_HaveShaderLang(GLSL) 0
}
if { ![tcl3dOglHaveExtension $toglwin "GL_ARB_fragment_shader"] } {
set ::g_HaveShaderLang(GLSL) 0
}
}
proc InitApprTextures {} {
# Create the texture vector to be used for sin/cos functions approximation.
set ::g_sincosTexWidth [tcl3dOglGetMaxTextureSize]
set ::g_sincosTexId [tcl3dVector GLuint 1]
set numChans 1
set ::g_sincosLookup [tcl3dVector GLfloat [expr $::g_sincosTexWidth*$numChans]]
PrintLog "sin/cos ... "
puts "Using maximum texture size ($::g_sincosTexWidth pixels) for sin/cos 1D texture"
for { set i 0 } { $i < $::g_sincosTexWidth } { incr i } {
set ang [expr {$i * 360.0/$::g_sincosTexWidth}]
set val [expr {0.5 + 0.5 * sin ([tcl3dDegToRad $ang])}]
set ind [expr {$numChans * $i}]
for { set c 0 } { $c < $numChans } { incr c } {
$::g_sincosLookup set [expr {$ind + $c}] $val
}
}
# Create the texture vector to be used for atan2 functions approximation.
set RAD_180 3.14159265359
set RAD_360 6.28318530718
set ::g_atanTexWidth 128
set ::g_atanTexId [tcl3dVector GLuint 1]
set ::g_atanLookup [tcl3dVector GLfloat [expr $::g_atanTexWidth*$::g_atanTexWidth]]
PrintLog "atan2 ... "
puts "Using $::g_atanTexWidth x $::g_atanTexWidth pixels for atan2 2D texture"
# x and y in the range from -1 to +1.
for { set i 0 } { $i < $::g_atanTexWidth } { incr i } {
set x [expr {$i * 2.0/($::g_atanTexWidth-1) - 1.0}]
for { set j 0 } { $j < $::g_atanTexWidth } { incr j } {
set y [expr {$j * 2.0/($::g_atanTexWidth-1) - 1.0}]
set val [expr {($RAD_180 + atan2 ($y, $x)) / $RAD_360}]
$::g_atanLookup set [expr {$i*$::g_atanTexWidth + $j}] $val
}
}
}
proc LoadApprTextures {} {
# Generate the texture to be used for sin/cos functions approximation.
glActiveTexture GL_TEXTURE1
glGenTextures 1 $::g_sincosTexId
glBindTexture GL_TEXTURE_1D [$::g_sincosTexId get 0]
glTexParameteri GL_TEXTURE_1D GL_TEXTURE_WRAP_S $::GL_REPEAT
glTexParameteri GL_TEXTURE_1D GL_TEXTURE_WRAP_T $::GL_REPEAT
glTexParameteri GL_TEXTURE_1D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
glTexParameteri GL_TEXTURE_1D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
glTexImage1D GL_TEXTURE_1D 0 $::GL_LUMINANCE16 $::g_sincosTexWidth 0 \
GL_LUMINANCE GL_FLOAT $::g_sincosLookup
# Generate the texture to be used for atan2 functions approximation.
glActiveTexture GL_TEXTURE2
glGenTextures 1 $::g_atanTexId
glBindTexture GL_TEXTURE_2D [$::g_atanTexId 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_MAG_FILTER $::GL_LINEAR
glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
glTexImage2D GL_TEXTURE_2D 0 $::GL_LUMINANCE16 \
$::g_atanTexWidth $::g_atanTexWidth 0 GL_LUMINANCE \
GL_FLOAT $::g_atanLookup
}
proc ReadShaderFile { fileName { apprFile "" } } {
set retVal [catch {open $fileName r} fp]
if { $retVal == 0 } {
# Extract the effects parameter values from the first 3 lines of the shader program.
# The first line is skipped, line 2 and 3 contain the parameter values for the 2 sliders.
gets $fp dummy
gets $fp param1
scan $param1 "// %f %f %f %f" ::g_paramSett(def,1) ::g_paramSett(min,1) \
::g_paramSett(max,1) ::g_paramSett(inc,1)
gets $fp param2
scan $param2 "// %f %f %f %f" ::g_paramSett(def,2) ::g_paramSett(min,2) \
::g_paramSett(max,2) ::g_paramSett(inc,2)
# Now read the complete file into a buffer.
# Look for the key string "// %OVERLOAD%" and replace it with the contents of the
# approximation file.
seek $fp 0 start
set buffer [read $fp]
close $fp
set retVal [catch {open $apprFile r} apprFp]
if { $retVal == 0 } {
set apprBuf [read $apprFp]
close $apprFp
regsub "// %OVERLOAD%" $buffer $apprBuf buffer
} else {
tk_messageBox -icon warning -title "Warning" -type ok \
-message "Could not open approximation file $apprFile. Using no approximation."
}
} else {
error "Cannot open shader file $fileName"
}
return $buffer
}
proc InitShaderGLSL {} {
CleanupShaderGLSL
set ::g_programDeformObject [glCreateProgramObjectARB]
set ::g_shaderDeformObject [glCreateShaderObjectARB GL_FRAGMENT_SHADER_ARB]
glAttachObjectARB $::g_programDeformObject $::g_shaderDeformObject
set shaderSource [ReadShaderFile "$::g_current(Effect)" "$::g_current(Approximation)"]
set ::g_current(ShaderSource) $shaderSource
tcl3dOglShaderSource $::g_shaderDeformObject $shaderSource
glCompileShaderARB $::g_shaderDeformObject
PrintGLSLLog $::g_shaderDeformObject
glLinkProgramARB $::g_programDeformObject
set success [tcl3dVector GLint 1]
glGetObjectParameterivARB $::g_programDeformObject GL_OBJECT_LINK_STATUS_ARB $success
if { [$success get 0] == 0 } {
tk_messageBox -icon error -type ok \
-title "glLinkProgramARB" \
-message "Shader could not be linked"
return false
}
$success delete
set ::sampler [glGetUniformLocationARB $::g_programDeformObject "sampler"]
set ::sincosSampler [glGetUniformLocationARB $::g_programDeformObject "sincosSampler"]
set ::atanSampler [glGetUniformLocationARB $::g_programDeformObject "atanSampler"]
set ::param1 [glGetUniformLocationARB $::g_programDeformObject "param1"]
set ::param2 [glGetUniformLocationARB $::g_programDeformObject "param2"]
set ::texScaleS [glGetUniformLocationARB $::g_programDeformObject "texScaleS"]
set ::texScaleT [glGetUniformLocationARB $::g_programDeformObject "texScaleT"]
PrintGLSLLog $::g_programDeformObject
return true
}
proc InitTexture {} {
ReadImg $::g_current(Texture)
glActiveTexture GL_TEXTURE0
glBindTexture GL_TEXTURE_2D [$::g_texId get 0]
}
# Set the actual shader program parameters when using GLSL.
proc SetShaderParamsGLSL {} {
glUniform1iARB $::sampler 0 ; # pass in texture
glUniform1iARB $::sincosSampler 1 ; # pass in sin/cos approximation texture
glUniform1iARB $::atanSampler 2 ; # pass in atan2 approximation texture
glUniform1fARB $::param1 $::g_current(Param,1) ; # pass in value of parameter1
glUniform1fARB $::param2 $::g_current(Param,2) ; # pass in value of parameter2
glUniform1fARB $::texScaleS $::g_texScaleS ; # pass in texture scaling parameter in S
glUniform1fARB $::texScaleT $::g_texScaleT ; # pass in texture scaling parameter in T
}
proc DisplayCallback { toglwin } {
if { $::g_isProgramLoaded } {
SetShaderParams$::g_ShaderLang
}
# puts "texScale: $::g_texScaleS $::g_texScaleT"
glClearColor 0.0 0.0 0.0 0.0
glClear GL_COLOR_BUFFER_BIT
glBegin GL_QUADS
glTexCoord2f 0.0 0.0
glVertex2f 0.0 0.0
glTexCoord2f $::g_texScaleS 0.0
glVertex2f $::sizeTexX 0.0
glTexCoord2f $::g_texScaleS $::g_texScaleT
glVertex2f $::sizeTexX $::sizeTexY
glTexCoord2f 0.0 $::g_texScaleT
glVertex2f 0.0 $::sizeTexY
glEnd
if { $::animStarted } {
DisplayFPS
}
$toglwin swapbuffer
}
proc AddTexToList { lbox textureFile isNewFile } {
set textureName [file rootname [file tail $textureFile]]
$lbox insert end $textureName
if { $textureFile eq $::g_current(Texture) } {
$lbox selection set end
}
if { $isNewFile } {
lappend ::g_Textures $textureFile
}
}
proc ShowEffectFiles { lbox } {
$lbox delete 0 end
foreach effectFile $::g_Effects($::g_ShaderLang) {
set effectName [file rootname [file tail $effectFile]]
$lbox insert end $effectName
if { $effectFile eq $::g_current(Effect) } {
$lbox selection set end
}
}
}
proc ShowApproximationFiles { lbox } {
$lbox delete 0 end
foreach apprFile $::g_ApprFiles($::g_ShaderLang) {
set apprName [file rootname [file tail $apprFile]]
$lbox insert end $apprName
if { $apprFile eq $::g_current(Approximation) } {
$lbox selection set end
}
}
}
proc ShowImageFiles { lbox } {
$lbox delete 0 end
foreach textureFile $::g_Textures {
AddTexToList $lbox $textureFile false
}
}
proc UpdateEffect { lbox toglwin } {
set ind [lindex [$lbox curselection] 0]
set ::g_current(Effect) [lindex $::g_Effects($::g_ShaderLang) $ind]
Update $toglwin false
}
proc UpdateAppr { lbox toglwin } {
set ind [lindex [$lbox curselection] 0]
set ::g_current(Approximation) [lindex $::g_ApprFiles($::g_ShaderLang) $ind]
Update $toglwin false
}
proc UpdateImage { lbox toglwin } {
set ind [lindex [$lbox curselection] 0]
set ::g_current(Texture) [lindex $::g_Textures $ind]
Update $toglwin true
}
proc UseShaderGLSL {} {
glUseProgramObjectARB $::g_programDeformObject
return true
}
proc Update { toglwin updateTex } {
if { $updateTex } {
InitTexture
}
# InitShaderGLSL calls ReadShaderFile, which updates the parameter values in g_paramSett.
set ::g_isProgramLoaded [InitShader$::g_ShaderLang]
if { ! $::g_isProgramLoaded } {
return
}
set ::g_isProgramLoaded [UseShader$::g_ShaderLang]
if { ! $::g_isProgramLoaded } {
return
}
foreach param { 1 2 } {
if { $::g_paramSett(inc,$param) == 0 } {
set ::g_current(Param,$param) 0
.fr.scale.fr$param.label configure -state disabled
.fr.scale.fr$param.param configure -state disabled
} else {
.fr.scale.fr$param.label configure -state normal
.fr.scale.fr$param.param configure -state normal
.fr.scale.fr$param.param configure -from $::g_paramSett(min,$param)
.fr.scale.fr$param.param configure -to $::g_paramSett(max,$param)
.fr.scale.fr$param.param configure -resolution $::g_paramSett(inc,$param)
set ::g_current(Param,$param) $::g_paramSett(def,$param)
}
}
$toglwin postredisplay
}
proc CreateCallback { toglwin } {
InitExtensions $toglwin
glEnable GL_TEXTURE_1D
glEnable GL_TEXTURE_2D
glPolygonMode GL_FRONT GL_FILL
tcl3dStartSwatch $::g_stopwatch
set ::g_startTime [tcl3dLookupSwatch $::g_stopwatch]
set ::g_lastTime $::g_startTime
set ::elapsedLastTime $::g_startTime
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set w [$toglwin width]
set h [$toglwin height]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
glOrtho 0.0 $::sizeTexX 0.0 $::sizeTexY 0.0 1.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
}
proc CleanupShaderGLSL {} {
if { [info exists ::g_shaderDeformObject] } {
glDeleteObjectARB $::g_shaderDeformObject
unset ::g_shaderDeformObject
}
if { [info exists ::g_programDeformObject] } {
glDeleteObjectARB $::g_programDeformObject
unset ::g_programDeformObject
}
}
proc Cleanup {} {
if { [info exists ::g_texId] } {
glDeleteTextures 1 [$::g_texId get 0]
$::g_texId delete
}
if { [info exists ::g_atanTexId] } {
glDeleteTextures 1 [$::g_atanTexId get 0]
$::g_atanTexId delete
}
if { [info exists ::g_sincosTexId] } {
glDeleteTextures 1 [$::g_sincosTexId get 0]
$::g_sincosTexId delete
}
if { [info exists ::g_sincosLookup] } {
$::g_sincosLookup delete
}
if { [info exists ::g_atanLookup] } {
$::g_atanLookup delete
}
CleanupShaderGLSL
tcl3dDeleteSwatch $::g_stopwatch
foreach var [info globals g_*] {
uplevel #0 unset $var
}
}
proc ExitProg {} {
exit
}
proc CreateToglWin { pathName } {
togl $pathName -width 512 -height 512 \
-double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
grid $pathName -row 0 -column 0 -sticky news
}
proc DestroyToglWin { pathName } {
destroy $pathName
}
frame .fr
pack .fr -expand 1 -fill both
CreateToglWin .fr.toglwin
frame .fr.btns
frame .fr.scale
frame .fr.shade
label .fr.info
grid .fr.btns -row 0 -column 1 -sticky news -rowspan 2
grid .fr.scale -row 1 -column 0 -sticky news
grid .fr.shade -row 2 -column 0 -sticky news -columnspan 2
grid .fr.info -row 3 -column 0 -sticky news -columnspan 2
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
set g_shaderInfoWidget [tcl3dCreateScrolledText .fr.shade "" -wrap none -height 4]
labelframe .fr.btns.frEffects -text "Effects"
labelframe .fr.btns.frAppr -text "Approximations"
labelframe .fr.btns.frImages -text "Images"
labelframe .fr.btns.frActions -text "Actions"
pack .fr.btns.frEffects .fr.btns.frAppr \
.fr.btns.frImages .fr.btns.frActions \
-side top -fill x -padx 3 -pady 4
set ::g_ShaderLang "GLSL"
# Get lists of available GLSL shader files as well as a list of available images.
# This must be done after the creation of the togl widget to know, if we have GLSL
# available. But it must be done before creating the listboxes, which need to know the number
# of files to be created with an optimal height.
InitFileLists
set effectListbox [tcl3dCreateScrolledListbox .fr.btns.frEffects "" -exportselection false \
-height [llength $::g_Effects($::g_ShaderLang)]]
set apprListbox [tcl3dCreateScrolledListbox .fr.btns.frAppr "" -exportselection false \
-height [llength $::g_ApprFiles($::g_ShaderLang)]]
set imagesListbox [tcl3dCreateScrolledListbox .fr.btns.frImages "" -exportselection false \
-height [llength $::g_Textures]]
bind $effectListbox <<ListboxSelect>> "UpdateEffect $effectListbox .fr.toglwin"
bind $apprListbox <<ListboxSelect>> "UpdateAppr $apprListbox .fr.toglwin"
bind $imagesListbox <<ListboxSelect>> "UpdateImage $imagesListbox .fr.toglwin"
ShowEffectFiles $effectListbox
ShowApproximationFiles $apprListbox
ShowImageFiles $imagesListbox
button .fr.btns.frActions.open -text "Load image ..." -command "AskOpen $imagesListbox"
pack .fr.btns.frActions.open -side top -expand 1 -fill x
button .fr.btns.frActions.viewFile -text "View shader file" -command ViewShaderFile
pack .fr.btns.frActions.viewFile -side top -expand 1 -fill x
button .fr.btns.frActions.viewSource -text "View shader source" -command ViewShaderSource
pack .fr.btns.frActions.viewSource -side top -expand 1 -fill x
checkbutton .fr.btns.frActions.anim -text "Animate" \
-indicatoron [tcl3dShowIndicator] \
-variable ::animStarted \
-command { StartAnimation }
pack .fr.btns.frActions.anim -side top -expand 1 -fill x
button .fr.btns.frActions.timeTest -text "Timing test ..." \
-command { OpenTimeTestWin .fr.toglwin }
pack .fr.btns.frActions.timeTest -side top -expand 1 -fill x
frame .fr.scale.fr1
frame .fr.scale.fr2
pack .fr.scale.fr1 .fr.scale.fr2 -side top -expand 1 -fill x
label .fr.scale.fr1.label -text "Parameter 1:"
label .fr.scale.fr2.label -text "Parameter 2:"
scale .fr.scale.fr1.param -orient horiz -showvalue true -variable g_current(Param,1) \
-command { PostRedisplay .fr.toglwin }
scale .fr.scale.fr2.param -orient horiz -showvalue true -variable g_current(Param,2) \
-command { PostRedisplay .fr.toglwin }
pack .fr.scale.fr1.label .fr.scale.fr2.label -side left
pack .fr.scale.fr1.param .fr.scale.fr2.param -side left -expand 1 -fill x
set appName "Tcl3D demo: Photo Booth Effects"
wm title . $appName
# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
Update .fr.toglwin true
Update .fr.toglwin true
PrintInfo [tcl3dOglGetInfoString]
PrintLog "Creating approximation textures: "
. configure -cursor watch
InitApprTextures
LoadApprTextures
PrintLog "Done\n"
. configure -cursor top_left_arrow
|
