Demo 52 of 68 in category RedBook
 |
# 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-2022, 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
}
|
