TclOgl Demo Spheres
Paul Obermeier 2005/10/11
Another demo implemented with tclogl.
TclOgl has been enhanced and renamed to Tcl3D.
I was asked, if it would be possible to use tclogl for molecule display.
Here is a little application to test the possibilities of sphere rendering with tclogl.
An updated version (using Tcl3D instead of tclogl) is available as part of the Tcl3D demos at [L1 ].
#!/bin/sh
# The next line restarts using wish84 \
exec wish8.4 $0 ${1+"$@"}
# TclOgl demo displaying spheres in various modes.
# Author: Paul Obermeier
# Date: 2005-10-11
package require tclogl
package require Togl
set no_mat { 0.0 0.0 0.0 1.0 }
set mat_ambient { 0.7 0.7 0.7 1.0 }
set mat_ambient_color { 0.8 0.8 0.2 1.0 }
set mat_diffuse { 0.1 0.5 0.8 1.0 }
set mat_specular { 1.0 1.0 1.0 1.0 }
set no_shininess { 0.0 }
set low_shininess { 5.0 }
set high_shininess { 100.0 }
set mat_emission {0.3 0.2 0.2 0.0}
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "bgerror: $msg"
}
proc RotX { w angle } {
set ::xRotate [expr {$::xRotate + $angle}]
$w postredisplay
}
proc RotY { w angle } {
set ::yRotate [expr {$::yRotate + $angle}]
$w postredisplay
}
proc RotZ { w angle } {
set ::zRotate [expr {$::zRotate + $angle}]
$w postredisplay
}
proc DrawSpheres {} {
if { $::shadeModel == $::GL_SMOOTH } {
glMaterialfv GL_FRONT GL_AMBIENT $::mat_ambient_color
glMaterialfv GL_FRONT GL_DIFFUSE $::mat_diffuse
glMaterialfv GL_FRONT GL_SPECULAR $::mat_specular
glMaterialfv GL_FRONT GL_SHININESS $::high_shininess
glMaterialfv GL_FRONT GL_EMISSION $::no_mat
}
set quadObj [gluNewQuadric]
for { set x 0 } { $x < $::numSpheresPerDim } { incr x } {
for { set y 0 } { $y < $::numSpheresPerDim } { incr y } {
for { set z 0 } { $z < $::numSpheresPerDim } { incr z } {
glPushMatrix
glTranslatef $x $y [expr {-1.0 * $z}]
if { $::lineMode } {
gluQuadricDrawStyle $quadObj GLU_LINE
} else {
gluQuadricDrawStyle $quadObj GLU_FILL
if { $::shadeModel == $::GL_SMOOTH } {
gluQuadricNormals $quadObj GLU_SMOOTH
} else {
gluQuadricNormals $quadObj GLU_FLAT
}
}
gluSphere $quadObj $::sphereSize $::numSlices $::numStacks
glPopMatrix
}
}
}
gluDeleteQuadric $quadObj
}
proc ToggleDisplayList {} {
if { $::useDisplayList } {
if { ! [info exists ::sphereList] } {
CreateDisplayList
}
} else {
if { [info exists ::sphereList] } {
glDeleteLists $::sphereList 1
unset ::sphereList
}
}
}
proc CreateDisplayList {} {
if { $::useDisplayList } {
if { [info exists ::sphereList] } {
glDeleteLists $::sphereList 1
}
set ::sphereList [glGenLists 1]
glNewList $::sphereList GL_COMPILE
DrawSpheres
glEndList
}
}
proc ShowAnimation { w } {
if { $::animStarted == 0 } {
return
}
set ::yRotate [expr {$::yRotate + 1}]
set ::zRotate [expr {$::zRotate + 1}]
$w postredisplay
set ::animId [after idle ShowAnimation $w]
}
proc tclCreateFunc { w } {
set ambient { 0.0 0.0 0.0 1.0 }
set diffuse { 1.0 1.0 1.0 1.0 }
set specular { 1.0 1.0 1.0 1.0 }
set position { 0.0 3.0 2.0 0.0 }
set lmodel_ambient { 0.4 0.4 0.4 1.0 }
set local_view { 0.0 }
glClearColor 0.0 0.1 0.1 0
glEnable GL_DEPTH_TEST
glLightfv GL_LIGHT0 GL_AMBIENT $ambient
glLightfv GL_LIGHT0 GL_DIFFUSE $diffuse
glLightfv GL_LIGHT0 GL_POSITION $position
glLightModelfv GL_LIGHT_MODEL_AMBIENT $lmodel_ambient
glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER $local_view
glEnable GL_LIGHTING
glEnable GL_LIGHT0
CreateDisplayList
}
proc tclDisplayFunc { w } {
glShadeModel $::shadeModel
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
glPushMatrix
glTranslatef $::xdist $::ydist [expr {-1.0 * $::zdist}]
glRotatef $::xRotate 1.0 0.0 0.0
glRotatef $::yRotate 0.0 1.0 0.0
glRotatef $::zRotate 0.0 0.0 1.0
if { $::useDisplayList } {
if { ! [info exists ::sphereList] } {
CreateDisplayList
}
glCallList $::sphereList
} else {
DrawSpheres
}
glPopMatrix
$w swapbuffers
}
proc tclReshapeFunc { toglwin w h } {
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
gluPerspective 60.0 [expr double($w)/double($h)] 1.0 2000.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
gluLookAt 0.0 0.0 5.0 0.0 0.0 0.0 0.0 1.0 0.0
}
proc UpdateNumSpheres { name1 name2 op } {
set numSpheres [expr $::numSpheresPerDim*$::numSpheresPerDim*$::numSpheresPerDim]
$::infoLabel configure -text "$numSpheres"
}
proc HandleRot {x y win} {
global cx cy
RotY $win [expr {180 * (double($x - $cx) / [winfo width $win])}]
RotX $win [expr {180 * (double($y - $cy) / [winfo height $win])}]
set cx $x
set cy $y
}
proc HandleTrans {axis x y win} {
global cx cy
if { $axis != "Z" } {
set ::xdist [expr {$::xdist + 0.1 * double($x - $cx)}]
set ::ydist [expr {$::ydist - 0.1 * double($y - $cy)}]
} else {
set ::zdist [expr {$::zdist + 0.1 * (double($x - $cx))}]
}
set cx $x
set cy $y
$win postredisplay
}
set ::xdist 0
set ::ydist 0
set ::zdist 5
set ::xRotate 0.0
set ::yRotate 0.0
set ::zRotate 0.0
set ::shadeModel $::GL_SMOOTH
set ::lineMode 0
set ::useDisplayList 0
set ::animStarted 0
wm title . "TclOgl spheres demo"
set frTogl [frame .f1]
set frSett [frame .f2]
set frTfms [frame .f3]
set frBttn [frame .f4]
set frInfo [frame .f5]
grid $frTogl -row 0 -column 0 -sticky news -columnspan 2
grid $frSett -row 1 -column 0 -sticky nws
grid $frTfms -row 1 -column 1 -sticky nes
grid $frBttn -row 2 -column 0 -sticky nws -columnspan 2
grid $frInfo -row 3 -column 0 -sticky news -columnspan 2
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1
grid columnconfigure . 1 -weight 1
togl $frTogl.c -width 500 -height 500 \
-double true -depth true \
-displayproc tclDisplayFunc \
-reshapeproc tclReshapeFunc \
-createproc tclCreateFunc
pack $frTogl.c -side top -expand 1 -fill both
frame $frSett.fr1
label $frSett.fr1.l1 -text "Number of slices per sphere:"
spinbox $frSett.fr1.s1 -from 4 -to 30 \
-textvariable ::numSlices -width 4 \
-command { CreateDisplayList ; $frTogl.c postredisplay }
eval pack [winfo children $frSett.fr1] -side left -anchor w -expand 1
pack $frSett.fr1 -expand 1 -anchor w
frame $frSett.fr2
label $frSett.fr2.l1 -text "Number of stacks per sphere:"
spinbox $frSett.fr2.s1 -from 4 -to 30 \
-textvariable ::numStacks -width 4 \
-command { CreateDisplayList ; $frTogl.c postredisplay }
eval pack [winfo children $frSett.fr2] -side left -anchor w -expand 1
pack $frSett.fr2 -expand 1 -anchor w
frame $frSett.fr3
label $frSett.fr3.l1 -text "Number of spheres per side:"
spinbox $frSett.fr3.s1 -from 1 -to 50 \
-textvariable ::numSpheresPerDim -width 4 \
-command { CreateDisplayList ; $frTogl.c postredisplay }
eval pack [winfo children $frSett.fr3] -side left -anchor w -expand 1
pack $frSett.fr3 -expand 1 -anchor w
frame $frSett.fr4
label $frSett.fr4.l2 -text "Total number of spheres:"
label $frSett.fr4.info -text "-1"
set ::infoLabel $frSett.fr4.info
eval pack [winfo children $frSett.fr4] -side left -anchor w -expand 1
pack $frSett.fr4 -expand 1 -anchor w
frame $frTfms.fr1
label $frTfms.fr1.lx -text "X translate:"
scale $frTfms.fr1.sx -from -50 -to 50 -length 200 -resolution 0.5 \
-orient horiz -showvalue true \
-variable xdist \
-command { $frTogl.c postredisplay }
eval pack [winfo children $frTfms.fr1] -side left -anchor nw -expand 1
pack $frTfms.fr1 -expand 1 -anchor w
frame $frTfms.fr2
label $frTfms.fr2.ly -text "Y translate:"
scale $frTfms.fr2.sy -from -50 -to 50 -length 200 -resolution 0.5 \
-orient horiz -showvalue true \
-variable ydist \
-command { $frTogl.c postredisplay }
eval pack [winfo children $frTfms.fr2] -side left -anchor nw -expand 1
pack $frTfms.fr2 -expand 1 -anchor w
frame $frTfms.fr3
label $frTfms.fr3.lz -text "Z translate:"
scale $frTfms.fr3.sz -from -50 -to 50 -length 200 -resolution 0.5 \
-orient horiz -showvalue true \
-variable zdist \
-command { $frTogl.c postredisplay }
eval pack [winfo children $frTfms.fr3] -side left -anchor nw -expand 1
pack $frTfms.fr3 -expand 1 -anchor w
checkbutton $frBttn.b1 -text "Use display list" -indicatoron 1 \
-variable ::useDisplayList \
-command ToggleDisplayList
checkbutton $frBttn.b2 -text "Use flat shading" -indicatoron 1 \
-variable ::shadeModel \
-offvalue $::GL_SMOOTH -onvalue $::GL_FLAT \
-command { $frTogl.c postredisplay }
checkbutton $frBttn.b3 -text "Use line mode" -indicatoron 1 \
-variable ::lineMode \
-command { CreateDisplayList ; $frTogl.c postredisplay }
checkbutton $frBttn.b4 -text "Animate" -indicatoron 0 \
-variable ::animStarted \
-command { ShowAnimation $frTogl.c }
eval pack [winfo children $frBttn] -side left -expand 1 -fill x
label $frInfo.l1 -text "TclOgl spheres demo: Copyright Paul Obermeier, 2005" \
-fg gray
eval pack [winfo children $frInfo] -side left -expand 1 -fill x
trace add variable ::numSpheresPerDim write UpdateNumSpheres
set ::sphereSize 0.4
set ::numSlices 15
set ::numStacks 15
set ::numSpheresPerDim 5
bind $frTogl.c <1> {set cx %x; set cy %y}
bind $frTogl.c <2> {set cx %x; set cy %y}
bind $frTogl.c <3> {set cx %x; set cy %y}
bind $frTogl.c <B1-Motion> {HandleRot %x %y %W}
bind $frTogl.c <B2-Motion> {HandleTrans X %x %y %W}
bind $frTogl.c <B3-Motion> {HandleTrans Z %x %y %W}
bind all <Escape> { exit }