[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.

[https://web.archive.org/web/20070208085840if_/http://www.xmission.com/~georgeps/images/wiki/SphereDemo-7.png]

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 $::argv
======

----
[Jeremy Miller] Wow. This is a really cool example of what can be done with tk.

<<categories>> Example  | Application