Philip Quaife 12 Oct 95.
Not having anything better to do, I noticed the post for generating Sierpinski Tetrahedron with tclogl [L1 ] which I had not looked at before.
I downloaded it and the first thing I noticed, was why is it so slow in both generating the triangles, as well as displaying the images.
I have applied the following:
'''Why?'''
One version of this code makes Tcl look good, the other does not. You decide which way of programming is appropriate.
Results
Original
6 Levels 3.3 secs. 7 Levels 13.5 secs. 8 Levels 55 secs.
Specialised
6 Levels 630mS 7 " 2.5secs 8 " 10secs
Non recursive specialised (with optimal list handling)
6 Levels 165ms 7 " 650ms 8 " 2.6secs
Note: The generation of the quads for each triangle is not correct and I have made no attempt to correct it. They need to be generated with left hand winding order. This would allow GL_CULL_FACE to be applied which would speed up the display of the scene.
PWQ Ok, call me lazy, I should have inlined the call to DrawTetra, this saves another 100ms on level 8.
#!/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
# Modified to have optimised drawing functions.
# Author: Philip Quaife
# Date: 2005-10-12
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
}
# 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 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
}
proc MidPointOpt { p1 p2 } {
list [expr {([lindex $p1 0]+[lindex $p2 0])/2}] \
[expr {([lindex $p1 1]+[lindex $p2 1])/2}] \
[expr {([lindex $p1 2]+[lindex $p2 2])/2}]
}
proc SierpinskiOptNR { w level p1 p2 p3 p4 } {
global rdepth
set nextpoints [list $level $p1 $p2 $p3 $p4]
while {[llength $nextpoints]} {
set points $nextpoints
set nextpoints [list]
foreach {l p1 p2 p3 p4} $points {
set p12 [MidPointOpt $p1 $p2]
set p13 [MidPointOpt $p1 $p3]
set p14 [MidPointOpt $p1 $p4]
set p23 [MidPointOpt $p2 $p3]
set p24 [MidPointOpt $p2 $p4]
set p34 [MidPointOpt $p3 $p4]
set level [expr {$l + 1}]
if {$level == $rdepth } then {
DrawTetraOpt $w $p1 $p2 $p3 $p4
} else {
lappend nextpoints $level $p1 $p12 $p13 $p14
lappend nextpoints $level $p2 $p12 $p23 $p24
lappend nextpoints $level $p3 $p13 $p23 $p34
lappend nextpoints $level $p4 $p14 $p24 $p34
}
}
}
}
### Move proc here so we can inline it in the next proc
proc DrawTetraOpt { w p1 p2 p3 p4 } {
glBegin GL_TRIANGLES
glColor3f 1 0 0 ; # RED
glVertex3fv $p1
glVertex3fv $p2
glVertex3fv $p3
glColor3f 1 1 0 ; # YELLOW
glVertex3fv $p2
glVertex3fv $p3
glVertex3fv $p4
glColor3f 0 0 1 ; # BLUE
glVertex3fv $p1
glVertex3fv $p3
glVertex3fv $p4
glColor3f 0 1 0 ; # GREEN
glVertex3fv $p1
glVertex3fv $p2
glVertex3fv $p4
glEnd
incr ::numTrias 4
}
proc SierpinskiOpt { w level p1 p2 p3 p4 } {
global rdepth
if {$level > $rdepth} then return
set p12 [MidPointOpt $p1 $p2]
set p13 [MidPointOpt $p1 $p3]
set p14 [MidPointOpt $p1 $p4]
set p23 [MidPointOpt $p2 $p3]
set p24 [MidPointOpt $p2 $p4]
set p34 [MidPointOpt $p3 $p4]
incr level
if {$level == $rdepth} then {
DrawTetraOpt $w $p1 $p2 $p3 $p4
}
SierpinskiOpt $w $level $p1 $p12 $p13 $p14
SierpinskiOpt $w $level $p2 $p12 $p23 $p24
SierpinskiOpt $w $level $p3 $p13 $p23 $p34
SierpinskiOpt $w $level $p4 $p14 $p24 $p34
}
###
### SPECIALIZE : Inline MidPoint in SierpinskiOpt
###
rename SierpinskiOpt {}
rename SierpinskiOptNR SierpinskiOpt
set map {}
foreach {txt p1 p2 } [regexp -inline -all {[[]MidPointOpt (.*?) (.*?)[]]} [set body [info body SierpinskiOpt]]] {
lappend map $txt
set x [subst -nocommand {[expr {([lindex $p1 0]+[lindex $p2 0])/2}]}]
set y [subst -nocommand {[expr {([lindex $p1 1]+[lindex $p2 1])/2}]}]
set z [subst -nocommand {[expr {([lindex $p1 2]+[lindex $p2 2])/2}]}]
lappend map "\[list $x $y $z \]"
}
set body [string map $map $body]
## Inline the DrawTetra proc also!
set body [string map [list {DrawTetraOpt $w $p1 $p2 $p3 $p4} [info body DrawTetraOpt]] $body]
catch {rename SierpinskiOpt {} }
proc SierpinskiOpt {w level p1 p2 p3 p4} $body
set ::opt 0
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 [list $x1 0 0]
set p2 [list -$x2 $y2 0]
set p3 [list -$x2 -$y2 0]
set p4 [list 0 0 $z3]
if { [info exists ::sierList] } {
glDeleteLists $::sierList 1
}
set ::sierList [glGenLists 1]
glNewList $::sierList GL_COMPILE
set ::numTrias 0
if {$::opt} {
set x [time {SierpinskiOpt $w 0 $p1 $p2 $p3 $p4}]
} else {
set x [time {Sierpinski $w 0 [concat $p1 $p2 $p3 $p4]}]
}
glEndList
$w postredisplay
set ::time "($::numTrias Tri's in [expr {[lindex $x 0]/1000}] ms)"
}
proc tclCreateFunc { w } {
glClearColor 0 0 0 0
glEnable GL_DEPTH_TEST
### FIX THE WINDING ORDER FOR THE MIDPOINT GENERATION!!!
# glEnable GL_CULL_FACE
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"
eval destroy [winfo children .]
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}
checkbutton $f1.opt -variable ::opt -text Opt
label $f1.time -textvariable ::time
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}Terrific case study! -jcw