Tetrahedron with 3dcanvas

GS - This little demo uses the 3dcanvas widget to draw a Sierpinski tetrahedon. We start with a tetrahedron which is replaced by 4 tetrahedra with half the previous edge length at the four corners. Then we repeat the process for the remaining tetrahedra.

The 3dcanvas shared library is available for:

Linux [1]
Windows [2] (compiled by EB)

# tetra-3dc.tcl 
# Author: Gerard Sookahet
# Date: 2004-06-18
# Description: 3D Sierpinski Tetrahedron with 3dcanvas

package require Tk
load ./dddcanvas10[info sharedlibextension]

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 "3dcanvas demo: Sierpinski Tetrahedron\n\nGerard Sookahet\n\nJune 2004"
 button $w.bquit -text OK -command {destroy .about}
 eval pack [winfo children $w]
}

# Animation loop
proc Animate {} {
    global G
 .c phirot $G 3
 .c thetarot $G 3
 after 32 Animate
}

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 } {
    global G
 set i 1
 foreach {x y z} $l {
        set p($i) "$x $y $z"
        incr i
 }
 $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(2) $p(3)] " "] -fill red]
 $w addgroup $G items [eval $w create polygon [join [concat $p(2) $p(3) $p(4)] " "] -fill yellow]
 $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(3) $p(4)] " "] -fill blue]
 $w addgroup $G items [eval $w create polygon [join [concat $p(1) $p(2) $p(4)] " "] -fill green]

}

# 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 } {
    global G
 $w delete all
 set G [.c create group]

 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"

 Sierpinski $w 0 [concat $p1 $p2 $p3 $p4]
}
 
proc Main {} {
    global somega sphi stheta
    global vdist 
    global rdepth 
    
  set vdist 2400
  set rdepth 4

  wm title . "Sierpinski Tetrahedron"
  3dcanvas .c -bg black -width 500 -height 500
  pack .c -side top

  set f1 [frame .f1]
  label $f1.l1 -text "Recursive depth "
  spinbox $f1.sdepth -from 1 -to 7 -textvariable rdepth -width 4
  label $f1.l2 -text "   View distance "
  scale $f1.vd -from 4600 -to 1000 -length 210 -orient horiz -showvalue true \
               -variable vdist -command {.c configure -viewdistance}
  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 "Omega rotate" -width 10 -command {.c omegarot $G 8}
  button $f2.brphi -text "Phi rotate" -width 10 -command {.c phirot $G 8}
  button $f2.brtheta -text "Theta rotate" -width 10 -command {.c thetarot $G 8}
  button $f2.banim -text Animate -width 10 -command {Animate}
  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 
}

Main

Discussion edit

MDD: I get the following error on Win2k: "couldn't load library "./dddcanvas10.dll": this library or a dependent library could not be found in library path" I'm running TclKit 8.4.2, and the dddcanvas10.dll file is in the launch directory. I even tried explicitly loading the dll from the console, but got the same error.

To ask a possibly stupid question: did you have the DLL in the same directory as Wish (c:/tcl/bin if you use the default installation dir)? Otherwise, you'd need to change the path

MDD: Yup. I'm using Tclkit, and routinely load dlls in that manner, such as the Img or SQLite dlls, without any problems. Does the dll have any dependencies that might conflict with invocation via tclkit.exe?

Yes, the dll is not stub-enabled, so require tcl84.dll and tk84.dll MDD: That would explain it. ;-)

LES: works for me on Windows 98. But I couldn't see and use the control buttons until I replaced set vdist 2400 with set vdist 2000 on line 104. My screen res is 800x600.

FW: Add this at the end to allow for click-and-drag rotation:

 proc handleRot {x y win} { global cx cy G
   $win phirot $G [expr {180 * (double($x - $cx) / [winfo width $win])}]
   $win thetarot $G [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}

That is wonderful! As an aside, I am reminded of Alexander Graham Bell's tetrahedral kites [3] which are also based around the Sierpinski tetrahedron.