package require Tk

array set arms {
    a {5 6} b {4 6} c {3 6} d {2 6} e {6 1} f {6 0} g {6 7} h {4 5} i {5 3}
    j {2 0} k {5 2} l {5 1} m {5 0} n {5 7} o {4 3} p {4 2} q {4 1} r {4 0}
    s {4 7} t {3 2} u {3 1} v {2 7} w {1 0} x {1 7} y {3 0} z {7 0}
    1 {5 6} 2 {4 6} 3 {3 6} 4 {2 6} 5 {6 1} 6 {6 0} 7 {6 7} 8 {4 5} 9 {5 3}
    alpha {2 0} numeric {2 1} 0 {5 2}
}
proc Semaphore {letter row col} {
    global arms
 
    set letter [string tolower $letter]
    if {! [info exists arms($letter)]} return   ;# Skip unknown chars
 
    set xy [Shift $row $col 40 80]
    .c create text $xy -text $letter -anchor c -tag lbl -font {Times 12 bold}
 
    # Make the body
    foreach {xx yy} [Shift $row $col 40 28] break
    set xy [list [expr {$xx-3}] [expr {$yy-3}] [expr {$xx+3}] [expr {$yy+3}]]
    
    .c create oval $xy -outline black -fill black 
    .c create line [Shift $row $col 40 36 40 46] -width 6
    .c create line [Shift $row $col 40 36 40 37] -width 6 -capstyle round
    .c create line [Shift $row $col 38 48 38 65] -width 2
    .c create line [Shift $row $col 41 48 41 65] -width 2
 
    # Make the arms with flags
    set x0 44 ; set y0 34                       ;# Right shoulder location
    set deg2rad [expr {4*atan(1)*2/360}]
    foreach {l r} $arms($letter) break
    foreach which {right left} arm [list $r $l] {
        set theta [expr {$arm * 45 * $deg2rad}]
        
        set xx [expr {$x0 + 12 * cos($theta)}]  ;# Hand location
        set yy [expr {$y0 - 12 * sin($theta)}]
        set x1 [expr {$x0 + 30 * cos($theta)}]  ;# End of flag staff
        set y1 [expr {$y0 - 30 * sin($theta)}]
        set x2 [expr {$x0 + 20 * cos($theta)}]  ;# Where flag starts on staff
        set y2 [expr {$y0 - 20 * sin($theta)}]
 
        set dx [expr {$x1 - $x2}]               ;# For computing normal to staff
        set dy [expr {$y1 - $y2}]
 
        # Some flags hang off the left, some hang off the right
        if {($arm == 1 || $arm == 0 || $arm == 7) ||
            ($which == "right" && ($arm == 2 || $arm == 6))} {
            set dx [expr {-$dx}]
            set dy [expr {-$dy}]
        }
        set x3 [expr {$x1 + $dy}]               ;# Top outer corner of flag
        set y3 [expr {$y1 - $dx}]
        set x4 [expr {$x2 + $dy}]               ;# Bottom outer corner
        set y4 [expr {$y2 - $dx}]
        .c create poly [Shift $row $col $x1 $y1 $x2 $y2 $x3 $y3] -fill red
        .c create poly [Shift $row $col $x2 $y2 $x3 $y3 $x4 $y4] -fill yellow
        .c create line [Shift $row $col $x0 $y0 $x1 $y1] -width 1
        .c create line [Shift $row $col $x0 $y0 $xx $yy] -width 3
        
        set x0 34                               ;# Left shoulder location
    }
}
# Shift - Shift coords over to a given row,col cell
proc Shift {row col args} {
    set drow 100
    set dcol 80
 
    set x0 [expr {$col * $dcol}]
    set y0 [expr {$row * $drow}]
    set result {}
    foreach {dx dy} $args {
        lappend result [expr {$x0 + $dx}] [expr {$y0 + $dy}]
    }
    return $result
}
# DoString -- shows a whole string as semaphore
proc DoString {str} {
    .c delete all
    set alpha 1                                 ;# In alpha by default
    
    set row [set col 0]                         ;# Initial position
    set max_col [expr {[winfo width .c] / 80}]  ;# Wrap column
    foreach letter [split $str {}] {
        if {[regexp {[0-9]} $letter]} {
            if {$alpha} {                       ;# Escape to numeric mode
                set alpha 0
                Semaphore "numeric" $row $col
                foreach {row col} [NextCell $row $col $max_col] break
            }
            Semaphore $letter $row $col
        } elseif {[regexp {[a-zA-Z]} $letter]} {
            if {! $alpha} {                     ;# Escape to alpha mode
                set alpha 1
                Semaphore "alpha" $row $col
                foreach {row col} [NextCell $row $col $max_col] break
            }
            Semaphore $letter $row $col
        }
        foreach {row col} [NextCell $row $col $max_col] break
    }
    .c config -scrollregion [.c bbox all]
}
proc NextCell {row col max_col} {
    if {[incr col] >= $max_col} {
        return [list [incr row] 0]
    }
    return [list $row $col]
}
proc Tracer {args} {
    DoString $::mytext
}
################################################################
################################################################
 
# Put up our gui
canvas .c -highlightthickness 0 -bd 2 -relief raised -width 500 -height 500
bind .c <2>          [bind Text <2>]         ;# Enable dragging w/ button 2
bind .c <B2-Motion>  [bind Text <B2-Motion>]
bind .c <Configure> Tracer
 
label .title -text "Semaphore Flag System" -font {Times 24 bold} -relief raised
label .lbl -text "Type text to see in semaphore"
entry .e -textvariable mytext
pack .title -side top -fill x
pack .e .lbl -side bottom -fill x
pack .c -side top -fill both -expand 1
update
 
trace variable mytext w Tracer
set mytext "tcl/tk"
focus .e
.e icursor end
.e select range 0 end