Updated 2010-06-06 17:05:28 by paul

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 [1].


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