#!/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 beproc tclReshapeFunc { toglwin } {
set w [$toglwin width]
set h [$toglwin height]