Description edit
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 [1].Donald Porter reported flags were wrong, numbers not included, and the signal mate was too close up. Fixed in this version 0.2: you can zoom in and out with <Up> and <Down>, or left and right mouse click. Still missing: "chopchop" and double letters... (RS)
See also Semaphore flag signalling system which is not animated, but shows numerous signals (smaller) in context.
Changes edit
PYK 20121201: removed update, entering a new message will now interrupt the flagmanCode edit
package require Tk
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
bind .e <KeyPress> {
if {[info exists spelling]} {
after cancel $spelling
}
#bring the flagman's hands down
flagman'signal .c ""
}
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 {-1250 60 1250 1500} -fill grey -outline grey
$c create poly {-20 100 -5 100 0 50 5 100 20 100 25 -4 0 -10
-25 -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 210 -extent 125 -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 {-20 0 -25 0 -25 48 -15 48 -15 0} -fill grey95 \
-tag {right rarm}
$c create poly {-21 50 -21 90 -19 90 -19 50} -fill brown -tag right
$c create poly {-21 88 -21 60 7 60 7 88} -fill red -tag {right rflag}
$c create poly {-21 60 7 60 7 88} -fill yellow -tag {right rflag prflag}
$c create poly 25 45 25 57 15 57 15 45 -smooth 1 -fill orange -tag left
$c create poly {20 0 25 0 25 48 15 48 15 0} -fill grey95 \
-tag {left larm}
$c create poly {21 50 21 90 19 90 19 50} -fill brown -tag left
$c create poly {21 88 21 60 -7 60 -7 88} -fill red -tag {left lflag}
$c create poly {21 60 -7 60 -7 88} -fill yellow -tag {left lflag plflag}
bind . <Up> {.c scale all 0 0 1.25 1.25}
bind . <Down> {.c scale all 0 0 0.8 0.8}
bind .c <1> {.c scale all 0 0 1.25 1.25}
bind .c <3> {.c scale all 0 0 0.8 0.8}
}
proc spellit {w msg index} {
global langle rangle
variable map
variable spelling
if {$index < [string length $msg]} {
set char [string index $msg $index]
wm title . $char
foreach {right left} $map($char) break
foreach {xr yr} [$w coords rarm] break
smooth'rotate $w right [expr {($right-$rangle)*45}] $xr $yr
set rangle $right
foreach {xl yl} [$w coords larm] break
smooth'rotate $w left [expr {($left-$langle)*-45}] $xl $yl
set langle $left
update
set spelling [after 1000 [list spellit $w $msg [incr index]]]
} else {
$w raise grin
wm title . "Flag Signals"
}
}
proc flagman'signal {w msg} {
regsub -all {[^A-Z0-9 ]} [string toupper $msg] "" msg
regsub -all {[0-9]+} $msg {+\0-} msg
$w lower grin
spellit $w "$msg " 0
}
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
foreach {xr0 yr0 xr1 yr1} [$w coords $item] break
set pattern [$w coords p$tag]
foreach {xp0 yp0} $pattern break
if {$xr0==$xp0 && $yr0==$yp0} {
set pattern [lreplace $pattern 0 1 $xr1 $yr1]
} elseif {$xr1==$xp0 && $yr1==$yp0} {
set pattern [lreplace $pattern 0 1 $xr0 $yr0]
}
$w coords p$tag $pattern
}
if {abs($xm-[lindex $c 0])<.01} {$w lower $tag}
}
}
proc center {w item} {
foreach {x0 y0 x1 y1} [$w bbox $item] break
list [expr {($x0+$x1)/2.}] [expr {($y0+$y1)/2.}]
}
proc sgn x {expr {$x>0? 1: $x<0? -1: 0}}
proc rotate {w tag angle x0 y0} {
set diff [expr {$angle * atan(1)/45.}]
foreach item [$w find withtag $tag] {
set points {}
foreach {x y} [$w coords $item] {
set rad [expr {hypot($x-$x0,$y-$y0)}]
if {$rad} {
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
}
}
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}
+ {4 3} 0 {1 4} 1 {1 0} 2 {2 0} 3 {3 0} 4 {4 0}
5 {0 3} 6 {0 2} 7 {0 1} 8 {2 7} 9 {3 7} - {4 2}
}
#---------------------
flagman
bind . <Escape> {exec wish $argv0 &; exit}Where's the reverse, which takes images of a signal mate and translates them into a string? :) WJP
