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}