Updated 2011-12-26 21:40:48 by RLE

George Peter Staplin: Feb 5, 2005 - Several years ago I wrote a demo over a holiday with Tcl/Tk that I named SphereDemo. The screenshot below was generated entirely with the code below it.

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

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
}

proc randomlyVaryMark {win s e} {
set range [- \$e \$s]
set randSeed [expr {rand() * \$range}]
set m [toInt [+ \$randSeed \$s]]

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} {

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
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]