You can also download the code here: http://www.xmission.com/~georgeps/implementation/software/demo/SphereDemo-7.tcl
#!/bin/wish8.4
#By George Peter Staplin
#Thanks to Arjen Markus for help using sqrt in the radar
proc + {n1 n2} {
expr {$n1 + $n2}
}
proc - {n1 n2} {
expr {$n1 - $n2}
}
proc * {n1 n2} {
expr {$n1 * $n2}
}
proc / {n1 n2} {
expr {$n1 / $n2}
}
proc toInt {n} {
expr int($n)
}
namespace eval ::radar {
proc drawCircle {win} {
$win.c delete circle
set width [winfo width $win.c]
set tWidth [- $width 10]
$win.c create arc $tWidth 0 0 $tWidth -outline green -start 90 -extent 90 -tags circle -style arc
$win.c create arc $tWidth 0 0 $tWidth -outline green -start 180 -extent 90 -tags circle -style arc
$win.c create arc $tWidth 0 0 $tWidth -outline green -start 270 -extent 90 -tags circle -style arc
$win.c create arc $tWidth 0 0 $tWidth -outline green -start 360 -extent 90 -tags circle -style arc
}
proc drawScanner {win deg} {
$win.c delete scanner
set theta [expr {$deg * atan2 (0,-1) / 180}]
set cosTheta [expr {cos($theta)}]
set sinTheta [expr {sin($theta)}]
set width [winfo width $win.c]
set tWidth [- $width 10]
set mid [/ $tWidth 2]
set x [* $mid $cosTheta]
set y [* $mid $sinTheta]
set x [+ $mid $x]
set y [- $mid $y]
$win.c create line $x $y $mid $mid -fill white -width 3 -tags scanner
incr deg -2
if {$deg < 0} {
set deg 360
}
after 40 [list radar::drawScanner $win $deg]
}
proc drawWaves {win count} {
$win.c delete wave
set width [winfo width $win.c]
set tWidth [- $width 10]
set mid [/ $tWidth 2]
$win.c create arc [- $mid $count] [- $mid $count] [+ $mid $count] [+ $mid $count] \
-outline purple -start 0 -extent 359 -tags wave -style chord -width 3
incr count 10
if {$count > $mid} {
set count 10
}
after 100 [list radar::drawWaves $win $count]
}
proc drawGrid {win} {
$win.c delete grid
set width [winfo width $win.c]
set tWidth [- $width 10]
set half [/ $tWidth 2]
set mod -$half
while 1 {
if {$mod > $half} {
break
}
set xy1 [expr {sqrt($half * $half - $mod * $mod)}]
set xy2 [expr {-$xy1}]
$win.c create line $xy1 $mod $xy2 $mod -fill darkgreen -tag grid
$win.c create line $mod $xy1 $mod $xy2 -fill darkgreen -tag grid
incr mod 9
}
if 0 {
foreach x {-100 -50 0 50 100} {
set y1 [expr {sqrt($half*$half-$x*$x)}]
set y2 [expr {-$y1}]
$win.c create line $x $y1 $x $y2 -fill green -tag B
}
foreach y {-100 -50 0 50 100} {
set x1 [expr {sqrt($half*$half-$y*$y)}]
set x2 [expr {-$x1}]
$win.c create line $x1 $y $x2 $y -fill green -tag B
}
}
$win.c move grid $half $half
}
proc create {win} {
frame $win -bg blue
pack [canvas $win.c -width 600 -height 600 -bg black] -fill both -expand 1
$win.c config -scrollregion {0 0 600 600}
$win.c xview moveto 0
$win.c yview moveto 0
radar::drawScanner $win 0
radar::drawWaves $win 10
bind $win.c <Configure> "[list radar::drawCircle $win] ; [list radar::drawGrid $win]"
return $win
}
}
namespace eval ::dockingClamp {
proc drawClamp {win} {
variable _priv$win
upvar 0 _priv$win ar
$win.c delete lclamp
$win.c delete rclamp
set height [winfo height $win.c]
set 3rdHeight [/ $height 3]
set width [winfo width $win.c]
set 4thWidth [/ $width 4]
set xOffset 5
#$win.c create line 20 10 20 $height -fill cyan -width 5 -tags clamp
set clampWidth 5
#|
$win.c create line $xOffset 1 $xOffset $3rdHeight \
-fill $ar(openedColor) -width $clampWidth -tags lclamp
#-
$win.c create line $xOffset $3rdHeight [+ $xOffset $4thWidth] $3rdHeight \
-fill $ar(openedColor) -width $clampWidth -tags lclamp
#-|
$win.c create line [+ $xOffset $4thWidth] $3rdHeight [+ $xOffset $4thWidth] [* $3rdHeight 2] \
-fill $ar(openedColor) -width $clampWidth -tags lclamp
#-
$win.c create line [+ $xOffset $4thWidth] [* $3rdHeight 2] $xOffset [* $3rdHeight 2] \
-fill $ar(openedColor) -width $clampWidth -tags lclamp
#|
$win.c create line $xOffset [* $3rdHeight 2] $xOffset $height \
-fill $ar(openedColor) -width $clampWidth -tags lclamp
#|
$win.c create line [- $width $xOffset] 1 [- $width $xOffset] $3rdHeight \
-fill $ar(openedColor) -width $clampWidth -tags rclamp
#-
$win.c create line [- $width $xOffset] $3rdHeight [- [- $width $xOffset] $4thWidth] $3rdHeight \
-fill $ar(openedColor) -width $clampWidth -tags rclamp
#|-
$win.c create line [- [- $width $xOffset] $4thWidth] $3rdHeight [- [- $width $xOffset] $4thWidth] [* $3rdHeight 2] \
-fill $ar(openedColor) -width $clampWidth -tags rclamp
#-
$win.c create line [- [- $width $xOffset] $4thWidth] [* $3rdHeight 2] [- $width $xOffset] [* $3rdHeight 2] \
-fill $ar(openedColor) -width $clampWidth -tags rclamp
#|
$win.c create line [- $width $xOffset] [* $3rdHeight 2] [- $width $xOffset] $height \
-fill $ar(openedColor) -width $clampWidth -tags rclamp
if {$ar(position)} {
set ar(status) Closing
closeClamp $win
}
}
proc closedClamp {win} {
variable _priv$win
upvar 0 _priv$win ar
set ar(status) Closed
$win.c itemconfigure insert -outline $ar(closedColor)
$win.c itemconfigure lclamp -fill $ar(closedColor)
$win.c itemconfigure rclamp -fill $ar(closedColor)
}
proc closeClamp {win} {
afterDoUntil 60 [list $win.c move lclamp 2 0] 25 0 {}
afterDoUntil 60 [list $win.c move rclamp -2 0] 25 0 [list dockingClamp::closedClamp $win]
}
proc openedClamp {win} {
variable _priv$win
upvar 0 _priv$win ar
set ar(status) Opened
$win.c itemconfigure insert -outline $ar(openedColor)
$win.c itemconfigure lclamp -fill $ar(openedColor)
$win.c itemconfigure rclamp -fill $ar(openedColor)
}
proc openClamp {win} {
afterDoUntil 60 [list $win.c move lclamp -2 0] 25 0 {}
afterDoUntil 60 [list $win.c move rclamp 2 0] 25 0 [list dockingClamp::openedClamp $win]
}
proc toggleClamp {win args} {
variable _priv$win
upvar 0 _priv$win ar
if {$ar(position)} {
set ar(status) Closing
closeClamp $win
return
}
set ar(status) Opening
openClamp $win
}
proc drawInsert {win} {
variable _priv$win
upvar 0 _priv$win ar
$win.c delete insert
set height [winfo height $win.c]
set 3rdHeight [/ $height 3]
set width [winfo width $win.c]
set halfWidth [/ $width 2]
set 4thWidth [/ $width 4]
set 6thWidth [/ $width 6]
set 8thWidth [/ $width 8]
set xyOffset 15
#top
$win.c create rectangle [+ $xyOffset $4thWidth] $xyOffset [- [- $width $4thWidth] $xyOffset] [- $3rdHeight $xyOffset] \
-outline $ar(openedColor) -width 5 -tags insert
#mid
$win.c create rectangle [- $halfWidth $xyOffset] [- $3rdHeight $xyOffset] [+ $halfWidth $xyOffset] [+ [* $3rdHeight 2] $xyOffset] \
-outline $ar(openedColor) -width 5 -tags insert
#bot
$win.c create rectangle [+ $xyOffset $4thWidth] [+ [* $3rdHeight 2] $xyOffset] [- [- $width $4thWidth] $xyOffset] [- $height $xyOffset] \
-outline $ar(openedColor) -width 5 -tags insert
}
proc create {win} {
frame $win -bg purple
variable _priv$win
upvar 0 _priv$win ar
set ar(position) 0
set ar(status) Open
set ar(openedColor) green
set ar(closedColor) orange
pack [label $win.title -text "Docking Clamp Control"] -side top -fill x
pack [frame $win.statusFrame] -side top -fill x
pack [label $win.statusFrame.l -text "Status: "] -side left
pack [label $win.statusFrame.stat -textvariable ::dockingClamp::_priv${win}(status)] -side left
pack [canvas $win.c -width 160 -height 300] -fill both -expand 1 -side top
trace variable ::dockingClamp::_priv${win}(position) w [list dockingClamp::toggleClamp $win]
bind $win.c <ButtonPress-1> [list toggle ::dockingClamp::_priv${win}(position)]
bind $win.c <Configure> "[list drawGradient $win.c y #7a84d6 black] ; \
[list dockingClamp::drawClamp $win] ; [list dockingClamp::drawInsert $win]"
return $win
}
}
namespace eval ::gradientScale {
proc drawText {win} {
variable _priv$win
upvar 0 _priv$win ar
set height [winfo height $win.c]
set numListLen [llength $ar(numList)]
set ratio [/ $height $numListLen]
set size 20
set aFont [font create]
font configure $aFont -size $size -family lucidatypewriter
while 1 {
array set fntInfo [font metrics $aFont]
if {$fntInfo(-linespace) <= $ratio} {
break
}
incr size -1
if {$size < 1} {
#The window is too small for any font
return
}
font configure $aFont -size $size
}
set y [- $height [/ $fntInfo(-linespace) 2]]
set numIndex 0
while 1 {
if {$numIndex > $numListLen} {
break
}
set num [lindex $ar(numList) $numIndex]
set numWidth [font measure $aFont -displayof $win.c $num]
set x [+ [/ $numWidth 2] 2]
$win.c create text $x $y -text $num -fill white -font $aFont
incr y -$fntInfo(-linespace)
incr numIndex
}
}
proc drawMarker {win} {
$win.c delete marker
variable _priv$win
upvar 0 _priv$win ar
set width [winfo width $win.c]
set height [winfo height $win.c]
set ratio [/ $height 100]
set newY [- $height [* $ratio $ar(marker)]]
$win.c create rectangle 0 $newY $width [+ $newY $ar(markerHeight)] -tags marker -fill $ar(markerColor)
}
proc setMark {win m} {
variable _priv$win
upvar 0 _priv$win ar
set ar(marker) $m
gradientScale::drawMarker $win
}
proc randomlyVaryMark {win s e} {
set range [- $e $s]
set randSeed [expr {rand() * $range}]
set m [toInt [+ $randSeed $s]]
gradientScale::setMark $win $m
after 30 [list gradientScale::randomlyVaryMark $win $s $e]
}
proc create {win col1Str col2Str numList} {
frame $win
variable _priv$win
upvar 0 _priv$win ar
set ar(numList) $numList
set ar(marker) 45
set ar(markerColor) black
set ar(markerHeight) 10
pack [canvas $win.c -width 100] -fill both -expand 1
bind $win.c <Configure> "[list drawGradient $win.c y $col1Str $col2Str] ;
[list gradientScale::drawText $win] ; [list gradientScale::drawMarker $win]"
return $win
}
}
namespace eval ::reactor {
proc drawHousing {win} {
$win.c delete housing
variable _priv$win
upvar 0 _priv$win ar
set width [winfo width $win.c]
set height [winfo height $win.c]
set 8thWidth [/ $width 8]
set 8thHeight [/ $height 8]
$win.c create polygon $8thWidth $8thHeight [* $8thWidth 6] $8thHeight \
[* $8thWidth 6] [* $8thHeight 6] $8thWidth [* $8thHeight 6] -outline $ar(housingColor) -smooth 1 -tags housing
$win.c create rectangle 1 [* $8thHeight 3] $width [* $8thHeight 4] -outline $ar(housingColor) -tags housing
}
proc moveArrow {win id} {
set width [winfo width $win]
set res [$win.c coords $id]
if {$res == ""} {
return
}
foreach {x1 y1 x2 y2} $res break
if {$x2 > $width} {
$win.c move $id [+ -$x1 10] 0
} else {
$win.c move $id 10 0
}
after 40 [list reactor::moveArrow $win $id]
}
proc drawArrow {win x y} {
variable _priv$win
upvar 0 _priv$win ar
set id [$win.c create line $x $y [+ $x 10] $y -arrow last -width 20 -fill $ar(flowColor) -tags flow]
after 40 [list reactor::moveArrow $win $id]
}
proc drawFlow {win} {
$win.c delete flow
set width [winfo width $win.c]
set height [winfo height $win.c]
set 8thWidth [/ $width 8]
set 8thHeight [/ $height 8]
set y [toInt [* $8thHeight 3.5]]
for {set x 30} {$x < $width} {incr x 30} {
drawArrow $win $x $y
}
}
proc pulseNode {win n} {
variable _priv$win
upvar 0 _priv$win ar
$win.c itemconfigure $ar([set ar(lastId)]) -fill $ar(pulseOffColor)
if {$n > 3} {
set n 1
}
$win.c itemconfigure $ar(id$n) -fill $ar(pulseOnColor)
set ar(lastId) id$n
incr n
after 160 [list reactor::pulseNode $win $n]
}
proc drawPulses {win} {
variable _priv$win
upvar 0 _priv$win ar
$win.c delete pulses
set width [winfo width $win.c]
set height [winfo height $win.c]
set 8thWidth [/ $width 8]
set 8thHeight [/ $height 8]
set ar(id1) [$win.c create polygon 0 0 20 0 10 20 -fill $ar(pulseOffColor) -tags pulses]
set ar(id2) [$win.c create polygon 0 0 20 0 10 20 -fill $ar(pulseOffColor) -tags pulses]
set ar(id3) [$win.c create polygon 0 0 20 0 10 20 -fill $ar(pulseOffColor) -tags pulses]
set ar(lastId) id1
$win.c move $ar(id1) [* $8thWidth 2] [* $8thHeight 2]
$win.c move $ar(id2) [* $8thWidth 4] [* $8thHeight 2]
$win.c move $ar(id3) [* $8thWidth 3] [* $8thHeight 5]
pulseNode $win 1
}
proc create {win} {
frame $win
variable _priv$win
upvar 0 _priv$win ar
set ar(housingColor) cyan
set ar(flowColor) green
set ar(pulseOnColor) white
set ar(pulseOffColor) red
pack [canvas $win.c -width 300 -height 100] -fill both -expand 1
bind $win.c <Configure> "[list drawGradient $win.c y darkblue royalblue] ; \
[list reactor::drawHousing $win] ; [list reactor::drawFlow $win] ; [list reactor::drawPulses $win]"
}
}
proc afterDoUntil {delay cmd limit count finalCmd} {
if {$count >= $limit} {
namespace eval :: $finalCmd
return
}
namespace eval :: $cmd
incr count
after $delay [list afterDoUntil $delay $cmd $limit $count $finalCmd]
}
proc toggle {varName} {
set $varName [expr ! [set $varName]]
}
proc randomlyVaryPressure {win s e} {
set range [- $e $s]
set randSeed [expr {rand() * $range}]
set p [toInt [+ $randSeed $s]]
pressureGauge::setPressure $win $p
after 40 randomlyVaryPressure $win $s $e
}
proc drawGradient {win type col1Str col2Str} {
$win delete gradient
set width [winfo width $win]
set height [winfo height $win]
foreach {r1 g1 b1} [winfo rgb $win $col1Str] break
foreach {r2 g2 b2} [winfo rgb $win $col2Str] break
set rRange [- $r2.0 $r1]
set gRange [- $g2.0 $g1]
set bRange [- $b2.0 $b1]
if {$type == "x"} {
set rRatio [/ $rRange $width]
set gRatio [/ $gRange $width]
set bRatio [/ $bRange $width]
for {set x 0} {$x < $width} {incr x} {
set nR [toInt [+ $r1 [* $rRatio $x]]]
set nG [toInt [+ $g1 [* $gRatio $x]]]
set nB [toInt [+ $b1 [* $bRatio $x]]]
set col [format {%4.4x} $nR]
append col [format {%4.4x} $nG]
append col [format {%4.4x} $nB]
$win create line $x 0 $x $height -tags gradient -fill #${col}
}
} else {
set rRatio [/ $rRange $height]
set gRatio [/ $gRange $height]
set bRatio [/ $bRange $height]
for {set y 0} {$y < $height} {incr y} {
set nR [toInt [+ $r1 [* $rRatio $y]]]
set nG [toInt [+ $g1 [* $gRatio $y]]]
set nB [toInt [+ $b1 [* $bRatio $y]]]
set col [format {%4.4x} $nR]
append col [format {%4.4x} $nG]
append col [format {%4.4x} $nB]
$win create line 0 $y $width $y -tags gradient -fill #${col}
}
}
return $win
}
proc main {argc argv} {
option add *background black
option add *foreground white
option add *Label.background black
option add *Label.foreground white
option add *font {Lucidatypewriter 20}
. config -bg black
label .l -text "Ion Engine"
label .l2 -text "Atomic Reactor"
grid .l .l2
frame .g
pack [frame .g.ml -relief ridge -bd 2] -side left -expand 1
pack [label .g.ml.l -text "Main Line Voltage" -font 14] -side top
pack [gradientScale::create .g.ml.p purple black [list 450 500 550 600 650 600 700 750 850 900 1,000]] -side bottom -fill x -padx 5
gradientScale::randomlyVaryMark .g.ml.p 45 55
pack [frame .g.se -relief ridge -bd 2] -side left -expand 1
pack [label .g.se.l -text "Static Electricity" -font 14] -side top
pack [gradientScale::create .g.se.p blue black [list 3,000 4,000 5,000 6,000 7,000 8,500 9,000 10,000 11,000 12,000]] -side bottom -fill x -padx 5
gradientScale::randomlyVaryMark .g.se.p 30 75
pack [frame .g.tf -relief ridge -bd 2] -side left -expand 1
pack [label .g.tf.l -text Thrust -font 14] -side top
pack [gradientScale::create .g.tf.gs red black [list 20,000 30,000 40,000 50,000 60,000 65,000 70,000 75,000 80,000]] -side bottom -fill both
gradientScale::randomlyVaryMark .g.tf.gs 45 56
reactor::create .reactor
radar::create .radar
dockingClamp::create .c
grid .g .reactor -sticky news
grid .c .radar -sticky news
grid rowconfigure . 0 -weight 1
grid rowconfigure . 1 -weight 1
grid columnconfigure . 0 -weight 1
grid columnconfigure . 1 -weight 1
#grid [canvas .grad -bg blue -width 300 -height 200]
#bind .grad <Configure> [list drawGradient .grad x red royalblue]
}
main $::argc $::argvJeremy Miller Wow. This is a really cool example of what can be done with tk.
