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 endArts and crafts of Tcl-Tk programming Category Toys