# projectionModes.tcl
#
# A Tcl3D widget demo with two windows, one rendered as a single image with
# projection set by gluPerspective, the other one rendered row by row with
# the projection set by numRows * glFrustum calls.
#
# Copyright (C) 2013-2024 Paul Obermeier
# See www.tcl3d.org for the Tcl3D extension.
package require tcl3d
set gDemo(winWidth) 300
set gDemo(winHeight) 150
set gDemo(near) 1.0
set gDemo(far) 10.0
set gDemo(fovX) 60.0
set gDemo(fovY) [expr {$gDemo(fovX) * $gDemo(winHeight) / $gDemo(winWidth)}]
set gDemo(numRows) 10
set gDemo(useTcl3dProcs) 0
set gDemo(printProjMat) 0
set gDemo(saveImgs) 0
set gDemo(xAngle) 0.0
set gDemo(yAngle) 0.0
set gDemo(zAngle) 0.0
# Determine the directory of this script
set gDemo(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"
ExitProg
}
# 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 tcl3dMatListPrint { mat { msg "" } { precisionString "%6.3f" } } {
if { $msg ne "" } {
puts "$msg"
}
for { set i 0 } { $i < 4 } { incr i } {
for { set j 0 } { $j < 4 } { incr j } {
puts -nonewline [format "$precisionString " [lindex $mat [expr 4*$j + $i]]]
}
puts ""
}
}
proc SetMousePos { x y } {
global gDemo
set gDemo(cx) $x
set gDemo(cy) $y
}
proc SetRotX { wid val } {
global gDemo
set gDemo(xAngle) [expr {$gDemo(xAngle) + $val}]
$wid postredisplay
}
proc SetRotY { wid val } {
global gDemo
set gDemo(yAngle) [expr {$gDemo(yAngle) + $val}]
$wid postredisplay
}
proc HandleRot { wid x y } {
global gDemo
SetRotY $wid [expr {180 * (double($x - $gDemo(cx)) / [winfo width $wid])}]
SetRotX $wid [expr {180 * (double($y - $gDemo(cy)) / [winfo height $wid])}]
set gDemo(cx) $x
set gDemo(cy) $y
}
proc MotionEvent { wid x y } {
global gDemo
HandleRot $gDemo(togl,Native) $x $y
HandleRot $gDemo(togl,Frustum) $x $y
HandleRot $gDemo(togl,OSG) $x $y
HandleRot $gDemo(togl,Offset) $x $y
HandleRot $gDemo(togl,Row) $x $y
}
proc SaveImg { type imgVec w h } {
global gDemo
set fileName [format "%s-%dx%d.png" $type $w $h]
set filePath [file join $gDemo(scriptDir) $fileName]
# Create a name on the file system, if running from within a Starpack.
set imgName [tcl3dGenExtName $filePath]
set ph [image create photo -width $w -height $h]
tcl3dVectorToPhoto $imgVec $ph $w $h 3
set fmt [string range [file extension $fileName] 1 end]
$ph write $fileName -format $fmt
image delete $ph
}
proc DrawCube {} {
global gDemo
glLoadIdentity
glTranslatef 0.0 0.0 -5.0
glRotatef $gDemo(xAngle) 1.0 0.0 0.0
glRotatef $gDemo(yAngle) 0.0 1.0 0.0
glRotatef $gDemo(zAngle) 0.0 0.0 1.0
glBegin GL_QUADS
glColor3f 0.0 0.7 0.1
glVertex3f -1.0 1.0 1.0
glVertex3f 1.0 1.0 1.0
glVertex3f 1.0 -1.0 1.0
glVertex3f -1.0 -1.0 1.0
glColor3f 0.9 1.0 0.0
glVertex3f -1.0 1.0 -1.0
glVertex3f 1.0 1.0 -1.0
glVertex3f 1.0 -1.0 -1.0
glVertex3f -1.0 -1.0 -1.0
glColor3f 0.2 0.2 1.0
glVertex3f -1.0 1.0 1.0
glVertex3f 1.0 1.0 1.0
glVertex3f 1.0 1.0 -1.0
glVertex3f -1.0 1.0 -1.0
glColor3f 0.7 0.0 0.1
glVertex3f -1.0 -1.0 1.0
glVertex3f 1.0 -1.0 1.0
glVertex3f 1.0 -1.0 -1.0
glVertex3f -1.0 -1.0 -1.0
glEnd
}
proc CallGluPerspective { fovX fovY near far } {
set aspect [expr {$fovX / $fovY}]
glLoadIdentity
gluPerspective $fovY $aspect $near $far
}
proc CallFrustumPerspective { fovX fovY near far } {
set aspect [expr {$fovX / $fovY}]
set fovYRad [tcl3dDegToRad $fovY]
set fovXRad [tcl3dDegToRad $fovX]
set top [expr {$near * tan(0.5 * $fovYRad) }]
set bottom [expr { -1.0 * $top }]
set left [expr { $bottom * $aspect }]
set right [expr { $top * $aspect }]
glLoadIdentity
glFrustum $left $right $bottom $top $near $far
}
proc CallOSGPerspective { fovX fovY near far } {
set aspect [expr {$fovX / $fovY}]
set fovYRad [tcl3dDegToRad $fovY]
set right [expr {$near * $aspect * tan(0.5 * $fovYRad) }]
set left [expr { -1.0 * $right }]
set top [expr {$near * tan(0.5 * $fovYRad) }]
set bottom [expr { -1.0 * $top }]
glLoadIdentity
glFrustum $left $right $bottom $top $near $far
}
proc CallPerspectiveWithOffset { fovX fovY near far winWidth winHeight subWidth subHeight offX offY } {
set aspect [expr {$fovX / $fovY}]
set fovY [tcl3dDegToRad $fovY]
set nTanFovX [expr {$near * $aspect * tan($fovY * 0.5) }]
set nTanFovY [expr {$near * tan($fovY * 0.5) }]
set left [expr {-1.0 * $nTanFovX * (1.0 - (2.0 * $offX / $winWidth))}]
set right [expr {$nTanFovX * (((2.0 * ($offX + $subWidth)) / $winWidth) - 1.0)}]
set bottom [expr {-1.0 * $nTanFovY * (1.0 - (2.0 * $offY / $winHeight))}]
set top [expr {$nTanFovY * (((2.0 * ($offY + $subHeight)) / $winHeight) - 1.0)}]
glLoadIdentity
glFrustum $left $right $bottom $top $near $far
}
# This procedure calls the C impementation of Tcl3D.
proc CallTcl3dPerspective { fovX fovY near far } {
set aspect [expr {$fovX / $fovY}]
set projMat [tcl3dVector GLfloat 16]
tcl3dPerspective $fovY $aspect $near $far $projMat
set projMatAsList [tcl3dVectorToList $projMat 16]
glLoadMatrixf $projMatAsList
$projMat delete
}
# This procedure calls the C impementation of Tcl3D.
proc CallTcl3dPerspectiveWithOffset { fovX fovY near far winWidth winHeight \
subWidth subHeight offX offY } {
set projMat [tcl3dVector GLfloat 16]
tcl3dPerspectiveWithOffset $fovX $fovY $near $far $winWidth $winHeight \
$subWidth $subHeight $offX $offY $projMat
set projMatAsList [tcl3dVectorToList $projMat 16]
glLoadMatrixf $projMatAsList
$projMat delete
}
proc CreateCallback { toglwin } {
set ident [lindex [$toglwin configure -ident] end]
# puts "CreateCallback $ident"
glEnable GL_DEPTH_TEST
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
global gDemo
set ident [lindex [$toglwin configure -ident] end]
# puts "ReshapeCallback $ident"
set gDemo($ident,winWidth) [$toglwin width]
set gDemo($ident,winHeight) [$toglwin height]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
switch -- $ident {
"Native" {
if { $gDemo(useTcl3dProcs) } {
CallTcl3dPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
} else {
CallGluPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
}
}
"Frustum" {
CallFrustumPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
}
"OSG" {
CallOSGPerspective $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far)
}
"Offset" {
if { $gDemo(useTcl3dProcs) } {
CallTcl3dPerspectiveWithOffset $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
$w $h $w $h 0 0
} else {
CallPerspectiveWithOffset $gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
$w $h $w $h 0 0
}
}
"Row" {
; # Do nothing in Reshape. Everything is done in DisplayCallback.
}
}
if { $gDemo(printProjMat) } {
set mat [tcl3dOglGetFloatState GL_PROJECTION_MATRIX 16]
tcl3dMatListPrint $mat "Projection matrix $ident:"
}
glMatrixMode GL_MODELVIEW
}
proc DisplayCallback { toglwin } {
global gDemo
set ident [lindex [$toglwin configure -ident] end]
# puts "DisplayCallback $ident"
set w [$toglwin width]
set h [$toglwin height]
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]
DrawCube
if { $gDemo(saveImgs) } {
set imgVec [tcl3dVector GLubyte [expr {$w * $h * 3}]]
glReadPixels 0 0 $w $h $::GL_RGB $::GL_UNSIGNED_BYTE $imgVec
SaveImg $ident $imgVec $w $h
$imgVec delete
}
$toglwin swapbuffers
}
proc DisplayCallbackRow { toglwin } {
global gDemo
set ident [lindex [$toglwin configure -ident] end]
# puts "DisplayCallback $ident"
set w [$toglwin width]
set h [$toglwin height]
set iw $gDemo(Native,winWidth)
set ih $gDemo(Native,winHeight)
if { $gDemo(saveImgs) } {
set imgVec [tcl3dVector GLubyte [expr $iw * $ih * 3]]
set rowVec [tcl3dVector GLubyte [expr $w * $h * 3]]
}
for { set row 0 } { $row < $ih } { incr row $h } {
glMatrixMode GL_PROJECTION
CallPerspectiveWithOffset \
$gDemo(fovX) $gDemo(fovY) $gDemo(near) $gDemo(far) \
$iw $ih $w $h 0 $row
if { $gDemo(printProjMat) } {
set mat [tcl3dOglGetFloatState GL_PROJECTION_MATRIX 16]
tcl3dMatListPrint $mat "Projection matrix $ident:"
}
glMatrixMode GL_MODELVIEW
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]
DrawCube
if { $gDemo(saveImgs) } {
glReadPixels 0 0 $w $h $::GL_RGB $::GL_UNSIGNED_BYTE $rowVec
set off [expr {$row * $w * 3}]
tcl3dVectorCopy $rowVec [tcl3dVectorInd $imgVec GLubyte $off] $w $h 3
}
}
if { $gDemo(saveImgs) } {
SaveImg $ident $imgVec $iw $ih
$imgVec delete
$rowVec delete
}
$toglwin swapbuffers
}
proc Cleanup {} {
global gDemo
catch { unset gDemo }
}
# Put all exit related code here.
proc ExitProg {} {
exit
}
proc CreateWindow {} {
global gDemo
wm title . "Tcl3D demo: Perspective Algorithms"
# Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
frame .fr
pack .fr
set gDemo(togl,Native) .fr.native
set gDemo(togl,Frustum) .fr.frustum
set gDemo(togl,OSG) .fr.osg
set gDemo(togl,Offset) .fr.offset
set gDemo(togl,Row) .fr.row
ttk::label .fr.l_native -text "Native gluPerspective"
togl $gDemo(togl,Native) -ident "Native" \
-width $gDemo(winWidth) -height $gDemo(winHeight) \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
ttk::label .fr.l_frustum -text "Frustum gluPerspective"
togl $gDemo(togl,Frustum) -ident "Frustum" \
-width $gDemo(winWidth) -height $gDemo(winHeight) \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
ttk::label .fr.l_osg -text "OSG gluPerspective"
togl $gDemo(togl,OSG) -ident "OSG" \
-width $gDemo(winWidth) -height $gDemo(winHeight) \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
ttk::label .fr.l_offset -text "Perspective with offset"
togl $gDemo(togl,Offset) -ident "Offset" \
-width $gDemo(winWidth) -height $gDemo(winHeight) \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
ttk::label .fr.l_row -text "Perspective with offset ($gDemo(numRows) rows)"
togl $gDemo(togl,Row) -ident "Row" \
-width $gDemo(winWidth) -height $gDemo(numRows) \
-rgba true -double true -depth true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallbackRow
ttk::checkbutton .fr.save -text "Save images" -variable gDemo(saveImgs)
ttk::label .fr.info
bind $gDemo(togl,Native) <1> "SetMousePos %x %y"
bind $gDemo(togl,Frustum) <1> "SetMousePos %x %y"
bind $gDemo(togl,OSG) <1> "SetMousePos %x %y"
bind $gDemo(togl,Offset) <1> "SetMousePos %x %y"
bind $gDemo(togl,Row) <1> "SetMousePos %x %y"
bind $gDemo(togl,Native) <B1-Motion> "MotionEvent %W %x %y"
bind $gDemo(togl,Frustum) <B1-Motion> "MotionEvent %W %x %y"
bind $gDemo(togl,OSG) <B1-Motion> "MotionEvent %W %x %y"
bind $gDemo(togl,Offset) <B1-Motion> "MotionEvent %W %x %y"
bind $gDemo(togl,Row) <B1-Motion> "MotionEvent %W %x %y"
bind . <Key-Escape> ExitProg
grid .fr.l_native -row 0 -column 0 -sticky news
grid .fr.l_frustum -row 0 -column 1 -sticky news
grid $gDemo(togl,Native) -row 1 -column 0
grid $gDemo(togl,Frustum) -row 1 -column 1
grid .fr.l_osg -row 2 -column 0 -sticky news
grid .fr.l_offset -row 2 -column 1 -sticky news
grid $gDemo(togl,OSG) -row 3 -column 0
grid $gDemo(togl,Offset) -row 3 -column 1
grid .fr.l_row -row 4 -column 0 -sticky news -columnspan 2
grid $gDemo(togl,Row) -row 5 -column 0
grid .fr.save -row 6 -column 0 -sticky news -columnspan 2
grid .fr.info -row 7 -column 0 -sticky news -columnspan 2
grid rowconfigure .fr 7 -weight 1
grid columnconfigure .fr 7 -weight 1
}
CreateWindow
PrintInfo [tcl3dOglGetInfoString]
|
