[Philip Quaife] ''12 Oct 95''.

Not having anything better to do, I noticed the post for generating
Sierpinski Tetrahedron with tclogl [http://wiki.tcl.tk/14520] 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.
   1. Removed concat. 
   1. Applied specialisation to midpoint generation.
   1. 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. ''


----

 #!/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
	}
	}
	}
 }

 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]
  catch {rename SierpinskiOpt {} }
  proc SierpinskiOpt {w level p1 p2 p3 p4} $body

 proc DrawTetraOpt { w p1 p2 p3 p4 } {
     #puts "DrawTetra $l"
     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
 }

 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]''