[http://mini.net/files/maritime.jpg] 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 [bind Text ] bind .c Tracer bind all {.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 ---- [Arts and crafts of Tcl-Tk programming]