Updated 2007-07-03 13:54:23 by LV

Keith Vetter 2002-11-5 - Early last evening I wrote Semaphore Flag Signalling System, then instead of going to bed, I stayed up a few more hours and added signal flags to it. So, in this version you can display text in either semaphore or signal flags. Note, I based the flags on [1].
 ##-##################################################################
 # Marine Signal Flags & Semaphore Flag System
 #
 # 2002-11-05 Keith Vetter
 # 2005-06-10 HJG: Numeric Flags + some extra Chars (Answer...)
 #####################################################################

 package require Tk

 proc Flags {letter row col} {
    global flags

    set letter [string tolower $letter]
    if {! [info exists flags($letter)]} return  ;# Skip unknown chars

    foreach part $flags($letter) {
        foreach {type color width} $part break
        set xy [lrange $part 2 end]
        if {$type == "line"} {set xy [lrange $part 3 end] } {set width 0}
        set xy2 [ScaleShift $row $col $xy]
        .c create $type $xy2 -fill $color -width $width -tag $type
    }
   set xy [Shift $row $col 40 80]
    .c create text $xy -text $letter -anchor c -tag lbl -font {Times 12 bold}
 }

 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
 }
 # Scales a unit figure into a given row,col cell
 proc ScaleShift {row col xy} {
    set drow 100
    set dcol  80
    set sx    50                                   ;# Scale factor in x
    set sy    40

    set x0 [expr {($col + .5) * $dcol}]
    set y0 [expr {($row + .5) * $drow}]
    set result {}
    foreach {dx dy} $xy {
        lappend result [expr {$x0 + $sx*($dx-.5)}] [expr {$y0 + $sy*($dy-.5)}]
    }
    return $result
 }
 # DoString -- shows a whole string as semaphore
 proc DoString {str} {
    global type
    .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 {$type == "flags"} {
            Flags $letter $row $col
        } elseif {[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
        } else {
            Semaphore $letter $row $col         ;# Extra Chars
        }
        foreach {row col} [NextCell $row $col $max_col] break
    }
    .c config -scrollregion [.c bbox all]
    .c yview moveto 1
 }
 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
 }
 # Extra chars: "!":Answer, "/":Annuler, "%":Error, "_":Break, "@","#": Test: Alpha,Numeric
 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}
    @     {2 0} #       {2 1} / {3 7}
 }
 array set flags {
    a {{rect white  0 0 .5 1}
       {poly blue   .5 0 1 0 .8 .5 1 1 .5 1}}
    b {{poly red    0 0 1 0 .8 .5 1 1 0 1}}
    c {{rect blue   0 0 1 .2}
       {rect white  0 .2 1 .4}
       {rect red    0 .4 1 .6}
       {rect white  0 .6 1 .8}
       {rect blue   0 .8 1 1}}
    d {{rect yellow 0 0 1 .2}
       {rect blue   0 .2 1 .8}
       {rect yellow 0 .8 1 1}}
    e {{rect blue   0 0 1 .5}
       {rect red    0 .5 1 1}}
    f {{rect white  0 0 1 1}
       {poly red    .5 0 1 .5 .5 1 0 .5}}
    g {{rect blue   0 0 1 1}
       {rect yellow 0 0 .1667 1}
       {rect yellow .333 0 .5 1}
       {rect yellow .667 0 .8333 1}}
    h {{rect white  0 0 .5 1}
       {rect red    .5 0 1 1}}
    i {{rect yellow 0 0 1 1}
       {oval black  .3 .25 .7 .75}}
    j {{rect blue   0 0 1 1}
       {rect white  0 .333 1 .666}}
    k {{rect yellow 0 0 .5 1}
       {rect blue   .5 0 1 1}}
    l {{rect black  0 0 1 1}
       {rect yellow 0 0 .5 .5}
       {rect yellow .5 .5 1 1}}
    m {{rect blue   0 0 1 1}
       {poly white  0 0 .075 0 1 .925 1 1 .925 1 0 .075}
       {poly white  .925 0 1 0 1 .075 .075 1 0 1 0 .925}}
    n {{rect blue   0 0 1 1}
       {rect white  .25 0 .5 .25}
       {rect white  .75 0 1 .25}
       {rect white   0 .25 .25 .5}
       {rect white  .5 .25 .75 .5}
       {rect white  .25 .5 .5 .75}
       {rect white  .75 .5 1 .75}
       {rect white   0 .75 .25 1}
       {rect white  .5 .75 .75 1}}
    o {{poly red     0 0 1 0 1 1}
       {poly yellow  0 0 1 1 0 1}}
    p {{rect blue    0 0 1 1}
       {rect white   .25 .333 .71 .6667}}
    q {{rect yellow  0 0 1 1}}
   _R {{rect red     0 0 1 1}
       {line yellow  6 .5 0 .5 1}
       {line yellow  6 0 .5 1 .5}}
    r {{rect yellow  0.00 0.0   1.00 1.00}
       {rect red     0.00 0.0   0.39 0.39}
       {rect red     0.00 0.61  0.39 1.00}
       {rect red     0.61 0.0   1.00 0.39}
       {rect red     0.61 0.61  1.00 1.00}}
    s {{rect white   0 0 1 1}
       {rect blue    .25 .333 .71 .6667}}
    t {{rect red     0 0 .33 1}
       {rect white   .33 0 .66 1}
       {rect blue    .66 0 1 1}}
    u {{rect white   0 0 1 1}
       {rect red     0 0 .5 .5}
       {rect red     .5 .5 1 1}}
    v {{rect white   0 0 1 1}
       {poly red     0 0 .075 0 1 .925 1 1 .925 1 0 .075}
       {poly red     .925 0 1 0 1 .075 .075 1 0 1 0 .925}}
    w {{rect blue    0 0 1 1}
       {rect white   .175 .2 .825 .8}
       {rect red     .275 .3 .725 .7}}
   _X {{rect white   0 0 1 1}
       {line blue 12 .5 0 .5 1}
       {line blue 12 0 .5 1 .5}}
    x {{rect blue    0.00 0.0   1.00 1.00}
       {rect white   0.00 0.0   0.34 0.34}
       {rect white   0.66 0.0   1.00 0.34}
       {rect white   0.00 0.66  0.34 1.00}
       {rect white   0.66 0.66  1.00 1.00}}
    y {{rect yellow  0 0 1 1}
       {poly red     .1 0 .3 0 0 .375 0 .125}
       {poly red     .5 0 .7 0 0 .875 0 .625}
       {poly red     .9 0 1 0 1 .125 .3 1 .1 1}
       {poly red     1 .375 1 .625 .7 1 .5 1}
       {poly red     1 .875 1 1 .9 1}}
    z {{poly black   0 0 .5 .5 0 1}
       {poly yellow  0 0 .5 .5 1 0}
       {poly blue    1 0 .5 .5 1 1}
       {poly red     0 1 .5 .5 1 1}}
    1 {{poly white   0.0 0.10  1.5 0.30  1.5 0.70  0.0 0.90}
       {oval red     0.2 0.32  0.5 0.68}}
    2 {{poly blue    0.0 0.10  1.5 0.30  1.5 0.70  0.0 0.90}
       {oval white   0.2 0.32  0.5 0.68}}
    3 {{poly red     0.0 0.1   0.5 0.20  0.5 0.80  0.0 0.90}
       {poly white   0.5 0.20  1.0 0.30  1.0 0.70  0.5 0.80}
       {poly blue    1.0 0.30  1.5 0.40  1.5 0.60  1.0 0.70}}
    4 {{poly red     0.0 0.10  1.5 0.30  1.5 0.70  0.0 0.90}
       {line white 4 0.7 0.20  0.7 0.80}
       {line white 4 0.0 0.50  1.5 0.5}}
    5 {{poly yellow  0.0 0.10  0.7 0.20  0.7 0.80  0.0 0.90}
       {poly blue    0.7 0.20  1.5 0.30  1.5 0.70  0.7 0.80}}
    6 {{poly black   0.0 0.10  1.5 0.30  1.5 0.50  0.0 0.50}
       {poly white   0.0 0.50  1.5 0.50  1.5 0.70  0.0 0.90}}
    7 {{poly yellow  0.0 0.10  1.5 0.30  1.5 0.50  0.0 0.50}
       {poly red     0.0 0.50  1.5 0.50  1.5 0.70  0.0 0.90}}
    8 {{poly white   0.0 0.10  1.5 0.30  1.5 0.70  0.0 0.90}
       {line red   4 0.7 0.20  0.7 0.80}
       {line red   4 0.0 0.50  1.5 0.50}}
    9 {{poly white   0.0 0.10  0.70 0.20  0.70 0.80  0.00 0.90}
       {poly black   0.7 0.20  1.50 0.30  1.50 0.70  0.70 0.80}
       {poly red     0.0 0.50  0.70 0.50  0.70 0.80  0.00 0.90}
       {poly yellow  0.7 0.50  1.50 0.50  1.50 0.70  0.70 0.80}}
    0 {{poly yellow  0.0 0.10  0.5 0.20   0.50 0.80  0.00 0.90}
       {poly red     0.5 0.20  1.0 0.30   1.00 0.70  0.50 0.80}
       {poly yellow  1.0 0.30  1.5 0.40   1.50 0.60  1.00 0.70}}
    ! {{poly red     0.00 0.10  1.50 0.40  1.50 0.60  0.00 0.90}
       {poly white   0.25 0.13  0.50 0.21  0.50 0.79  0.25 0.87}
       {poly white   0.75 0.23  1.00 0.31  1.00 0.69  0.75 0.77}}
 }
 # http://www.anbg.gov.au/flags/signal-flags.html

 ################################################################

 # Put up our gui:
  set type flags
  canvas      .c     -highlightthickness 0 -bd 2 -relief raised -width 500 -height 500 \
                     -yscrollcommand {.sb set}
  scrollbar   .sb    -orient vertical -command {.c yview}
  label       .title -text "Marine Signal Flags & Semaphore Flag System" \
                     -font {Times 18 bold} -relief raised
  frame       .f
  label       .lbl   -text "Type text to see in signal flags or semaphore"
  radiobutton .flag  -text "Signal Flags" -variable type -value flags \
                     -relief raised -command Tracer
  radiobutton .sema  -text "Semaphores" -variable type -value sema \
                     -relief raised -command Tracer
  entry       .e     -textvariable mytext

  pack .title -side top    -fill x
  pack .e .f  -side bottom -fill x
  pack .sema .flag -in .f -side right
  pack .lbl -in .f -side left
  pack .sb         -side right -fill y
  pack .c          -side top   -fill both -expand 1

  bind .c <2>           [bind Text <2>]         ;# Enable dragging w/ button 2
  bind .c <B2-Motion>   [bind Text <B2-Motion>]
  bind .c <Configure>   Tracer
  bind all <MouseWheel> {.c yview scroll [expr {-%D/120}] units}

  update

  trace variable mytext w Tracer
 #set mytext "abcdefghijklmnopqrstuvwxyz"
  set mytext "abcdefghijklmnopqrstuvwxyz%!/?12345?67890_"

  focus .e
  .e icursor end
  .e select range 0 end

HJG Added numeric flags, answer-flag, and a few extra chars (e.g. "Annuler", "Error"). Also alternate design for the flags R and X (line-endpoints got over the edge of these flags).

Arts and crafts of Tcl-Tk programming Category Toys