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 http://www.anbg.gov.au/flags/signal-flags.html .
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
}
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
}
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}
}
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}}
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}}
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}}
}
# 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 &\nSemaphore Flag System" \
-font {Times 24 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"
focus .e
.e icursor end
.e select range 0 end