# Testbed for GLSL procedural noise functions.
#
# Shaders are loaded from two external files:
# SimplexNoiseGLSL.vert and SimplexNoiseGLSL.frag.
# The program itself draws a spinning sphere
# with a noise-generated fragment color.
#
# Author: Stefan Gustavson (stegu@itn.liu.se) 2004, 2005, 2010, 2011
#
# Modified and extended for Tcl3D by Paul Obermeier 2011/03/20
# See www.tcl3d.org for the Tcl3D extension.

package require Tk
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

# Will be set to true in LoadExtensions,
# if all needed OpenGL extensions are available.
set g_Demo(haveOglExtensions) false

# Create a stop watch for time measurement.
set g_Demo(stopWatch) [tcl3dNewSwatch]
set g_Demo(frameCount) 0

set g_Demo(appName) "Tcl3D demo: GLSL simplex noise"

# Variables for toggling time update and object animation.
set g_Demo(updateTime)    1
set g_Demo(animateObject) 1

# Toggle between full-screen quad and sphere.
set g_Demo(drawSphere) 1

# Select noise algorithm: 2D, 3D or 4D noise.
set g_Demo(noiseAlgo) 3

# 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 {} {
    global g_Demo

    if { [winfo exists .fr.status] } {
        set updateTime    "Off"
        set animateObject "Off"
        if { $g_Demo(updateTime) } {
            set updateTime "On"
        }
        if { $g_Demo(animateObject) } {
            set animateObject "On"
        }
        set msg [format "Time update: %s Object animation: %s Noise algorithm: %dD" \
                 $updateTime $animateObject $g_Demo(noiseAlgo)]
        .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 fps [expr {double($g_Demo(frameCount)) / $dt}]
        wm title . [format "%s (%.0f fps)" $g_Demo(appName) $fps]
        set g_Demo(lastTime) $currentTime
        set g_Demo(frameCount) 0
    }
    incr g_Demo(frameCount)
}

proc Animate {} {
    global g_Demo

    .fr.toglwin 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 ToggleUpdateTime {} {
    global g_Demo

    set g_Demo(updateTime) [expr ! $g_Demo(updateTime)]
    PrintStatus
    if { $g_Demo(updateTime) } {
        tcl3dStartSwatch $g_Demo(stopWatch)
    } else {
        tcl3dStopSwatch $g_Demo(stopWatch)
    }
}

proc ToggleAnimateObject {} {
    global g_Demo

    set g_Demo(animateObject) [expr ! $g_Demo(animateObject)]
    PrintStatus
}

proc ToggleObjects {} {
    global g_Demo

    set g_Demo(drawSphere) [expr ! $g_Demo(drawSphere)]
}

proc SetNoiseAlgo { algoNum } {
    global g_Demo

    set g_Demo(noiseAlgo) $algoNum
    PrintStatus
}

proc CheckExtProc { extProc } {
    if { ![tcl3dOglHaveFunc $extProc] } {
        puts "Extension procedure $extProc not available"
        return false
    }
    return true
}

proc CheckExtensions { toglwin } {
    global g_Demo

    set g_Demo(haveOglExtensions) true

    # These extension strings indicate that the OpenGL Shading Language
    #  and GLSL shader objects are supported.
    if { ![tcl3dOglHaveExtension $toglwin "GL_ARB_shading_language_100"] } {
        puts "Extension GL_ARB_shading_language_100 missing"
        set g_Demo(haveOglExtensions) false
    }

    if { ![tcl3dOglHaveExtension $toglwin "GL_ARB_shader_objects"] } {
        puts "Extension GL_ARB_shader_objects missing"
        set g_Demo(haveOglExtensions) false
    }

    if { ! [CheckExtProc "glActiveTexture"] || \
         ! [CheckExtProc "glCreateProgram"] || \
         ! [CheckExtProc "glCreateProgram"] || \
         ! [CheckExtProc "glDeleteProgram"] || \
         ! [CheckExtProc "glUseProgram"] || \
         ! [CheckExtProc "glCreateShader"] || \
         ! [CheckExtProc "glDeleteShader"] || \
         ! [CheckExtProc "glShaderSource"] || \
         ! [CheckExtProc "glCompileShader"] || \
         ! [CheckExtProc "glGetShaderiv"] || \
         ! [CheckExtProc "glGetShaderInfoLog"] || \
         ! [CheckExtProc "glAttachShader"] || \
         ! [CheckExtProc "glLinkProgram"] || \
         ! [CheckExtProc "glGetUniformLocation"] || \
         ! [CheckExtProc "glUniform1f"] || \
         ! [CheckExtProc "glUniform1i"] } {
        set g_Demo(haveOglExtensions) false
    }
}

proc CreateShader { 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 [tcl3dOglBuildProgram $vertexSource "" "" "" $fragmentSource]
    set program [dict get $g_ProgramDict program]
    return $program
}

proc SetupCamera { toglwin } {
    global g_Demo

    set w [$toglwin width]
    set h [$toglwin height]
 
    # Set viewport. This is the pixel rectangle we want to draw into.
    glViewport 0 0 $w $h

    # Select and setup the projection matrix.
    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr {double($w)/double($h)}] 1.0 100.0

    # Select and setup the modelview matrix.
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    if { $g_Demo(drawSphere) } {
        gluLookAt 0.0 -4.0 0.0  0.0 0.0 0.0  0.0 0.0 1.0
    } else {
        glTranslatef 0.0 0.0 -1.0
    }
}

proc InitSphereList { scale } {
    set listId [glGenLists 1]
  
    glNewList $listId GL_COMPILE
    tcl3dSphere 0.0 0.0 0.0 $scale 30
    glEndList
    return $listId
}

proc DrawScene { t listId } {
    glRotatef 30.0 1.0 0.0 0.0
    glEnable GL_LIGHTING
    glEnable GL_LIGHT0
    glPushMatrix
        glRotatef [expr {30.0*$t}] 0.0 0.0 1.0
        glTranslatef 5.0 0.0 0.0
        set lightpos0 { 0.0 0.0 0.0 1.0 }
        glLightfv GL_LIGHT0 GL_POSITION $lightpos0
    glPopMatrix
    glPushMatrix
        glRotatef [expr {45.0*$t}] 0.0 0.0 1.0
        glColor3f 1.0 1.0 1.0
        glCallList $listId
    glPopMatrix
    # Disable lighting again, to play nice
    glDisable GL_LIGHTING
    glDisable GL_LIGHT0
}

proc RenderScene { listId programObject updateTime animateObject } {
    global g_Demo

    set location_time -1

    if { $animateObject } {
        set g_Demo(t) [tcl3dLookupSwatch $g_Demo(stopWatch)]
    }
    # Use vertex and fragment shaders.
    glUseProgram $programObject

    # Select noise algorithm: 2D, 3D or 4D noise.
    set noiseAlgo [glGetUniformLocation $programObject "algorithm"]
    glUniform1i $noiseAlgo [expr int($g_Demo(noiseAlgo))] 

    # Update the uniform time variable.
    if { $updateTime } {
        set location_time [glGetUniformLocation $programObject "time"]
        if { $location_time != -1 } {
            glUniform1f $location_time [tcl3dLookupSwatch $g_Demo(stopWatch)] 
        }
    }
    # Render with the shaders active.
    if { $g_Demo(drawSphere) } {
        DrawScene $g_Demo(t) $listId
    } else {
        glBegin GL_QUADS
            glTexCoord2f 0.0 0.0 ; glVertex3f -1.0 -1.0 0.0
            glTexCoord2f 0.0 1.0 ; glVertex3f -1.0  1.0 0.0
            glTexCoord2f 1.0 1.0 ; glVertex3f  1.0  1.0 0.0
            glTexCoord2f 1.0 0.0 ; glVertex3f  1.0 -1.0 0.0
        glEnd
    }

    # Deactivate the shaders.
    glUseProgram 0
}

proc CreateCallback { toglwin } {
    global g_Demo

    CheckExtensions $toglwin

    # Create the shader object from two external GLSL source files
    set g_Demo(program) [CreateShader "SimplexNoiseGLSL.vert" "SimplexNoiseGLSL.frag"]

    glEnable GL_DEPTH_TEST

    glClearColor 0.0 0.1 0.3 1.0
    set g_Demo(sphereList) [InitSphereList 1.0]

    tcl3dResetSwatch $g_Demo(stopWatch)
    tcl3dStartSwatch $g_Demo(stopWatch)
    set g_Demo(lastTime) [tcl3dLookupSwatch $g_Demo(stopWatch)]
}

proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    global g_Demo

    SetupCamera $toglwin
}

proc DisplayCallback { toglwin } {
    global g_Demo

    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]

    SetupCamera $toglwin

    RenderScene $g_Demo(sphereList) $g_Demo(program) \
                $g_Demo(updateTime) $g_Demo(animateObject)

    if { [info exists g_Demo(animateId)] } {
        ShowFPS
    }

    $toglwin swapbuffer
}

proc Cleanup {} {
    global g_Demo g_ProgramDict

    if { [info exists g_Program] } {
        tcl3dOglDestroyProgram $g_Program
    }

    tcl3dDeleteSwatch $g_Demo(stopWatch)
    foreach var [info globals g_*] {
        uplevel #0 unset $var
    }
}

# Put all exit related code here.
proc ExitProg {} {
    exit
}

# Create the OpenGL window and some Tk helper widgets.
proc CreateWindow {} {
    global g_Demo

    frame .fr
    pack .fr -expand 1 -fill both

    togl .fr.toglwin -width $g_Demo(winWidth) -height $g_Demo(winHeight) \
                     -double true -depth true \
                     -createcommand  CreateCallback \
                     -reshapecommand ReshapeCallback \
                     -displaycommand DisplayCallback

    listbox .fr.usage -font $g_Demo(listFont) -height 7
    label .fr.status
    label .fr.info
    grid .fr.toglwin -row 0 -column 0 -sticky news
    grid .fr.usage   -row 1 -column 0 -sticky news
    grid .fr.status  -row 2 -column 0 -sticky news
    grid .fr.info    -row 3 -column 0 -sticky news
    grid rowconfigure .fr 0 -weight 1
    grid columnconfigure .fr 0 -weight 1
    wm title . $g_Demo(appName)

    # Watch for Esc key and Quit messages
    wm protocol . WM_DELETE_WINDOW "ExitProg"
    bind . <Key-Escape> "ExitProg"
    bind . <Key-o> "ToggleObjects"
    bind . <Key-t> "ToggleUpdateTime"
    bind . <Key-a> "ToggleAnimateObject"
    bind . <Key-1> "SetNoiseAlgo 1"
    bind . <Key-2> "SetNoiseAlgo 2"
    bind . <Key-3> "SetNoiseAlgo 3"
    bind . <Key-4> "SetNoiseAlgo 4"

    bind .fr.toglwin <1> "StartAnimation"
    bind .fr.toglwin <2> "StopAnimation"
    bind .fr.toglwin <3> "StopAnimation"
    bind .fr.toglwin <Control-Button-1> "StopAnimation" 

    .fr.usage insert end "Key-Escape Exit"
    .fr.usage insert end "Key-o      Toggle objects"
    .fr.usage insert end "Key-t      Toggle time update"
    .fr.usage insert end "Key-a      Toggle object animation"
    .fr.usage insert end "Key-1      Switch off noise"
    .fr.usage insert end "Key-2|3|4  Select 2D|3D|4D noise"
    .fr.usage insert end "Mouse-L|MR Start|Stop animation"
}

CreateWindow
PrintStatus
PrintInfo [tcl3dOglGetInfoString]

if { [file tail [info script]] eq [file tail $::argv0] } {
    # If started directly from tclsh or wish, then start animation.
    update
    StartAnimation
}
