#-----------------------------------------------------------------------------
#           Name: ogl_benchmark_sphere.cpp
#         Author: Kevin Harris (kevin@codesampler.com)
#  Last Modified: 04/21/05
#    Description: Renders a textured sphere using either Immediate Mode calls,
#                 Immediate Mode calls cached in a Display List, or as a 
#                 collection of geometric data stored in an interleaved 
#                 fashion within a Vertex Array.
#
#   Control Keys: Left Mouse Button - Spin the view.
#                 F1 - Decrease sphere precision.
#                 F2 - Increase sphere precision.
#                 F3 - Use Immediate mode
#                 F4 - Use a Display List
#                 F5 - Use a Vertex Array
#                 F6 - Perform Benchmarking
#                 F7 - Toggle wire-frame mode.
#-----------------------------------------------------------------------------
#
# Original C++ code by Kevin Harris (kevin@codesampler.com)
# See www.codesampler.com for the original files
# OpenGL samples page 9: Benchmarking Test App
#
# Modified for Tcl3D by Paul Obermeier 2005/11/07
# See www.tcl3d.org for the Tcl3D extension.

package require Tk
package require Img
package require tcl3d

tcl3dConsoleCreate .tcl3dOutputConsole "# " "Console of ogl_benchmark_sphere"

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

set g_WinWidth  640
set g_WinHeight 480

set IMMEDIATE_MODE_C   0
set IMMEDIATE_MODE_TCL 1
set DISPLAY_LIST       2
set VERTEX_ARRAY       3

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

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

set g_bRenderInWireFrame 0
set g_nCurrentMode $DISPLAY_LIST
set g_nPrecision  50

set g_StopWatch [tcl3dNewSwatch]

# A custom data structure for our interleaved vertex attributes
# The interleaved layout will be GL_T2F_N3F_V3F
set TU 0
set TV 1
set NX 2
set NY 3
set NZ 4
set X  5
set Y  6
set Z  7
set SIZE 8

# 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 SetMouseInput { x y } {
    set ::g_LastMousePosX(1) $x
    set ::g_LastMousePosY(1) $y
}

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

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

proc PrintRenderMode { mode } {
    if { $mode == $::DISPLAY_LIST } {
        puts -nonewline "Render Method: Display List"
    } elseif { $mode == $::IMMEDIATE_MODE_C } {
        puts -nonewline "Render Method: Immediate Mode calling C"
    } elseif { $mode == $::IMMEDIATE_MODE_TCL } {
        puts -nonewline "Render Method: Immediate Mode calling Tcl"
    } elseif { $mode == $::VERTEX_ARRAY } {
        puts -nonewline "Render Method: Vertex Array"
    }
    puts " (Sphere Resolution: $::g_nPrecision)"
}

proc CreateGeometry { toglwin } {
    if { $::g_nCurrentMode == $::DISPLAY_LIST } {
        CreateSphereDisplayList
    }
    if { $::g_nCurrentMode == $::VERTEX_ARRAY || \
         $::g_nCurrentMode == $::IMMEDIATE_MODE_C || \
         $::g_nCurrentMode == $::IMMEDIATE_MODE_TCL } {
        CreateSphereGeometry 0.0 0.0 0.0 1.5 $::g_nPrecision
    }
    PrintRenderMode $::g_nCurrentMode
    $toglwin postredisplay
}

proc DecreaseSpherePrecision {} {
    SetPrecision .fr.toglwin -5
}

proc IncreaseSpherePrecision {} {
    SetPrecision .fr.toglwin 5
}

proc SetPrecision { toglwin off } {
    if { ($::g_nPrecision > 5     && $off < 0) || \
         ($::g_nPrecision < 30000 && $off > 0) } {
        set ::g_nPrecision [expr $::g_nPrecision + $off]
    }
    CreateGeometry $toglwin
}

proc UseImmediateModeWithC {} {
    SetMode .fr.toglwin $::IMMEDIATE_MODE_C
}

proc UseImmediateModeWithTcl {} {
    SetMode .fr.toglwin $::IMMEDIATE_MODE_TCL
}

proc UseDisplayListMode {} {
    SetMode .fr.toglwin $::DISPLAY_LIST
}

proc UseVertexArrayMode {} {
    SetMode .fr.toglwin $::VERTEX_ARRAY
}

proc SetMode { toglwin mode } {
    set ::g_nCurrentMode $mode
    CreateGeometry $toglwin
}

proc ToggleWireframe {} {
    set ::g_bRenderInWireFrame [expr 1 - $::g_bRenderInWireFrame]
    .fr.toglwin postredisplay
}

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)/double($h)] 0.1 100.0
}

proc CreateCallback { toglwin } {
    glEnable GL_TEXTURE_2D
    glEnable GL_DEPTH_TEST
    glClearColor 0.0 0.0 0.0 1.0

    glMatrixMode GL_PROJECTION
    glLoadIdentity
    gluPerspective 45.0 [expr double($::g_WinWidth)/double($::g_WinHeight)] 0.1 100.0

    # Load texture image.
    set texName [file join $::g_scriptDir "mars.bmp"]
    set retVal [catch {set phImg [image create photo -file $texName]} err1]
    if { $retVal != 0 } {
        error "Error reading image $texName ($err1)"
    } else {
        set w [image width  $phImg]
        set h [image height $phImg]
        set n [tcl3dPhotoChans $phImg]
        set pTextureImage [tcl3dVectorFromPhoto $phImg]
        image delete $phImg
    }

    set ::g_textureID [tcl3dVector GLuint 1]
    glGenTextures 1 $::g_textureID

    glBindTexture GL_TEXTURE_2D [$::g_textureID get 0]

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

    if { $n == 3 } {
        set type $::GL_RGB
    } else {
       set type $::GL_RGBA
    }
    glTexImage2D GL_TEXTURE_2D 0 $n $w $h 0 $type GL_UNSIGNED_BYTE $pTextureImage

    $pTextureImage delete

    # Create the first sphere...
    CreateGeometry $toglwin
}

# Create a sphere centered at cy, cx, cz with radius r, and 
# precision p. Based on a function Written by Paul Bourke. 
# http://astronomy.swin.edu.au/~pbourke/opengl/sphere/

proc renderSphere { cx cy cz r p } {
    set PI     3.14159265358979
    set TWOPI  6.28318530717958
    set PIDIV2 1.57079632679489

    set theta1 0.0
    set theta2 0.0
    set theta3 0.0

    set ex 0.0
    set ey 0.0
    set ez 0.0

    set px 0.0
    set py 0.0
    set pz 0.0

    # Disallow a negative number for radius.
    if { $r < 0 } {
        set r [expr -1.0 * $r]
    }

    # Disallow a negative number for precision.
    if { $p < 4 } {
        set p 4
    }

    # If the sphere is too small, just render a OpenGL point instead.
    if { $p < 4 || $r <= 0 } {
        glBegin GL_POINTS
        glVertex3f $cx $cy $cz
        glEnd
        return
    }

    set p2 [expr $p / 2]
    for {set i 0 } { $i < $p2 } { incr i } {
        set theta1 [expr {$i * $TWOPI / $p - $PIDIV2}]
        set theta2 [expr {($i + 1) * $TWOPI / $p - $PIDIV2}]

        glBegin GL_TRIANGLE_STRIP
        for {set j 0 } { $j <= $p } { incr j } {
            set theta3 [expr {$j * $TWOPI / $p}]

            set ex [expr {cos($theta2) * cos($theta3)}]
            set ey [expr {sin($theta2)}]
            set ez [expr {cos($theta2) * sin($theta3)}]
            set px [expr {$cx + $r * $ex}]
            set py [expr {$cy + $r * $ey}]
            set pz [expr {$cz + $r * $ez}]

            glNormal3f $ex $ey $ez
            glTexCoord2f [expr {-1.0 * ($j/double($p))}] \
                         [expr { 2.0 * ($i+1)/double($p)}]
            glVertex3f $px $py $pz

            set ex [expr {cos($theta1) * cos($theta3)}]
            set ey [expr {sin($theta1)}]
            set ez [expr {cos($theta1) * sin($theta3)}]
            set px [expr {$cx + $r * $ex}]
            set py [expr {$cy + $r * $ey}]
            set pz [expr {$cz + $r * $ez}]

            glNormal3f $ex $ey $ez
            glTexCoord2f [expr {-1.0 * ($j/double($p))}] \
                         [expr { 2.0 * ($i/double($p))}]
            glVertex3f $px $py $pz
        }
        glEnd
    }
}

proc CreateSphereDisplayList {} {
    if { [info exists ::g_sphereDList] } {
        glDeleteLists $::g_sphereDList 0
    }

    if { ! [info exists ::g_firstPass] } {
        set ::g_sphereDList [glGenLists 1]
        set ::g_firstPass 0
    }

    if { $::g_sphereDList != 0 } {
        glNewList $::g_sphereDList GL_COMPILE
        # Cache the calls needed to render a sphere
        renderSphere 0.0 0.0 0.0 1.5 $::g_nPrecision
        glEndList
    }
}

# Creates a sphere as an array of vertex data suitable to be fed into a 
# OpenGL vertex array. The sphere will be centered at cy, cx, cz with 
# radius r, and precision p. Based on a function Written by Paul Bourke. 
# http://astronomy.swin.edu.au/~pbourke/opengl/sphere/

proc CreateSphereGeometry { cx cy cz r p } {
    set PI     3.14159265358979
    set TWOPI  6.28318530717958
    set PIDIV2 1.57079632679489

    set theta1 0.0
    set theta2 0.0
    set theta3 0.0

    set ex 0.0
    set ey 0.0
    set ez 0.0

    set px 0.0
    set py 0.0
    set pz 0.0

    set tu 0.0
    set tv 0.0

    #-------------------------------------------------------------------------
    # If sphere precision is set to 4, then 20 verts will be needed to 
    # hold the array of GL_TRIANGLE_STRIP(s) and so on...
    #
    # Example:
    #
    # total_verts = (p/2) * ((p+1)*2)
    # total_verts = (4/2) * (  5  *2)
    # total_verts =   2   *  10
    # total_verts =      20
    #-------------------------------------------------------------------------

    set ::g_nNumSphereVertices [expr ($p/2) * (($p+1)*2)]

    if { [info exists ::g_pSphereVertices] } {
        $::g_pSphereVertices delete
        unset ::g_pSphereVertices
    }
    set ::g_pSphereVertices [tcl3dVector GLfloat [expr $::SIZE * $::g_nNumSphereVertices]]

    # Disallow a negative number for radius.
    if { $r < 0 } {
        set r [expr -1.0 * $r]
    }

    # Disallow a negative number for precision.
    if { $p < 4 } {
        set p 4
    }

    set p2 [expr $p / 2]
    set k -1
    for {set i 0 } { $i < $p2 } { incr i } {
        set theta1 [expr {$i * $TWOPI / $p - $PIDIV2}]
        set theta2 [expr {($i + 1) * $TWOPI / $p - $PIDIV2}]

        for {set j 0 } { $j <= $p } { incr j } {
            set theta3 [expr {$j * $TWOPI / $p}]

            set ex [expr {cos($theta2) * cos($theta3)}]
            set ey [expr {sin($theta2)}]
            set ez [expr {cos($theta2) * sin($theta3)}]
            set px [expr {$cx + $r * $ex}]
            set py [expr {$cy + $r * $ey}]
            set pz [expr {$cz + $r * $ez}]
            set tu [expr {-1.0 * ($j/double($p))}]
            set tv [expr { 2.0 * ($i+1)/double($p)}]

            incr k
            set ind [expr {$k * $::SIZE}]
            # These lists are used for the Tcl immediate mode version.
            set ::gVtxList($k) [list $px $py $pz]
            set ::gNorList($k) [list $ex $ey $ez]
            set ::gTexList($k) [list $tu $tv]
            # This array is used for all other versions.
            $::g_pSphereVertices set [expr {$ind + $::X}]  $px 
            $::g_pSphereVertices set [expr {$ind + $::Y}]  $py 
            $::g_pSphereVertices set [expr {$ind + $::Z}]  $pz 
            $::g_pSphereVertices set [expr {$ind + $::NX}] $ex 
            $::g_pSphereVertices set [expr {$ind + $::NY}] $ey 
            $::g_pSphereVertices set [expr {$ind + $::NZ}] $ez 
            $::g_pSphereVertices set [expr {$ind + $::TU}] $tu
            $::g_pSphereVertices set [expr {$ind + $::TV}] $tv 

            set ex [expr {cos($theta1) * cos($theta3)}]
            set ey [expr {sin($theta1)}]
            set ez [expr {cos($theta1) * sin($theta3)}]
            set px [expr {$cx + $r * $ex}]
            set py [expr {$cy + $r * $ey}]
            set pz [expr {$cz + $r * $ez}]
            set tu [expr {-1.0 * ($j/double($p))}]
            set tv [expr { 2.0 * ($i/double($p))}]

            incr k
            set ind [expr {$k * $::SIZE}]
            # These lists are used for the Tcl immediate mode version.
            set ::gVtxList($k) [list $px $py $pz]
            set ::gNorList($k) [list $ex $ey $ez]
            set ::gTexList($k) [list $tu $tv]
            # This array is used for all other versions.
            $::g_pSphereVertices set [expr {$ind + $::X}]  $px 
            $::g_pSphereVertices set [expr {$ind + $::Y}]  $py 
            $::g_pSphereVertices set [expr {$ind + $::Z}]  $pz 
            $::g_pSphereVertices set [expr {$ind + $::NX}] $ex 
            $::g_pSphereVertices set [expr {$ind + $::NY}] $ey 
            $::g_pSphereVertices set [expr {$ind + $::NZ}] $ez 
            $::g_pSphereVertices set [expr {$ind + $::TU}] $tu 
            $::g_pSphereVertices set [expr {$ind + $::TV}] $tv 
        }
    }
}

proc StopBenchmark {} {
    set ::gStopBenchmark true
}

proc StartBenchmark {} {
    DoBenchmark .fr.toglwin
}

proc DoBenchmark { toglwin } {
    puts  "Benchmark Initiated - Standby..." 

    set fElapsed 0.0
    set nFrames  1000
    set nCount   $nFrames

    set saveSpinX $::g_fSpinX(1)
    set saveSpinY $::g_fSpinY(1)

    tcl3dResetSwatch $::g_StopWatch
    tcl3dStartSwatch $::g_StopWatch
    set start [tcl3dLookupSwatch $::g_StopWatch]

    set ::gStopBenchmark false
    while { $nCount && $::gStopBenchmark == false } {
        render $toglwin
        set ::g_fSpinX(1) [expr $::g_fSpinX(1) + 0.25]
        set ::g_fSpinY(1) [expr $::g_fSpinY(1) + 0.5]
        incr nCount -1
        update
    }

    set finish [tcl3dLookupSwatch $::g_StopWatch]

    set ::g_fSpinX(1) $saveSpinX
    set ::g_fSpinY(1) $saveSpinY
    render $toglwin

    set fElapsed  [expr $finish - $start]

    puts "-- Benchmark Report --"
    PrintRenderMode $::g_nCurrentMode

    set nFramesRendered [expr $nFrames - $nCount]

    puts "Frames Rendered:   $nFramesRendered"
    puts "Sphere Resolution: $::g_nPrecision"
    puts "Primitive Used:    GL_TRIANGLE_STRIP"
    puts "Elapsed Time:      [format "%.2f" $fElapsed] seconds"
    puts "Frames Per Second: [format "%.1f" [expr $nFramesRendered/$fElapsed]]"
    puts ""
}

proc render { toglwin } {
    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]

    # 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]

    glMatrixMode GL_MODELVIEW
    glLoadIdentity
    glTranslatef 0.0 0.0 -5.0
    glRotatef [expr -1.0*$::g_fSpinY(1)] 1.0 0.0 0.0
    glRotatef [expr -1.0*$::g_fSpinX(1)] 0.0 1.0 0.0

    if { $::g_bRenderInWireFrame } {
        glPolygonMode GL_FRONT_AND_BACK GL_LINE
    } else {
        glPolygonMode GL_FRONT_AND_BACK GL_FILL
    }

    # Render test sphere...

    glBindTexture GL_TEXTURE_2D [$::g_textureID get 0]

    # To be fair to immediate mode, we won't force it incur the overhead 
    # of calling hundreds of math subroutines to generate a sphere each 
    # frame, instead, we'll use the same array that we would use for 
    # testing the vertex array, but we'll make the immediate mode calls 
    # ourselves. This is more typical of how a real app would use 
    # immediate mode calls.

    if { $::g_nCurrentMode == $::IMMEDIATE_MODE_C } {
        # Render a textured sphere using immediate mode calling C
        tcl3dSphere 0.0 0.0 0.0 1.5 $::g_nPrecision

    } elseif { $::g_nCurrentMode == $::IMMEDIATE_MODE_TCL } {
        # Render a textured sphere using immediate mode calling Tcl
        glBegin GL_TRIANGLE_STRIP
        for {set i 0 } { $i < $::g_nNumSphereVertices } { incr i } {
            glNormal3fv   $::gNorList($i)
            glTexCoord2fv $::gTexList($i)
            glVertex3fv   $::gVtxList($i)
        }
        glEnd

    } elseif { $::g_nCurrentMode == $::DISPLAY_LIST } {
        # Render a textured sphere as a display list
        glCallList $::g_sphereDList

    } elseif { $::g_nCurrentMode == $::VERTEX_ARRAY } {
        # Render a textured sphere using a vertex array
        glInterleavedArrays GL_T2F_N3F_V3F 0 $::g_pSphereVertices
        glDrawArrays GL_TRIANGLE_STRIP 0 $::g_nNumSphereVertices
    }

     $toglwin swapbuffers
}

proc Cleanup {} {
    if { [info exists ::g_textureID] } {
        glDeleteTextures 1 [$::g_textureID get 0]
        $::g_textureID delete
    }
    if { [info exists ::g_sphereDList] } {
        glDeleteLists $::g_sphereDList 0
    }
    tcl3dDeleteSwatch $::g_StopWatch

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

proc ExitProg {} {
    exit
}

proc DisplayCallback { toglwin } {
    render $toglwin
}

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width $g_WinWidth -height $g_WinHeight \
                 -double true -depth true \
                 -createcommand CreateCallback \
                 -reshapecommand ReshapeCallback \
                 -displaycommand DisplayCallback 
listbox .fr.usage -font $::g_listFont -height 9
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: CodeSampler's Benchmarking Test App"

# Watch For ESC Key And Quit Messages
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
bind . <Key-s>      "StopBenchmark"
bind . <Key-F1>     "DecreaseSpherePrecision"
bind . <Key-F2>     "IncreaseSpherePrecision"
bind . <Key-F3>     "UseImmediateModeWithC"
bind . <Key-F8>     "UseImmediateModeWithTcl"
bind . <Key-F4>     "UseDisplayListMode"
bind . <Key-F5>     "UseVertexArrayMode"
bind . <Key-F6>     "StartBenchmark"
bind . <Key-F7>     "ToggleWireframe"

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

.fr.usage insert end "Key-Escape Exit"
.fr.usage insert end "Key-F1|F2  Decrease|Increase sphere precision."
.fr.usage insert end "Key-F3     Use Immediate mode calling C."
.fr.usage insert end "Key-F8     Use Immediate mode calling Tcl."
.fr.usage insert end "Key-F4     Use a Display List."
.fr.usage insert end "Key-F5     Use a Vertex Array."
.fr.usage insert end "Key-F6     Start benchmark."
.fr.usage insert end "Key-s      Stop running benchmark."
.fr.usage insert end "Key-F7     Toggle wireframe mode."
.fr.usage configure -state disabled

PrintInfo [tcl3dOglGetInfoString]
