Updated 2012-12-06 00:11:40 by RLE

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 flagman

Code  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