# 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
