# ogl_bench v1.0 - Copyright 2007 - Graphcomp
# Bob Free bfree@graphcomp.com
# http://graphcomp.com/opengl

# This program is freely distributable without licensing fees 
# and is provided without guarantee or warrantee expressed or 
# implied. This program is -not- in the public domain.
#
# Modified for Tcl3D by Paul Obermeier 2008/10/01
# See www.tcl3d.org for the Tcl3D extension.

package require Tk
package require tcl3d

# Console window for benchmark output.
tcl3dConsoleCreate .tcl3dOutputConsole "# " "Benchmark Results"

# Font to be used in the Tk listbox.
set g_listFont {-family {Courier} -size 10}

# Set up constants
set PROGRAM "Bob Free's OpenGL Benchmark - Tcl Binding"
set CYCLES 1000

# Set up globals
set g_Frames 0
set g_StopBenchmark false

set g_WinWidth  512
set g_WinHeight 512

set g_TexWidth  128
set g_TexHeight 128

set g_LastMousePosX(1) 0
set g_LastMousePosY(1) 0
set g_LastMousePosX(2) 0
set g_LastMousePosY(2) 0

set g_fSpinX(1) 0.0
set g_fSpinY(1) 0.0
set g_fSpinX(2) 0.0
set g_fSpinY(2) 0.0

set g_IncrY 0.5

set idTexture      [tcl3dVector GLuint 1]
set idFrameBuffer  [tcl3dVector GLuint 1]
set idRenderBuffer [tcl3dVector GLuint 1]

set idVertexProg [tcl3dVector GLuint 1]
set idFragProg   [tcl3dVector GLuint 1]

set g_StopWatch [tcl3dNewSwatch]

# Determine the directory of this script.
set g_scriptDir [file dirname [info script]]

proc CheckGLErrors { msg } {
    set errMsg [tcl3dOglGetError]
    if { $errMsg eq "" } {
        return
    }
    puts "$msg: $errMsg"
}

# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
    tk_messageBox -icon error -type ok -message "Error: $msg"
    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 SetMouseInput { btn x y } {
    set ::g_LastMousePosX($btn) $x
    set ::g_LastMousePosY($btn) $y
}

proc GetMouseInput { btn x y } {
    set nXDiff [expr ($x - $::g_LastMousePosX($btn))]
    set nYDiff [expr ($y - $::g_LastMousePosY($btn))]
        
    set ::g_fSpinX($btn) [expr $::g_fSpinX($btn) - $nXDiff]
    set ::g_fSpinY($btn) [expr $::g_fSpinY($btn) - $nYDiff]

    set ::g_LastMousePosX($btn) $x
    set ::g_LastMousePosY($btn) $y
    .fr.toglwin postredisplay
}

proc Reset {} {
    set ::g_StopBenchmark false
    set ::g_Frames 0
    set ::g_fSpinX(2) 0.0
    set ::g_fSpinY(2) 0.0
    set ::g_fSpinX(1) 0.0
    set ::g_fSpinY(1) 0.0
    set ::g_Benches(appBench,secs)     0.0
    set ::g_Benches(frameBench,secs)   0.0
    set ::g_Benches(textureBench,secs) 0.0
    set ::g_Benches(teapotBench,secs)  0.0
    tcl3dResetSwatch $::g_StopWatch
    tcl3dStartSwatch $::g_StopWatch
}

# Start benchmark
proc StartBench { bench } {
    global g_Benches g_StopWatch

    set g_Benches($bench,start) [tcl3dLookupSwatch $g_StopWatch]
}

# Accumulate benchmark
proc EndBench { bench } {
    global g_Benches g_StopWatch

    set now [tcl3dLookupSwatch $g_StopWatch]
    set g_Benches($bench,secs) [expr { $g_Benches($bench,secs) +
                                     ($now - $g_Benches($bench,start)) }]
}

# Print benchmark
proc PrintBench {} {
    global g_Frames g_Benches

    if { ! $g_Frames || \
         ! [info exists g_Benches(appBench,secs)] || \
         ! [info exists g_Benches(frameBench,secs)] || \
         ! [info exists g_Benches(textureBench,secs)] || \
         ! [info exists g_Benches(teapotBench,secs)] } {
        puts "No measurable time has elapsed."
        return
    }

    puts "Number of frames rendered: $g_Frames"
    puts "Image size: $::g_WinWidth x $::g_WinHeight"

    puts [format "FBO Texture Rendering FPS: %.1f" \
          [expr $g_Frames / $g_Benches(textureBench,secs)]]
    puts [format "Teapot Shader FPS: %.1f" \
          [expr $g_Frames / $g_Benches(teapotBench,secs)]]
  
    set overhead [expr $g_Benches(frameBench,secs) - \
                  ($g_Benches(textureBench,secs) + $g_Benches(teapotBench,secs))]
    puts [format "Frame overhead secs/frame: %f" [expr $overhead / $g_Frames]]
  
    set overhead [expr $g_Benches(appBench,secs) - $g_Benches(frameBench,secs)]
    puts [format "OS/GLUT overhead secs/frame: %f" [expr $overhead / $g_Frames]]
  
    puts [format "Overall FPS: %.1f" [expr $g_Frames / $g_Benches(appBench,secs)]]
    puts ""
}

# Check OpenGL Version
proc CheckVersion { toglwin } {
    set version  [glGetString GL_VERSION]
    set vendor   [glGetString GL_VENDOR]
    set renderer [glGetString GL_RENDERER]

    puts "$::PROGRAM\n"
    puts "OpenGL  : $version"
    puts "Vendor  : $vendor"
    puts "Renderer: $renderer"
    puts ""

    if { ![tcl3dOglHaveExtension $toglwin "GL_EXT_framebuffer_object"] } {
        error "Extension GL_EXT_framebuffer_object missing"
    }
}

proc CheckExtProc { extProc } {
    if { ! [tcl3dOglHaveFunc $extProc] } {
        error "Extension proc $extProc not available"
    }
}

# Check availability of extensions
proc InitExtensions {} {
    CheckExtProc "glIsRenderbufferEXT"
    CheckExtProc "glBindRenderbufferEXT"
    CheckExtProc "glDeleteRenderbuffersEXT"
    CheckExtProc "glGenRenderbuffersEXT"
    CheckExtProc "glRenderbufferStorageEXT"
    CheckExtProc "glGetRenderbufferParameterivEXT"
    CheckExtProc "glIsFramebufferEXT"
    CheckExtProc "glBindFramebufferEXT"
    CheckExtProc "glDeleteFramebuffersEXT"
    CheckExtProc "glGenFramebuffersEXT"
    CheckExtProc "glCheckFramebufferStatusEXT"
    CheckExtProc "glFramebufferTexture1DEXT"
    CheckExtProc "glFramebufferTexture2DEXT"
    CheckExtProc "glFramebufferTexture3DEXT"
    CheckExtProc "glFramebufferRenderbufferEXT"
    CheckExtProc "glGetFramebufferAttachmentParameterivEXT"
    CheckExtProc "glGenerateMipmapEXT"
    CheckExtProc "glGenProgramsARB"
    CheckExtProc "glBindProgramARB"
    CheckExtProc "glProgramStringARB"
    CheckExtProc "glDeleteProgramsARB"
}

# Initialize Vertex/Fragment Programs
proc InitProgs {} {
    # NOP Vertex shader
    set vertexProgStr {!!ARBvp1.0 \
        TEMP vertexClip; \
        DP4 vertexClip.x, state.matrix.mvp.row[0], vertex.position; \
        DP4 vertexClip.y, state.matrix.mvp.row[1], vertex.position; \
        DP4 vertexClip.z, state.matrix.mvp.row[2], vertex.position; \
        DP4 vertexClip.w, state.matrix.mvp.row[3], vertex.position; \
        MOV result.position, vertexClip; \
        MOV result.color, vertex.color; \
        MOV result.texcoord[0], vertex.texcoord; \
        MOV result.texcoord[1], vertex.normal; \
        END \
    }
    # Black Light Fragment shader
    set fragProgStr {!!ARBfp1.0 \
        TEMP decal,color; \
        TEX decal, fragment.texcoord[0], texture[0], 2D; \
        MUL result.color, decal, fragment.texcoord[1]; \
        END \
    }

    # Convert the program strings into a tcl3dVector, as the glProgramStringARB function
    # expects the string as a "const void *" pointer.
    set vertexProg [tcl3dVectorFromByteArray GLubyte $vertexProgStr]
    set fragProg   [tcl3dVectorFromByteArray GLubyte $fragProgStr]

    glGenProgramsARB 1 $::idVertexProg
    glGenProgramsARB 1 $::idFragProg
  
    glBindProgramARB GL_VERTEX_PROGRAM_ARB [$::idVertexProg get 0]
    glProgramStringARB GL_VERTEX_PROGRAM_ARB GL_PROGRAM_FORMAT_ASCII_ARB \
                       [string length $vertexProgStr] $vertexProg

    glBindProgramARB GL_FRAGMENT_PROGRAM_ARB [$::idFragProg get 0]
    glProgramStringARB GL_FRAGMENT_PROGRAM_ARB GL_PROGRAM_FORMAT_ASCII_ARB \
                       [string length $fragProgStr] $fragProg
    $vertexProg delete
    $fragProg   delete
}

# Terminate Vertex/Fragment Programs
proc TermProgs {} {
    glBindProgramARB GL_VERTEX_PROGRAM_ARB 0
    glBindProgramARB GL_FRAGMENT_PROGRAM_ARB 0

    glDeleteProgramsARB 1 [list [$::idVertexProg get 0]]
    glDeleteProgramsARB 1 [list [$::idFragProg get 0]]
    $::idVertexProg delete
    $::idFragProg   delete
}

# FBO Status handler
proc StatusFBO {} {
    set stat [glCheckFramebufferStatus GL_FRAMEBUFFER_EXT]
    if { ! $stat || $stat == $::GL_FRAMEBUFFER_COMPLETE_EXT } {
        return
    }
    error [format "FBO status: %04X" $stat]
}

# Initialize Framebuffers
proc InitFBO {} {
    glGenTextures 1 $::idTexture
    glGenFramebuffers  1 $::idFrameBuffer
    glGenRenderbuffers 1 $::idRenderBuffer

    glBindFramebuffer GL_FRAMEBUFFER_EXT [$::idFrameBuffer get 0]
    glBindTexture GL_TEXTURE_2D [$::idTexture get 0]

    glTexImage2D GL_TEXTURE_2D 0 $::GL_RGBA8 $::g_TexWidth $::g_TexHeight \
                 0 $::GL_RGBA GL_UNSIGNED_BYTE NULL

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR

    glFramebufferTexture2D GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT \
                              GL_TEXTURE_2D [$::idTexture get 0] 0

    glBindRenderbuffer GL_RENDERBUFFER_EXT [$::idRenderBuffer get 0]

    glRenderbufferStorage GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT24 \
                             $::g_TexWidth $::g_TexHeight

    glFramebufferRenderbuffer GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT \
                                 GL_RENDERBUFFER_EXT [$::idRenderBuffer get 0]

    StatusFBO
}

# FBO texture renderer
proc RenderFBO { doBench } {
    glBindFramebuffer GL_FRAMEBUFFER_EXT [$::idFrameBuffer get 0]

    glViewport 0 0 512 512
    glLoadIdentity
    glTranslated -0.75 -0.85 -2.5

    glRotated [expr {-1.0 * $::g_fSpinY(2) }] 1.0 0.0 0.0
    if { $doBench } {
        set ::g_fSpinX(2) [expr { $::g_fSpinX(2) + 0.5 }]
    }

    glRotated [expr {-1.0 * $::g_fSpinX(2) }] 0.0 1.0 0.0
    if { $doBench } {
        set ::g_fSpinY(2) [expr { $::g_fSpinY(2) + 1.0 }]
    }

    glClearColor 0 0 0 0
    glClear [expr { $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT }]
    glColor3d 1.0 1.0 1.0

    glutWireTeapot 0.125

    glBindFramebuffer GL_FRAMEBUFFER_EXT 0
}

# Terminate FBO objects
proc TermFBO {} {
    glBindRenderbuffer GL_RENDERBUFFER_EXT 0
    glBindFramebuffer GL_FRAMEBUFFER_EXT 0
    glBindTexture GL_TEXTURE_2D 0

    glDeleteRenderbuffers 1 [$::idRenderBuffer get 0]
    glDeleteFramebuffers  1 [$::idFrameBuffer get 0]
    glDeleteTextures 1 [$::idTexture get 0]
    $::idRenderBuffer delete
    $::idFrameBuffer  delete
    $::idTexture      delete
}

# Resize Window
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
    set w [$toglwin width]
    set h [$toglwin height]

    glViewport 0 0 $w $h

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr {double($w)/$h}] 0.1 100.0

    glMatrixMode GL_MODELVIEW

    set ::g_WinWidth  $w
    set ::g_WinHeight $h
}

# Initialize OpenGL Environment
proc CreateCallback { toglwin } {
    CheckVersion $toglwin
    InitExtensions

    ReshapeCallback $toglwin

    InitFBO
    InitProgs
}

# Frame handler
proc DoBenchmark { toglwin } {
    global g_Frames g_StopBenchmark

    Reset

    StartBench appBench
    # Run benchmark CYCLES times
    while { $g_Frames < $::CYCLES && $g_StopBenchmark == false } {
        StartBench frameBench

        # Render animated texture
        StartBench textureBench
        RenderFBO true
        EndBench textureBench
      
        # Set up ModelView
        glViewport 0 0 $::g_WinWidth $::g_WinHeight
        glMatrixMode GL_MODELVIEW
        glLoadIdentity
        glTranslatef 0.0 0.0 -5.0
        glRotated $::g_fSpinY(1) 0.0 1.0 0.0
        set ::g_fSpinY(1) [expr {$::g_fSpinY(1) + $::g_IncrY}]
      
        # Set attributes
        glEnable GL_TEXTURE_2D
        glEnable GL_DEPTH_TEST
        glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL

        # Clear render buffer and set teapot color
        glClearColor 0.2 0.2 0.2 1.0
        glClear [expr {$::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT}]
        glColor3d 0.9 0.45 0.0
      
        # Render the teapot using our shader
        StartBench teapotBench
        glEnable GL_VERTEX_PROGRAM_ARB
        glEnable GL_FRAGMENT_PROGRAM_ARB
     
        # Take care, which GLUT implementation you are using.
        # Freeglut uses 7 as the grid parameter to the teapot routine.
        # Mark Kilgards original GLUT implementation uses 14 for the same parameter.
        glutSolidTeapot 1.0 7

        glDisable GL_FRAGMENT_PROGRAM_ARB
        glDisable GL_VERTEX_PROGRAM_ARB
        EndBench teapotBench

        # Double-buffer and done
        $toglwin swapbuffers
        EndBench frameBench

        update
        incr g_Frames
    }
    EndBench appBench
    PrintBench
}

proc Render { toglwin } {
    # Render animated texture
    RenderFBO false
      
    # Set up ModelView
    glViewport 0 0 $::g_WinWidth $::g_WinHeight
    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 -5.0
    glRotated [expr {-1.0 * $::g_fSpinY(1) }] 1.0 0.0 0.0
    glRotated [expr {-1.0 * $::g_fSpinX(1) }] 0.0 1.0 0.0
      
    # Set attributes
    glEnable GL_TEXTURE_2D
    glEnable GL_DEPTH_TEST
    glTexEnvi GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE $::GL_DECAL

    # Clear render buffer and set teapot color
    glClearColor 0.2 0.2 0.2 1.0
    glClear [expr {$::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT}]
    glColor3d 0.9 0.45 0.0
  
    # Render the teapot using our shader
    glEnable GL_VERTEX_PROGRAM_ARB
    glEnable GL_FRAGMENT_PROGRAM_ARB
     
    # Take care, which GLUT implementation you are using.
    # Freeglut uses 7 as the grid parameter to the teapot routine.
    # Mark Kilgards original GLUT implementation uses 14 for the same parameter.
    glutSolidTeapot 1.0 7

    glDisable GL_FRAGMENT_PROGRAM_ARB
    glDisable GL_VERTEX_PROGRAM_ARB

    # Double-buffer and done
    $toglwin swapbuffers
}

proc DisplayCallback { toglwin } {
    Render $toglwin
}

proc StartBenchmark {} {
    DoBenchmark .fr.toglwin
}

proc StopBenchmark {} {
    set ::g_StopBenchmark true
}

proc Cleanup {} {
    # Release Framebuffers
    TermProgs
    TermFBO

    tcl3dDeleteSwatch $::g_StopWatch

    foreach var [info globals g_*] {
        uplevel #0 unset $var
    }
}

proc ExitProg {} {
    exit
}

Reset

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width $g_WinWidth -height $g_WinHeight \
                 -double true -depth true -alpha true \
                 -createcommand CreateCallback \
                 -reshapecommand ReshapeCallback \
                 -displaycommand DisplayCallback
listbox .fr.usage -font $::g_listFont -height 5
label   .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.usage   -row 1 -column 0 -sticky news
grid .fr.info    -row 2 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
wm title . "Tcl3D demo: $PROGRAM"

# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
bind . <Key-F6>     "StartBenchmark"
bind . <Key-space>  "StopBenchmark"

bind .fr.toglwin <1>         "SetMouseInput 1 %x %y"
bind .fr.toglwin <B1-Motion> "GetMouseInput 1 %x %y"
bind .fr.toglwin <2>         "SetMouseInput 2 %x %y"
bind .fr.toglwin <B2-Motion> "GetMouseInput 2 %x %y"

.fr.usage insert end "Key-Escape Exit"
.fr.usage insert end "Key-F6     Start benchmark"
.fr.usage insert end "Key-Space  Stop running benchmark"
.fr.usage insert end "Mouse-1    Rotate teapot"
.fr.usage insert end "Mouse-2    Rotate textured teapots"
.fr.usage configure -state disabled

PrintInfo [tcl3dOglGetInfoString]
