Version 2 of Tetrahedron with tclogl

Updated 2006-06-21 21:27:34

Paul Obermeier 2005/07/27

The Sierpinski demo implemented with tclogl. This is a slightly modified version of Tetrahedron with 3dcanvas, but instead of using the 3dcanvas package, it uses hardware accelerated OpenGL calls.

See Optimized Tetrahedron with tclogl.


http://www.poSoft.de/images/sierpinski3.png http://www.poSoft.de/images/sierpinski8.png


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

[ Category Graphics | Category 3D Graphics | Category Tcl3D ]