9 puts stderr "where-vessels: bad usage: $m"
16 if {$ai >= [llength $argv]} {
17 badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
19 set v [lindex $argv $ai]
24 while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
26 switch -exact -- $arg {
28 --pirate { set pirate [string totitle [nextarg]] }
29 --ocean { set ocean [string totitle [nextarg]] }
30 --clipboard-file { set clipboard_file [nextarg] }
31 --notes { set notes_loc [nextarg] }
32 default { badusage "unknown option $arg" }
35 set argv [lrange $argv $ai end]
36 if {[llength $argv]} { badusage "non-option args not allowed" }
38 set itemre { (\w+) = ([^=]*) }
39 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
42 set vn [open vessel-notes]
43 while {[gets $vn l] >= 0} {
44 regsub -all {\t+} $l "\t" l
45 manyset [split $l "\t"] vname vid owner note
48 set notes($nk) [list $owner $note]
55 switch -exact $vi(vesselClass) {
56 smsloop { set sz 00sl }
57 lgsloop { set sz 01ct }
59 longship { set sz 03ls }
60 baghlah { set sz 04bg }
61 merchbrig { set sz 05mb }
62 warbrig { set sz 06wb }
64 warfrig { set sz 08wf }
65 merchgal { set sz 09mg }
66 grandfrig { set sz 10gf }
67 default { error "$vi(vesselClass) ?" }
70 switch -exact $vi(vesselSubclass) {
72 icy { append abbrev F }
73 default { error "$vi(vesselSubclass) ?" }
75 switch -exact $vi(isLocked)/$vi(isBattleReady) {
76 true/false { append abbrev 2- }
77 false/false { append abbrev 1+ }
78 false/true { append abbrev 0* }
79 default { error "$vi(isLocked)/$vi(isBattleReady) ?" }
81 switch -exact $vi(inPort) {
83 false { append abbrev ? }
84 default { error "$vi(inPort) ?" }
86 set nk $vi(vesselId).$vi(vesselName)
87 upvar #0 notes($nk) note
88 if {[info exists note]} {
89 manyset $note owner xabbrev
90 if {![string compare $owner $pirate]} {
95 append abbrev $xabbrev
100 set kk "$vi(islandName) $abbrev"
101 upvar #0 count($kk) k
102 if {![info exists k]} { set k 0 }
106 set cl [open clipboard]
107 while {[gets $cl l] >= 0} {
111 if {![regexp -expanded $manyitemre $l dummy \
112 thiskey thisval rhs]} { error "$l ?" }
113 # puts "KEY $thiskey VAL $thisval"
114 set vi($thiskey) $thisval
115 if {![string length $rhs]} break
116 regsub {^, } $rhs {} rhs
123 set chart [exec perl -we {
128 yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
129 sub { sprintf "%d %d", @_; },
130 sub { printf "archlabel %d %d %s\n", @_; },
131 sub { printf "island %s %s\n", @_; },
132 sub { printf "league %s %s %s.\n", @_; },
133 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
135 STDOUT->error and die $!;
138 frame .f -border 1 -relief groove
141 #$canvas configure -width 1000 -height 800
142 pack $canvas -expand 1 -fill both
143 pack .f -expand 1 -fill both -side left
149 return [expr {$c * $scale}]
152 proc chart-got/archlabel {args} { }
153 proc chart-got/island {x y args} {
154 # puts "ISLE $x $y $args"
155 global canvas isleloc
156 set isleloc($args) [list $x $y]
158 # $canvas create oval \
159 # [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
160 # [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
162 $canvas create text [coord $x] [coord $y] \
163 -text $args -anchor s
165 proc chart-got/league {x1 y1 x2 y2 kind} {
166 # puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
168 set l [$canvas create line \
169 [coord $x1] [coord $y1] \
170 [coord $x2] [coord $y2]]
171 if {![string compare $kind .]} {
172 $canvas itemconfigure $l -dash .
177 global chart count isleloc canvas
179 foreach l [split $chart "\n"] {
180 # puts "CHART-GOT $l"
181 set proc [lindex $l 0]
182 eval chart-got/$proc [lrange $l 1 end]
185 set lastislandname {}
186 foreach key [lsort [array names count]] {
188 # puts "SHOWING $key $c"
189 regexp {^(.*) (\S+)$} $key dummy islandname abbrev
190 if {[string compare $lastislandname $islandname]} {
191 manyset $isleloc($islandname) x y
194 set lastislandname $islandname
198 regsub -all {[0-9]} $text {} text
200 set text [format "%2d%s" $c $text]
202 set text [format " %s" $text]
204 set id [$canvas create text $x $y \
205 -anchor nw -font fixed \
207 set bbox [$canvas bbox $id]
208 set bid [eval $canvas create rectangle $bbox -fill white]
209 $canvas lower $bid $id
210 manyset $bbox dummy dummy dummy y
217 foreach nk [lsort [array names $note]] {
218 puts "IGNORED NOTE $nk"
222 pack .ctrl -side right
224 panner::canvas-scroll-bbox .f.c
225 panner::create .ctrl.pan .f.c 120 120
227 pack .ctrl.pan -side top -pady 10 -padx 5
229 pack .ctrl.zoom -side top
233 set nscale [expr "\$scale $extail"]
234 puts "ZOOM $scale $nscale"
235 if {$nscale < 1 || $nscale > 200} return
239 panner::updatecanvas-bbox .ctrl.pan
242 button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
243 button .ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2}
244 pack .ctrl.zoom.out .ctrl.zoom.in -side left
246 #. configure -width 640 -height 480
247 wm geometry . 1024x480
249 #puts "[$canvas bbox all]"