Semaphore Flag Signalling System

Keith Vetter 2002-11-4 - This was a quick, one-night programming session to write a short program that displays text using the semaphore flag signalling system. As you type in text, it also gets displayed with semaphore flags. For a good overview of the system see [1].

KPV I upgraded this to now also show Maritime Signal Flags.

RS: Nice! Not as "moving" as Flag signalling, but better to see the signals in context. How about scrolling when the rendered flag text reaches the bottom of the canvas?

KPV The upgraded version now automatically scrolls to the bottom whenever you type anything. Note, in both versions you can scroll by panning with button 2.

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

Arts and crafts of Tcl-Tk programming

Category Toys