Richard Suchenwirth - As another weekend fun project, here's flag signalling in Tcl/Tk (not the colorful kind, where each flag stands for a letter, but the moving type, where a signal mate holds two flags in different angles to represent letters). You see the mate in the bigger window, and can type in messages in the entry below, which he will signal when clicking on "Go" (or hit <Return>). Apart from the fun, this is an exercise in smooth rotation, to make the animation look more realistic (also note the mate's grin ;-). http://www.anbg.gov.au/flags/semaphore.html is an Australian spec of the system, officially called "Semaphore". "International Code of Signals", U.S. Pub 102 (NIMA), is at [L1 ].
proc flagman {} {
wm title . "Flag Signals"
set ::rangle 0; set ::langle 0
set c [canvas .c -width 250 -height 250 -bg steelblue3]
entry .e -textvar msg
set ::msg "Hello Tcl and Tk world"
bind .e <Return> {flagman'signal .c $msg}
focus .e
button .go -text Go -command {flagman'signal .c $msg} -pady 0
grid .c -
grid .e .go -sticky news
$c config -scrollregion {-125 -100 125 150}
$c create rect {-125 50 125 150} -fill grey -outline grey
$c create poly {-20 100 -5 100 0 50 5 100 20 100 20 -4 0 -10
-20 -4} -fill white
$c create oval {-10 -29 10 -5} -fill orange -outline orange
$c create line {-4 -20 -4 -17}
$c create line {4 -20 4 -17}
$c create arc -6 -24 6 -10 -start 220 -extent 120 -style arc -tag grin
$c create rect {-9 -29 9 -24} -fill white -outline white
$c create poly -25 45 -25 57 -15 57 -15 45 -smo 1 -fill orange -tag right
$c create poly {-25 0 -25 48 -15 48 -15 0 -20 -5} -fill grey95 -tag right
$c create poly {-21 50 -21 90 -19 90 -19 50} -fill brown -tag right
$c create poly {-21 88 -21 60 21 60 21 88} -fill blue -tag {right rflag}
$c create poly {-14 81 -14 67 12 67 12 81} -fill white -tag {right rflag}
$c create poly 25 45 25 57 15 57 15 45 -smooth 1 -fill orange -tag left
$c create poly {25 0 25 48 15 48 15 0 20 -5} -fill grey95 -tag left
$c create poly {21 50 21 90 19 90 19 50} -fill brown -tag left
$c create poly {21 88 21 60 -19 60 -19 88} -fill blue -tag {left lflag}
$c create poly {14 81 14 67 -12 67 -12 81} -fill white -tag {left lflag}
}
proc flagman'signal {w msg} {
global langle rangle
array set map {
A {1 0} B {2 0} C {3 0} D {4 0} E {0 3} F {0 2} G {0 1}
H {2 7} I {3 7} J {4 2} K {1 4} L {1 3} M {1 2} N {1 1}
O {3 6} P {2 4} Q {2 3} R {2 2} S {2 1} T {3 4} U {3 3}
V {4 1} W {6 3} X {7 3} Y {3 2} Z {7 2} " " {0 0}
}
regsub -all {[^A-Z ]} [string toupper $msg] "" msg
$w lower grin
foreach char [split "$msg " ""] {
wm title . $char
foreach {right left} $map($char) break
smooth'rotate $w right [expr {($right-$rangle)*45}] -20 0
set rangle $right
smooth'rotate $w left [expr {($left-$langle)*-45}] 20 0
set langle $left
after 1000
}
$w raise grin
wm title . "Flag Signals"
}
proc smooth'rotate {w tag angle x0 y0} {
if {abs($angle)>180} {
set angle [expr {(360-abs($angle))*-[sgn $angle]}]
} ;# select shortest path around the circle
if {[set n [expr {abs($angle)/5.}]]} {
set smoothangle [expr {$angle/$n}]
for {set i 0} {$i<$n} {incr i} {
rotate $w $tag $smoothangle $x0 $y0
flag'hang $w lflag rflag
update idletasks
}
}
}
proc flag'hang {w args} {
foreach tag $args {
$w raise $tag
set item [lindex [$w find withtag $tag] 0]
set c [$w coords $item]
set y1 [lindex $c 1]
set y2 [lindex $c end]
set xm [expr {([lindex $c 0]+[lindex $c 2])/2.}]
if {$y2<$y1} {
set ym [expr {([lindex $c 1]+[lindex $c 3])/2.}]
rotate $w $tag 180 $xm $ym
}
if {abs($xm-[lindex $c 0])<.01} {$w lower $tag}
}
}
proc sgn x {expr {$x>0? 1: $x<0? -1: 0}}
proc rotate {w tag angle x0 y0} {
foreach item [$w find withtag $tag] {
set diff [expr {$angle * atan(1)/45.}]
set points {}
foreach {x y} [$w coords $item] {
set rad [expr {hypot($x-$x0,$y-$y0)}]
set th [expr {atan2($y-$y0, $x-$x0)}]
set x [expr {$x0+cos($th+$diff)*$rad}]
set y [expr {$y0+sin($th+$diff)*$rad}]
lappend points $x $y
}
$w coords $item $points
}
}
#---------------------
flagman
bind . <Escape> {exec wish $argv0 &; exit}