Updated 2010-06-06 16:51:12 by paul ▲

Philip Quaife 12 Oct 95.

Not having anything better to do, I noticed the post for generating Sierpinski Tetrahedron with tclogl [1] 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:

  1. Use of lists vs arrays for storing vertex information.
  2. Removed concat.
  3. Applied specialisation to midpoint generation.
  4. Provided non recursive algorithm for generating triangles.
 '''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

Category GraphicsCategory 3D GraphicsCategory Tcl3D