Tetrahedron with tclogl
Paul Obermeier 2005/07/27
The Sierpinski demo implemented with tclogl.
TclOgl has been enhanced and renamed to Tcl3D.
This is a slightly modified version of Tetrahedron with 3dcanvas, but instead of using the 3dcanvas package, it uses hardware accelerated OpenGL calls.
See also Optimized Tetrahedron with tclogl.
An updated version (including the optimizations mentioned above) is available as part of the Tcl3D demos at [L1 ].
#!/bin/sh
# The next line restarts using wish84 \
exec wish8.4 $0 ${1+"$@"}
# tetra-3dc.tcl
# Author: Gerard Sookahet
# Date: 2004-06-18
# Description: 3D Sierpinski Tetrahedron with 3dcanvas
# Modified to use OpenGL (package tclogl)
# Author: Paul Obermeier
# Date: 2005-06-27
package require Tk
package require tclogl
package require Togl
catch { console show }
bind all <Escape> { exit }
proc About {} {
set w .about
catch {destroy $w} ; toplevel $w
wm title $w "About this demo"
message $w.msg -justify center -aspect 250 -relief sunken \
-text "tclogl demo: Sierpinski Tetrahedron\n\nGerard Sookahet, June 2004\n\nPaul Obermeier, June 2005"
button $w.bquit -text OK -command {destroy .about}
eval pack [winfo children $w]
}
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
}
# Animation loop
proc Animate { w } {
rotY $w 3
rotZ $w 3
after 32 Animate $w
}
proc Sierpinski { w level l } {
global rdepth
if {$level > $rdepth} then return
set i 1
foreach {x y z} $l {
set p($i) "$x $y $z"
incr i
}
set p12 [MidPoint [concat $p(1) $p(2)]]
set p13 [MidPoint [concat $p(1) $p(3)]]
set p14 [MidPoint [concat $p(1) $p(4)]]
set p23 [MidPoint [concat $p(2) $p(3)]]
set p24 [MidPoint [concat $p(2) $p(4)]]
set p34 [MidPoint [concat $p(3) $p(4)]]
incr level
if {$level == $rdepth} then {
DrawTetra $w [concat $p(1) $p(2) $p(3) $p(4)]
}
Sierpinski $w $level [concat $p(1) $p12 $p13 $p14]
Sierpinski $w $level [concat $p(2) $p12 $p23 $p24]
Sierpinski $w $level [concat $p(3) $p13 $p23 $p34]
Sierpinski $w $level [concat $p(4) $p14 $p24 $p34]
}
proc DrawTetra { w l } {
#puts "DrawTetra $l"
set i 1
foreach {x y z} $l {
set p($i) [list $x $y $z]
incr i
}
glBegin GL_TRIANGLES
glColor3f 1 0 0 ; # RED
glVertex3fv $p(1)
glVertex3fv $p(2)
glVertex3fv $p(3)
glColor3f 1 1 0 ; # YELLOW
glVertex3fv $p(2)
glVertex3fv $p(3)
glVertex3fv $p(4)
glColor3f 0 0 1 ; # BLUE
glVertex3fv $p(1)
glVertex3fv $p(3)
glVertex3fv $p(4)
glColor3f 0 1 0 ; # GREEN
glVertex3fv $p(1)
glVertex3fv $p(2)
glVertex3fv $p(4)
glEnd
incr ::numTrias 4
}
# Return the middle coordinates of two 3d points
proc MidPoint { l } {
set X 0
set Y 0
set Z 0
foreach {x y z} $l {
set X [expr {$X + $x}]
set Y [expr {$Y + $y}]
set Z [expr {$Z + $z}]
}
return [list [expr {$X/2}] [expr {$Y/2}] [expr {$Z/2}]]
}
proc Init { w } {
set edge 340
set x1 [expr {sqrt(3)*$edge/3}]
set x2 [expr {sqrt(3)*$edge/6}]
set z3 [expr {sqrt(6)*$edge/3}]
set y2 [expr {$edge/2}]
# Vertices' coordinates of the regular tetrahedron
set p1 "$x1 0 0"
set p2 "-$x2 $y2 0"
set p3 "-$x2 -$y2 0"
set p4 "0 0 $z3"
if { [info exists ::sierList] } {
glDeleteLists $::sierList 1
}
set ::sierList [glGenLists 1]
glNewList $::sierList GL_COMPILE
set ::numTrias 0
Sierpinski $w 0 [concat $p1 $p2 $p3 $p4]
puts "Number of triangles: $::numTrias"
glEndList
}
proc tclCreateFunc { w } {
glClearColor 0 0 0 0
glEnable GL_DEPTH_TEST
glShadeModel GL_FLAT
Init $w
}
proc tclDisplayFunc { w } {
glClear [expr $::GL_COLOR_BUFFER_BIT | $::GL_DEPTH_BUFFER_BIT]
glPushMatrix
glTranslatef 0 0 [expr -1.0 * $::vdist]
glRotatef $::xRotate 1.0 0.0 0.0
glRotatef $::yRotate 0.0 1.0 0.0
glRotatef $::zRotate 0.0 0.0 1.0
glCallList $::sierList
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
}
set vdist 400
set rdepth 1
set xRotate 0.0
set yRotate 0.0
set zRotate 0.0
wm title . "Sierpinski Tetrahedron"
togl .c -width 500 -height 500 \
-double true -depth true \
-displayproc tclDisplayFunc \
-reshapeproc tclReshapeFunc \
-createproc tclCreateFunc
pack .c -side top
set f1 [frame .f1]
label $f1.l1 -text "Recursive depth "
spinbox $f1.sdepth -from 1 -to 10 -textvariable rdepth -width 4
label $f1.l2 -text " View distance "
scale $f1.vd -from 0 -to 1000 -length 200 -orient horiz -showvalue true \
-variable vdist -command {.c postredisplay}
eval pack [winfo children $f1] -side left
pack $f1
set f2 [frame .f2]
button $f2.brun -text "Run" -width 10 -fg white -bg blue -command {Init .c}
button $f2.bromega -text "Z rotate" -width 10 -command {rotZ .c 8}
button $f2.brphi -text "Y rotate" -width 10 -command {rotY .c 8}
button $f2.brtheta -text "X rotate" -width 10 -command {rotX .c 8}
button $f2.banim -text Animate -width 10 -command {Animate .c}
button $f2.babout -text A -width 1 -bg grey -command {About}
button $f2.bquit -text Quit -width 10 -bg grey -command exit
eval pack [winfo children $f2] -side left
pack $f2
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
}
bind .c <1> {set cx %x; set cy %y}
bind .c <B1-Motion> {handleRot %x %y %W}This is wrong:
scale $f1.vd -from 0 -to 1000 -length 200 -orient horiz -showvalue true -variable vdist -command {.c postredisplay}Since "scale" passed in parameter to ".c postredisplay <value>" and it doesn't like that. Fix is
proc handleScale {s} {
.c postredisplay
}
scale $f1.vd -from 0 -to 1000 -length 200 -orient horiz -showvalue true -variable vdist -command {handleScale}Also, tclReshapeFunc callback passed in only one value. So it has to be
proc tclReshapeFunc { toglwin } {
set w [$toglwin width]
set h [$toglwin height]