Demo 12 of 17 in category tcl3dOgl
 |
# Copyright: 2005-2024 Paul Obermeier (obermeier@tcl3d.org)
#
# See the file "Tcl3D_License.txt" for information on
# usage and redistribution of this file, and for a
# DISCLAIMER OF ALL WARRANTIES.
#
# Module: Tcl3D -> tcl3dOgl
# Filename: Sierpinski.tcl
#
# Author: Paul Obermeier
#
# Description: Tcl3D demo displaying a 3D Sierpinski Tetrahedron.
#
# Derived from a demo by Gerard Sookahet (tetra-3dc.tcl),
# which used the 3dcanvas package.
# The original version is at: http://wiki.tcl.tk/11832.
#
# Incorporates optimization functions by Philip Quaife.
# See the Tcl'ers Wiki http://wiki.tcl.tk/14820 for a
# description of his optimizations.
package require Tk
package require tcl3d
set vdist 600
set rdepth 4
set xRotate 0.0
set yRotate 0.0
set zRotate 0.0
set animStarted 0
set frameCount 0
set useOpt 0
set buildInfo "Info"
set appName "Tcl3D demo: Sierpinski Tetrahedron"
# Create a stop watch for time measurement.
set stopwatch [tcl3dNewSwatch]
# Show errors occuring in the Togl callbacks.
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
proc GetFPS { { elapsedFrames 1 } } {
set currentTime [tcl3dLookupSwatch $::stopwatch]
set fps [expr $elapsedFrames / ($currentTime - $::s_lastTime)]
set ::s_lastTime $currentTime
return $fps
}
proc DisplayFPS {} {
global frameCount
incr frameCount
if { $frameCount == 100 } {
wm title . [format "%s (%.0f fps)" $::appName [GetFPS $frameCount]]
set frameCount 0
}
}
proc trans { w args } {
$w postredisplay
}
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
}
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
}
proc ShowAnimation { w } {
if { $::animStarted == 0 } {
return
}
set ::yRotate [expr {$::yRotate + 0.1}]
set ::zRotate [expr {$::zRotate + 0.1}]
$w postredisplay
set ::animId [tcl3dAfterIdle ShowAnimation $w]
}
proc StartAnimation {} {
if { ! [info exists ::animateId] } {
set ::animStarted 1
ShowAnimation $::frTogl.toglwin
}
}
proc StopAnimation {} {
if { [info exists ::animId] } {
after cancel $::animId
set ::animStarted 0
}
}
# 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 } {
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
}
}
}
}
### Move proc here so we can inline it in the next proc
proc DrawTetraOpt { w p1 p2 p3 p4 } {
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
}
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]
## Inline the DrawTetra proc also!
set body [string map [list {DrawTetraOpt $w $p1 $p2 $p3 $p4} [info body DrawTetraOpt]] $body]
catch {rename SierpinskiOpt {} }
proc SierpinskiOpt {w level p1 p2 p3 p4} $body
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 { $::useOpt } {
set ::buildTime [time {SierpinskiOpt $w 0 $p1 $p2 $p3 $p4}]
} else {
set ::buildTime [time {Sierpinski $w 0 [concat $p1 $p2 $p3 $p4]}]
}
glEndList
$w postredisplay
set ::buildInfo [format "%d triangles: %d msec to build" \
$::numTrias [expr [lindex $::buildTime 0] / 1000]]
}
proc CreateCallback { w } {
glClearColor 0 0 0 0
glEnable GL_DEPTH_TEST
glShadeModel GL_FLAT
Init $w
tcl3dStartSwatch $::stopwatch
set ::startTime [tcl3dLookupSwatch $::stopwatch]
set ::s_lastTime $::startTime
set ::elapsedLastTime $::startTime
}
proc DisplayCallback { 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
if { $::animStarted } {
DisplayFPS
}
$w swapbuffers
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
set w [$toglwin width]
set h [$toglwin height]
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
}
wm title . $appName
set frMast [frame .fr]
set frTogl [frame .fr.togl]
set frBttn [frame .fr.bttn]
set frInfo [frame .fr.info]
pack $frMast -expand 1 -fill both
grid $frTogl -row 0 -column 0 -sticky news
grid $frBttn -row 1 -column 0 -sticky nws
grid $frInfo -row 2 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
togl $frTogl.toglwin -width 500 -height 500 \
-double true -depth true \
-displaycommand DisplayCallback \
-reshapecommand ReshapeCallback \
-createcommand CreateCallback
pack $frTogl.toglwin -side top -expand 1 -fill both
label $frBttn.l1 -text "Recursive depth "
spinbox $frBttn.sdepth -from 1 -to 10 -textvariable rdepth -width 4
button $frBttn.b -text "Build" \
-command { Init $frTogl.toglwin ; $frTogl.toglwin postredisplay }
checkbutton $frBttn.opt -text "Optimize" -indicatoron 1 \
-variable ::useOpt
label $frBttn.l2 -text " View distance "
scale $frBttn.vd -from 0 -to 1000 -length 100 -orient horiz -showvalue false \
-variable vdist -command "trans $frTogl.toglwin"
checkbutton $frBttn.b1 -text "Animate" -indicatoron [tcl3dShowIndicator] \
-variable ::animStarted \
-command { ShowAnimation $frTogl.toglwin }
eval pack [winfo children $frBttn] -side left -anchor w -expand 1
label $frInfo.l1 -textvariable buildInfo -bg white
label $frInfo.l2 -text [tcl3dOglGetInfoString]
eval pack [winfo children $frInfo] -pady 2 -side top -expand 1 -fill x
bind . <Key-Escape> { exit }
bind $frTogl.toglwin <1> {set cx %x; set cy %y}
bind $frTogl.toglwin <B1-Motion> {handleRot %x %y %W}
if { [file tail [info script]] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then start animation.
update
StartAnimation
}
|
