##-##################################################################
# 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 endHJG 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
