# Copyright: 2007-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: tcl3dChaos.tcl
#
# Author: Paul Obermeier
#
# Description: Implementation of algorithmn described on Wiki page
# "Simple Chaos Theory with Tcl" (http://wiki.tcl.tk/11887)
# using Tcl3D.
# Interesting values:
# 2000 8 10 14 revert
# 6300 3 3 3 revert
package require Tk
set retVal [catch {package require tcl3d} gVersion]
set gHaveTcl3D [expr !$retVal]
set gSett(Width) 640
set gSett(Height) 480
set gSett(PixelSize) 1
set gOpts(Iterations) 300
set gOpts(Red) 24
set gOpts(Green) 24
set gOpts(Blue) 24
set gOpts(Revert) 0
set gOpts(ScanMode) 1
set gOpts(UseTcl3D) $gHaveTcl3D
proc PrintGeneralInfo {} {
global gOpts tcl_platform
if { ! [winfo exists .fr.info] } {
return
}
if { $gOpts(UseTcl3D) } {
.fr.info configure -text [tcl3dOglGetInfoString]
} else {
.fr.info configure -text \
[format "Running on %s with a Photo image (Tcl %s)" \
$tcl_platform(os) [info patchlevel]]
}
}
proc PrintExecutionInfo { msg { timeStr "" } } {
if { [winfo exists .fr.row2.l_TimeInfo] } {
if { $timeStr ne "" } {
scan $timeStr "%d" ms
set sec [expr { $ms / 1000.0 / 1000.0 }]
append msg [format " %.1f seconds" $sec]
}
.fr.row2.l_TimeInfo configure -text $msg
}
}
proc Clip { c } {
if {$c > 255} {
return 255
} elseif {$c < 0} {
return 0
} else {
return $c
}
}
proc GetColorString {r g b} {
return "#[format %02x $r][format %02x $g][format %02x $b]"
}
proc SetPixel { x y r g b } {
global gSett gOpts
global gCountPixels
set r [Clip $r]
set g [Clip $g]
set b [Clip $b]
if { $gOpts(UseTcl3D) } {
glColor3ub $r $g $b
glVertex3f $x [expr {$gSett(Height) - $y}] 0.0
} else {
set colorStr [GetColorString $r $g $b]
CANVAS put $colorStr -to $x $y
}
incr gCountPixels
}
proc IncrPixel {x y r g b {optReverse false}} {
global gColCache
if { ! [info exists gColCache($y,r)] } {
if {$optReverse} {
set gColCache($y,r) 0
set gColCache($y,g) 0
set gColCache($y,b) 0
} else {
set gColCache($y,r) 255
set gColCache($y,g) 255
set gColCache($y,b) 255
}
}
if {$optReverse} {
set r -$r
set g -$g
set b -$b
}
set gColCache($y,r) [expr {$gColCache($y,r) - $r}]
set gColCache($y,g) [expr {$gColCache($y,g) - $g}]
set gColCache($y,b) [expr {$gColCache($y,b) - $b}]
}
proc Redraw {} {
global gOpts
if { $gOpts(UseTcl3D) && [winfo exists .fr.toglwin] } {
.fr.toglwin postredisplay
}
}
proc ClearBackground { reverse } {
global gSett gOpts
if { $gOpts(UseTcl3D) } {
if {$reverse} {
glClearColor 0.0 0.0 0.0 0.0
} else {
glClearColor 1.0 1.0 1.0 0.0
}
} else {
InitPhoto
if {$reverse} {
CANVAS put black -to 0 0 $gSett(Width) $gSett(Height)
} else {
CANVAS put white -to 0 0 $gSett(Width) $gSett(Height)
}
}
}
proc Chaos { iterations r g b {optReverse false} {optUpdate false} } {
global gSett gOpts gOgl
global gColCache gStopUpdate gCountPixels
set x 0.4
set gStopUpdate false
set gCountPixels 0
ClearBackground $optReverse
if { $gOpts(UseTcl3D) } {
if { [info exists gOgl(DisplayListBase)] && \
[glIsList $gOgl(DisplayListBase)] } {
glDeleteLists $gOgl(DisplayListBase) $gOgl(DisplayListLen)
set gOgl(DisplayListBase) [glGenLists $gSett(Width)]
set gOgl(DisplayListLen) $gSett(Width)
}
}
for {set sx 0} {$sx < $gSett(Width)} {incr sx} {
set r_value [expr { pow(($sx*1.0)/$gSett(Width), 0.25) * 3.0 + 1.0} ]
catch { unset gColCache }
for {set i 1} {$i <= $iterations} {incr i} {
set x [expr {$r_value * $x * (1 - $x)}]
set sy [expr {int($gSett(Height) - $x*$gSett(Height))}]
IncrPixel $sx $sy $r $g $b $optReverse
}
if { $gOpts(UseTcl3D) } {
glNewList [expr {$sx + $gOgl(DisplayListBase)}] GL_COMPILE
glBegin GL_POINTS
}
foreach redIndex [array names gColCache "*,r"] {
set row [lindex [split $redIndex ","] 0]
SetPixel $sx $row $gColCache($row,r) \
$gColCache($row,g) \
$gColCache($row,b)
}
if { $gOpts(UseTcl3D) } {
glEnd
glEndList
}
if { $optUpdate } {
Redraw
update
}
if { $gStopUpdate } {
set gStopUpdate false
break
}
}
}
proc StartChaos {} {
global gOpts
global gCountPixels
# Stop an already running Chaos run.
StopChaos
PrintExecutionInfo "Calculating chaos ..."
update
set ms [time {Chaos $gOpts(Iterations) \
$gOpts(Red) $gOpts(Green) $gOpts(Blue) \
$gOpts(Revert) $gOpts(ScanMode)} 1]
PrintExecutionInfo "Time for $gCountPixels pixels:" $ms
Redraw
}
proc StopChaos {} {
global gStopUpdate
set gStopUpdate true
update
}
proc StartAnimation {} {
StartChaos
}
proc StopAnimation {} {
StopChaos
}
proc CreateCallback { toglwin } {
global gSett gOgl
glClearColor 1.0 1.0 1.0 0.0
glPointSize $::gSett(PixelSize)
set gOgl(DisplayListBase) [glGenLists $gSett(Width)]
set gOgl(DisplayListLen) $gSett(Width)
}
proc ReshapeCallback { toglwin { w -1 } { h -1 } } {
global gSett gOpts
if { $gOpts(UseTcl3D) } {
set w [$toglwin width]
set h [$toglwin height]
}
set gSett(Width) $w
set gSett(Height) $h
if { $gOpts(UseTcl3D) } {
glViewport 0 0 $w $h
glMatrixMode GL_PROJECTION
glLoadIdentity
glOrtho 0.0 $w 0.0 $h -1.0 1.0
glMatrixMode GL_MODELVIEW
glLoadIdentity
}
}
proc DisplayCallback { toglwin } {
global gSett gOgl
glClear GL_COLOR_BUFFER_BIT
# Viewport command is not really needed, but has been inserted for
# Mac OSX. Presentation framework (Tk) does not send a reshape event,
# when switching from one demo to another.
glViewport 0 0 [$toglwin width] [$toglwin height]
for { set x 0 } { $x < $gSett(Width) } { incr x } {
glCallList [expr {$gOgl(DisplayListBase) + $x}]
}
$toglwin swapbuffers
}
proc InitPhoto {} {
global gSett
catch { image delete CANVAS }
image create photo CANVAS -width $gSett(Width) -height $gSett(Height)
}
proc InitCanvas {} {
global gSett gOpts
catch { destroy .fr.toglwin }
if { $gOpts(UseTcl3D) } {
togl .fr.toglwin -width $gSett(Width) -height $gSett(Height) \
-double true \
-createcommand CreateCallback \
-reshapecommand ReshapeCallback \
-displaycommand DisplayCallback
} else {
InitPhoto
label .fr.toglwin -image CANVAS -borderwidth 0
bind .fr.toglwin <Configure> "ReshapeCallback .fr.toglwin %w %h"
}
grid .fr.toglwin -row 0 -column 0 -sticky news
}
proc ResetCanvas {} {
InitCanvas
PrintGeneralInfo
}
# Cleanup procedure needed only, when this script is used from
# the presentation framework.
proc Cleanup {} {
StopChaos
}
proc ExitProg {} {
Cleanup
exit
}
proc CreateWindow {} {
global gSett gOpts
global gHaveTcl3D gVersion
frame .fr
pack .fr -expand 1 -fill both
InitCanvas
frame .fr.row1
frame .fr.row2
label .fr.info
grid .fr.toglwin -row 0 -column 0 -sticky news
grid .fr.row1 -row 1 -column 0 -sticky news
grid .fr.row2 -row 2 -column 0 -sticky news
grid .fr.info -row 3 -column 0 -sticky news
grid rowconfigure .fr 0 -weight 1
grid columnconfigure .fr 0 -weight 1
wm title . "Tcl3D demo: Simple Chaos Theory"
wm protocol . WM_DELETE_WINDOW "ExitProg"
bind . <Key-Escape> "ExitProg"
labelframe .fr.row1.fr1
pack .fr.row1.fr1 -side left -padx 1 -pady 1
foreach cmd [list "Revert" "ScanMode"] {
checkbutton .fr.row1.fr1.cb_$cmd -text $cmd -variable gOpts($cmd) \
-indicatoron 1
pack .fr.row1.fr1.cb_$cmd -side left
}
checkbutton .fr.row1.fr1.cb_UseTcl3D -text "Use Tcl3D" \
-variable gOpts(UseTcl3D) -indicatoron 1 -command ResetCanvas
pack .fr.row1.fr1.cb_UseTcl3D -side left
if { ! $gHaveTcl3D } {
set gOpts(UseTcl3D) false
.fr.row1.fr1.cb_UseTcl3D configure -state disabled
}
labelframe .fr.row1.fr2
pack .fr.row1.fr2 -side left -padx 1 -pady 1 -ipady 1
label .fr.row1.fr2.l_iter -text "Iterations:"
spinbox .fr.row1.fr2.s_iter -from 100 -to 7000 -increment 100 -width 4 \
-textvariable gOpts(Iterations)
pack .fr.row1.fr2.l_iter .fr.row1.fr2.s_iter -side left
foreach cmd [list "Red" "Green" "Blue"] {
label .fr.row1.fr2.l_$cmd -text "${cmd}:"
spinbox .fr.row1.fr2.s_$cmd -from 0 -to 255 -increment 1 -width 3 \
-textvariable gOpts($cmd)
pack .fr.row1.fr2.l_$cmd .fr.row1.fr2.s_$cmd -side left
}
button .fr.row2.b_Start -text "Start Chaos" -command StartChaos \
-relief groove
pack .fr.row2.b_Start -side left -padx 2
button .fr.row2.b_Stop -text "Stop Chaos" -command StopChaos \
-relief groove
pack .fr.row2.b_Stop -side left -padx 2
if { $gHaveTcl3D } {
set msg "Found Tcl3D version $gVersion"
} else {
set msg "No Tcl3D available, using photo image version"
}
label .fr.row2.l_TimeInfo -text $msg
pack .fr.row2.l_TimeInfo -side left -padx 2
}
CreateWindow
PrintGeneralInfo
if { [file tail [info script]] eq [file tail $::argv0] } {
# If started directly from tclsh or wish, then start animation.
update
StartChaos
}
|
