# 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