Demo 1 of 5 in category tcl3dTogl
 |
# tcl3dDouble.tcl
#
# A Tcl3D widget demo with two windows, one single buffered and the
# other double buffered.
#
# This is a version of the original Togl double demo written entirely in Tcl
# with the help of the Tcl3D package.
#
# Copyright (C) 1996 Brian Paul and Ben Bederson (Original C/Tcl version)
# Copyright (C) 2005-2024 Paul Obermeier (Tcl3D version)
# See the LICENSE file for copyright details.
#
# Original sources available at: http://sourceforge.net/projects/togl/
package require tcl3d
# 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 CreateCallback { toglwin } {
set ::FontBase [$toglwin loadbitmapfont]
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set w [$toglwin width]
set h [$toglwin height]
set aspect [expr double ($w) / double ($h)]
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
glFrustum [expr -1.0 * $aspect] $aspect -1.0 1.0 1.0 10.0
set ::CornerX [expr -1.0 * $aspect]
set ::CornerY -1.0
set ::CornerZ -1.1
glMatrixMode GL_MODELVIEW
}
proc PrintString {s} {
set len [string length $s]
if { $len > 0 } {
glListBase $::FontBase
set sa [tcl3dVectorFromString GLubyte $s]
glCallLists $len GL_UNSIGNED_BYTE $sa
$sa delete
}
}
proc DisplayCallback { 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]
glLoadIdentity
glTranslatef 0.0 0.0 -3.0
glRotatef $::xAngle 1.0 0.0 0.0
glRotatef $::yAngle 0.0 1.0 0.0
glRotatef 0.0 0.0 0.0 1.0
glEnable GL_DEPTH_TEST
if { ! [info exists ::cubeList] } {
set ::cubeList [glGenLists 1]
glNewList $::cubeList GL_COMPILE
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
glEndList
}
glCallList $::cubeList
glDisable GL_DEPTH_TEST
glLoadIdentity
glColor3f 1.0 1.0 1.0
glRasterPos3f $::CornerX $::CornerY $::CornerZ
set ident [lindex [$toglwin configure -ident] end]
if { [string compare $ident "Single"] == 0 } {
PrintString "Single buffered"
} else {
PrintString "Double buffered"
}
$toglwin swapbuffers
}
proc SetRotX { wid val } {
set ::xAngle $val
if { $::xAngle < 0.0 } {
set ::xAngle [expr $::xAngle + 360.0]
} elseif { $::xAngle > 360.0 } {
set ::xAngle [expr $::xAngle - 360.0]
}
$wid postredisplay
}
proc SetRotY { wid val } {
set ::yAngle $val
if { $::yAngle < 0.0 } {
set ::yAngle [expr $::yAngle + 360.0]
} elseif { $::yAngle > 360.0 } {
set ::yAngle [expr $::yAngle - 360.0]
}
$wid postredisplay
}
proc Cleanup {} {
# Destroy the display list and it's associated variable.
# Needed when running the demo in the presentation framework.
if { [info exists ::cubeList] } {
glDeleteLists $::cubeList 1
unset ::cubeList
}
}
proc CreateWindows {} {
wm title . "Tcl3D demo: Single vs Double Buffering"
# Master frame. Needed to integrate demo into Tcl3D Starpack presentation.
frame .fr
pack .fr -expand 1 -fill both
frame .fr.f1
# create first Togl widget
togl .fr.f1.o1 -width 400 -height 400 -rgba true \
-double false -depth true -ident Single \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
# create second Togl widget, share display lists with first widget
togl .fr.f1.o2 -width 400 -height 400 -rgba true \
-double true -depth true -ident Double -sharelist Single \
-createcommand CreateCallback \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback
frame .fr.x
label .fr.x.l -text "X Axis"
scale .fr.x.s -from 0 -to 360 -command {SetAngle x} -orient horizontal -variable ::xAngle
frame .fr.y
label .fr.y.l -text "Y Axis"
scale .fr.y.s -from 0 -to 360 -command {SetAngle y} -orient horizontal -variable ::yAngle
label .fr.info
bind .fr.f1.o1 <B1-Motion> {
MotionEvent [lindex [%W config -width] 4] \
[lindex [%W config -height] 4] \
%x %y
}
bind .fr.f1.o2 <B1-Motion> {
MotionEvent [lindex [%W config -width] 4] \
[lindex [%W config -height] 4] \
%x %y
}
bind . <Key-Escape> "exit"
grid .fr.f1 -row 0 -column 0 -sticky news
grid .fr.x -row 1 -column 0 -sticky news
grid .fr.y -row 2 -column 0 -sticky news
grid .fr.info -row 3 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
pack .fr.f1.o1 -side left -padx 2 -pady 2 -fill both -expand true
pack .fr.f1.o2 -side left -padx 2 -pady 2 -fill both -expand true
pack .fr.x.l -side left
pack .fr.x.s -side left -fill x -expand true
pack .fr.y.l -side left
pack .fr.y.s -side left -fill x -expand true
}
# This is called when mouse button 1 is pressed and moved in either of
# the OpenGL windows.
proc MotionEvent { width height x y } {
SetRotX .fr.f1.o1 [expr 360.0 * $y / $height]
SetRotX .fr.f1.o2 [expr 360.0 * $y / $height]
SetRotY .fr.f1.o1 [expr 360.0 * ($width - $x) / $width]
SetRotY .fr.f1.o2 [expr 360.0 * ($width - $x) / $width]
.fr.x.s set $::xAngle
.fr.y.s set $::yAngle
}
# This is called when a slider is changed.
proc SetAngle {axis value} {
global xAngle yAngle
switch -exact $axis {
x {SetRotX .fr.f1.o1 $value
SetRotX .fr.f1.o2 $value
}
y {SetRotY .fr.f1.o1 $value
SetRotY .fr.f1.o2 $value
}
}
}
set xAngle 33.0
set yAngle 45.0
CreateWindows
PrintInfo [tcl3dOglGetInfoString]
|
