# shadowmap.tcl
#
# An example of the OpenGL red book modified to work with Tcl3D.
# The original C sources are Copyright (c) 1993-2003, Silicon Graphics, Inc.
# The Tcl3D sources are Copyright (c) 2005-2026, Paul Obermeier.
# See file LICENSE for complete license information.

package require tcl3d

set SHADOW_MAP_WIDTH      256
set SHADOW_MAP_HEIGHT     256

set PI       3.14159265359

set fovy      60.0
set nearPlane 10.0
set farPlane  100.0

set angle 0.0
set torusAngle 0.0

set lightPos { 25.0 25.0 25.0 1.0 }
set lookat { 0.0 0.0 0.0 }
set up { 0.0 0.0 1.0 }

set depthImage [tcl3dVector GLfloat [expr $::SHADOW_MAP_WIDTH*$::SHADOW_MAP_HEIGHT]]

set showShadow  0
set textureOn   1
set compareMode 1
set funcMode    1
set animate     1

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

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

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

proc UpdateMsg { msgStr } {
    .fr.usage configure -state normal
    .fr.usage delete end
    .fr.usage insert end $msgStr
    .fr.usage configure -state disabled
}

proc CreateCallback { toglwin } {
    set white { 1.0 1.0 1.0 1.0 }

    if { [tcl3dOglHaveExtension $toglwin "GL_ARB_shadow"] } {
        set ::GL_TEXTURE_COMPARE_MODE  $::GL_TEXTURE_COMPARE_MODE_ARB
        set ::GL_TEXTURE_COMPARE_FUNC  $::GL_TEXTURE_COMPARE_FUNC_ARB
        set ::GL_DEPTH_TEXTURE_MODE    $::GL_DEPTH_TEXTURE_MODE_ARB
        set ::GL_COMPARE_R_TO_TEXTURE  $::GL_COMPARE_R_TO_TEXTURE_ARB
    } else {
        puts "Extension GL_ARB_shadow missing."
    }

    glTexImage2D GL_TEXTURE_2D 0 $::GL_DEPTH_COMPONENT \
                 $::SHADOW_MAP_WIDTH $::SHADOW_MAP_HEIGHT 0 \
                 GL_DEPTH_COMPONENT GL_UNSIGNED_BYTE NULL

    glLightfv GL_LIGHT0 GL_POSITION $::lightPos
    glLightfv GL_LIGHT0 GL_SPECULAR $white
    glLightfv GL_LIGHT0 GL_DIFFUSE $white

    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S $::GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T $::GL_CLAMP_TO_EDGE
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER $::GL_LINEAR
    glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER $::GL_LINEAR
    glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_FUNC $::GL_LEQUAL
    glTexParameteri GL_TEXTURE_2D $::GL_DEPTH_TEXTURE_MODE $::GL_LUMINANCE
    glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_MODE \
                    $::GL_COMPARE_R_TO_TEXTURE

    glTexGeni GL_S GL_TEXTURE_GEN_MODE $::GL_OBJECT_LINEAR
    glTexGeni GL_T GL_TEXTURE_GEN_MODE $::GL_OBJECT_LINEAR
    glTexGeni GL_R GL_TEXTURE_GEN_MODE $::GL_OBJECT_LINEAR
    glTexGeni GL_Q GL_TEXTURE_GEN_MODE $::GL_OBJECT_LINEAR

    glColorMaterial GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE

    glCullFace GL_BACK

    glEnable GL_DEPTH_TEST
    glEnable GL_LIGHT0
    glEnable GL_LIGHTING
    glEnable GL_TEXTURE_2D
    glEnable GL_TEXTURE_GEN_S
    glEnable GL_TEXTURE_GEN_T
    glEnable GL_TEXTURE_GEN_R
    glEnable GL_TEXTURE_GEN_Q
    glEnable GL_COLOR_MATERIAL
    glEnable GL_CULL_FACE
}

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 $::fovy [expr double($w)/double($h)] \
                   $::nearPlane $::farPlane
    glMatrixMode GL_MODELVIEW
}

proc StartAnimation {} {
    set ::angle [expr $::angle + $::PI / 10000]
    set ::torusAngle [expr $::torusAngle + 0.1]
    .fr.toglwin postredisplay
    set ::spinId [tcl3dAfterIdle StartAnimation]
}

proc StopAnimation {} {
    if { [info exists ::spinId] } {
        after cancel $::spinId 
    }
}

proc ToggleTexture { toglwin } {
    set ::textureOn [expr 1 - $::textureOn]
    if { $::textureOn } {
        UpdateMsg "Texture on"
        glEnable GL_TEXTURE_2D
    } else {
        UpdateMsg "Texture off"
        glDisable GL_TEXTURE_2D
    }
    $toglwin postredisplay
}

proc ToggleCompareMode { toglwin } {
    set ::compareMode [expr 1 - $::compareMode]
    if { $::compareMode } {
        UpdateMsg "Compare mode on"
        glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_MODE \
                        $::GL_COMPARE_R_TO_TEXTURE
    } else {
        UpdateMsg "Compare mode off"
        glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_MODE $::GL_NONE
    }
    $toglwin postredisplay
}

proc ToggleFuncMode { toglwin } {
    set ::funcMode [expr 1 - $::funcMode]
    if { $::funcMode } {
        UpdateMsg "Operator GL_LEQUAL"
        glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_FUNC $::GL_LEQUAL
    } else {
        UpdateMsg "Operator GL_GEQUAL"
        glTexParameteri GL_TEXTURE_2D $::GL_TEXTURE_COMPARE_FUNC $::GL_GEQUAL
    }
    $toglwin postredisplay
}

proc ToggleShowShadow { toglwin } {
    set ::showShadow [expr 1 - $::showShadow]
    $toglwin postredisplay
}

proc ToggleAnimation { toglwin } {
    set ::animate [expr 1 - $::animate]
    if { $::animate } {
        StartAnimation
    } else {
        StopAnimation
    }
}

proc drawObjects { shadowRender } {
    global lightPos

    set ::textureOn [glIsEnabled GL_TEXTURE_2D]

    if { $shadowRender } {
        glDisable GL_TEXTURE_2D
    }

    if { ! $shadowRender } {
        glNormal3f 0 0 1
        glColor3f 1 1 1
        glRectf -20.0 -20.0 20.0 20.0
    }

    glPushMatrix
    glTranslatef 11 11 11
    glRotatef 54.73 -5 5 0
    glRotatef $::torusAngle 1 0 0
    glColor3f 1 0 0
    glutSolidTorus 1 4 8 36
    glPopMatrix

    glPushMatrix
    glTranslatef 2 2 2
    glColor3f 0 0 1
    glutSolidCube 4
    glPopMatrix

    glPushMatrix
    glTranslatef [lindex $::lightPos 0] [lindex $::lightPos 1] [lindex $::lightPos 2]
    glColor3f 1 1 1
    glutWireSphere 0.5 6 6
    glPopMatrix

    if { $shadowRender && $::textureOn } {
        glEnable GL_TEXTURE_2D
    }
}

proc generateShadowMap { toglwin } {
    set litePos  [tcl3dVector GLfloat 4]
    glGetLightfv GL_LIGHT0 GL_POSITION $litePos

    set viewport [tcl3dOglGetViewport]
    glViewport 0 0 $::SHADOW_MAP_WIDTH $::SHADOW_MAP_HEIGHT

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

    glMatrixMode GL_PROJECTION
    glPushMatrix
    glLoadIdentity
    gluPerspective 80.0 1.0 10.0 1000.0
    glMatrixMode GL_MODELVIEW

    glPushMatrix
    glLoadIdentity
    gluLookAt [$litePos get 0] [$litePos get 1] [$litePos get 2] \
              [lindex $::lookat 0] [lindex $::lookat 1] [lindex $::lookat 2] \
              [lindex $::up 0] [lindex $::up 1] [lindex $::up 2]

    drawObjects 1

    glPopMatrix
    glMatrixMode GL_PROJECTION
    glPopMatrix
    glMatrixMode GL_MODELVIEW

    glCopyTexImage2D GL_TEXTURE_2D 0 GL_DEPTH_COMPONENT 0 0 \
                     $::SHADOW_MAP_WIDTH $::SHADOW_MAP_HEIGHT 0

    glViewport [lindex $viewport 0] [lindex $viewport 1] \
               [lindex $viewport 2] [lindex $viewport 3]

    if { $::showShadow } {
        glReadPixels 0 0 $::SHADOW_MAP_WIDTH $::SHADOW_MAP_HEIGHT \
                     GL_DEPTH_COMPONENT GL_FLOAT $::depthImage
        glWindowPos2f [expr 0.5 * [lindex $viewport 2]] 0
        glDrawPixels $::SHADOW_MAP_WIDTH $::SHADOW_MAP_HEIGHT GL_LUMINANCE \
                     GL_FLOAT $::depthImage
        $toglwin swapbuffers
    }
    $litePos  delete
}

proc generateTextureMatrix {} {
    set tmptcl3dVector { 0.0 0.0 0.0 0.0 }
    set tmpMatrix [tcl3dVector GLfloat 16]
    set transposeMat [tcl3dVector GLfloat 16]

    #
    #  Set up projective texture matrix.  We use the GL_MODELVIEW matrix
    #  stack and OpenGL matrix commands to make the matrix.
    #
    glPushMatrix
    glLoadIdentity
    glTranslatef 0.5 0.5 0.0
    glScalef 0.5 0.5 1.0
    gluPerspective 60.0 1.0 1.0 1000.0
    gluLookAt [lindex $::lightPos 0] [lindex $::lightPos 1] [lindex $::lightPos 2] \
               [lindex $::lookat 0] [lindex $::lookat 1] [lindex $::lookat 2] \
               [lindex $::up 0] [lindex $::up 1] [lindex $::up 2]
    glGetFloatv GL_MODELVIEW_MATRIX $tmpMatrix
    glPopMatrix

    tcl3dMatfTranspose $tmpMatrix $transposeMat

    set j 0
    for { set i 0 } { $i < 4 } { incr i } {
        lset tmptcl3dVector $j [$transposeMat get $i]
        incr j
    }
    glTexGenfv GL_S GL_OBJECT_PLANE $tmptcl3dVector

    set j 0
    for { set i 4 } { $i < 8 } { incr i } {
        lset tmptcl3dVector $j [$transposeMat get $i]
        incr j
    }
    glTexGenfv GL_T GL_OBJECT_PLANE $tmptcl3dVector

    set j 0
    for { set i 8 } { $i < 12 } { incr i } {
        lset tmptcl3dVector $j [$transposeMat get $i]
        incr j 
    }
    glTexGenfv GL_R GL_OBJECT_PLANE $tmptcl3dVector

    set j 0
    for { set i 12 } { $i < 16 } { incr i } {
        lset tmptcl3dVector $j [$transposeMat get $i]
        incr j
    }
    glTexGenfv GL_Q GL_OBJECT_PLANE $tmptcl3dVector

    $tmpMatrix delete
    $transposeMat delete
}

proc DisplayCallback { toglwin } {
    set radius 30.0

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

    generateShadowMap $toglwin
    generateTextureMatrix

    if { $::showShadow } {
        return
    }

    glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
    
    glPushMatrix
    gluLookAt [expr $radius*cos($::angle)] [expr $radius*sin($::angle)] 30 \
              [lindex $::lookat 0] [lindex $::lookat 1] [lindex $::lookat 2] \
              [lindex $::up 0] [lindex $::up 1] [lindex $::up 2]
    drawObjects 0
    glPopMatrix

    $toglwin swapbuffers
}

frame .fr
pack .fr -expand 1 -fill both
togl .fr.toglwin -width 512 -height 512 -double true -depth true \
                 -createcommand  CreateCallback  \
                 -reshapecommand ReshapeCallback \
                 -displaycommand DisplayCallback

listbox .fr.usage -font $::listFont -height 7
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: OpenGL Red Book example shadowmap"

bind . <Key-t> "ToggleTexture .fr.toglwin"
bind . <Key-m> "ToggleCompareMode .fr.toglwin"
bind . <Key-f> "ToggleFuncMode .fr.toglwin"
bind . <Key-s> "ToggleShowShadow .fr.toglwin"
bind . <Key-p> "ToggleAnimation .fr.toglwin"
bind . <Key-Escape> "exit"

.fr.usage insert end "Key-t      Toggle Texture"
.fr.usage insert end "Key-m      Toggle CompareMode"
.fr.usage insert end "Key-f      Toggle FuncMode"
.fr.usage insert end "Key-s      Toggle ShowShadow"
.fr.usage insert end "Key-p      Toggle Animation"
.fr.usage insert end "Key-Escape Exit"
.fr.usage insert end "Status display"
.fr.usage configure -state disabled

PrintInfo [tcl3dOglGetInfoString]

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