10 if {$debug} { puts "DEBUG $m" }
14 puts stderr "where-vessels: bad usage: $m"
20 if {$ai >= [llength $argv]} {
21 badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
23 set v [lindex $argv $ai]
33 set notes_loc vessel-notes
34 set scraper {./yppedia-ocean-scraper --chart}
41 while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
43 switch -exact -- $arg {
45 --pirate { glset pirate [string totitle [nextarg]] }
46 --ocean { glset ocean [string totitle [nextarg]] }
47 --clipboard-file { load-clipboard-file [nextarg] }
48 --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
49 --notes { glset notes_loc [nextarg] }
50 --debug { incr debug }
51 default { badusage "unknown option $arg" }
54 set argv [lrange $argv $ai end]
55 if {[llength $argv]} { badusage "non-option args not allowed" }
59 global ocean notes_loc pirate scraper
60 if {![info exists ocean] || ![info exists pirate]} {
61 set cmd {./yarrg --find-window-only --quiet}
62 if {[info exists ocean]} { lappend cmd --ocean $ocean }
63 if {[info exists pirate]} { lappend cmd --pirate $pirate }
64 manyset [split [eval exec $cmd] " "] ocean pirate
66 lappend scraper $ocean
70 global notes_loc notes
72 if {[regexp {^\w+\:} $notes_loc]} {
74 debug "FETCHING NOTES"
75 ::http::geturl $notes_loc
76 switch -glob [::http::status].[::http::ncode] {
78 ok.* { error "retrieving vessel-notes $url: [::http::code]" }
79 * { error "retrieving vessel-notes $url: [::http::error]" }
81 set notes_data [::http::data]
84 set vn [open $notes_loc]
85 set notes_data [read $vn]
88 foreach l [split $notes_data "\n"] {
89 regsub -all {\t+} $l "\t" l
90 manyset [split $l "\t"] vname vid owner note
93 set notes($nk) [list $owner $note]
99 global pirate notes_used
101 switch -exact $vi(vesselClass) {
102 smsloop { set sz 00sl }
103 lgsloop { set sz 01ct }
105 longship { set sz 03ls }
106 baghlah { set sz 04bg }
107 merchbrig { set sz 05mb }
108 warbrig { set sz 06wb }
109 xebec { set sz 07xe }
110 warfrig { set sz 08wf }
111 merchgal { set sz 09mg }
112 grandfrig { set sz 10gf }
113 default { error "$vi(vesselClass) ?" }
116 switch -exact $vi(vesselSubclass) {
118 icy { append abbrev F }
119 default { error "$vi(vesselSubclass) ?" }
121 switch -exact $vi(isLocked)/$vi(isBattleReady) {
122 true/false { append abbrev 2- }
123 false/false { append abbrev 1+ }
124 false/true { append abbrev 0* }
125 default { error "$vi(isLocked)/$vi(isBattleReady) ?" }
127 switch -exact $vi(inPort) {
129 false { append abbrev ? }
130 default { error "$vi(inPort) ?" }
132 set nk $vi(vesselId).$vi(vesselName)
133 upvar #0 notes($nk) note
134 if {[info exists note]} {
135 manyset $note owner xabbrev
136 if {![string compare $owner $pirate]} {
141 append abbrev $xabbrev
142 set notes_used($nk) 1
146 set kk "$vi(islandName) $abbrev"
147 upvar #0 count($kk) k
148 if {![info exists k]} { set k 0 }
153 proc parse-clipboard {} {
154 global clipboard count notes notes_used
156 catch { unset count }
157 catch { unset notes_used }
159 set itemre { (\w+) = ([^=]*) }
160 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
163 foreach l [split $clipboard "\n"] {
164 if {![string length $l]} continue
167 if {![regexp -expanded $manyitemre $l dummy \
168 thiskey thisval rhs]} { error "$l ?" }
169 set vi($thiskey) $thisval
170 if {![string length $rhs]} break
171 regsub {^, } $rhs {} rhs
177 foreach nk [lsort [array names notes]] {
178 if {![info exists notes_used($nk)]} {
179 debug "IGNORED NOTE $nk"
184 proc load-clipboard-file {fn} {
186 glset clipboard [read $f]
192 debug "FETCHING CHART"
193 set chart [eval exec $scraper [list | perl -we {
198 yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
199 sub { sprintf "%d %d", @_; },
200 sub { printf "archlabel %d %d %s\n", @_; },
201 sub { printf "island %s %s\n", @_; },
202 sub { printf "league %s %s %s.\n", @_; },
203 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
205 STDOUT->error and die $!;
214 return [expr {$c * $scale}]
217 proc chart-got/archlabel {args} { }
218 proc chart-got/island {x y args} {
219 # debug "ISLE $x $y $args"
220 global canvas isleloc
221 set isleloc($args) [list $x $y]
223 # $canvas create oval \
224 # [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
225 # [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
227 $canvas create text [coord $x] [coord $y] \
228 -text $args -anchor s
230 proc chart-got/league {x1 y1 x2 y2 kind} {
231 # debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
233 set l [$canvas create line \
234 [coord $x1] [coord $y1] \
235 [coord $x2] [coord $y2]]
236 if {![string compare $kind .]} {
237 $canvas itemconfigure $l -dash .
242 global chart count isleloc canvas
244 foreach l [split $chart "\n"] {
245 # debug "CHART-GOT $l"
246 set proc [lindex $l 0]
247 eval chart-got/$proc [lrange $l 1 end]
250 set lastislandname {}
251 foreach key [lsort [array names count]] {
253 # debug "SHOWING $key $c"
254 regexp {^(.*) (\S+)$} $key dummy islandname abbrev
255 if {[string compare $lastislandname $islandname]} {
256 manyset $isleloc($islandname) x y
259 set lastislandname $islandname
263 regsub -all {[0-9]} $text {} text
265 set text [format "%2d%s" $c $text]
267 set text [format " %s" $text]
269 set id [$canvas create text $x $y \
270 -anchor nw -font fixed \
272 set bbox [$canvas bbox $id]
273 set bid [eval $canvas create rectangle $bbox -fill white]
274 $canvas lower $bid $id
275 manyset $bbox dummy dummy dummy y
279 panner::updatecanvas-bbox .ctrl.pan
283 proc widgets-setup {} {
286 frame .f -border 1 -relief groove
289 pack $canvas -expand 1 -fill both
290 pack .f -expand 1 -fill both -side left
293 pack .ctrl -side right
295 debug "BBOX [$canvas bbox all]"
297 panner::canvas-scroll-bbox .f.c
298 panner::create .ctrl.pan .f.c 120 120 $debug
300 pack .ctrl.pan -side top -pady 10 -padx 5
302 pack .ctrl.zoom -side top
304 button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
305 button .ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2}
306 pack .ctrl.zoom.out .ctrl.zoom.in -side left
308 wm geometry . 1024x480
314 set nscale [expr "\$scale $extail"]
315 debug "ZOOM $scale $nscale"
316 if {$nscale < 1 || $nscale > 200} return
325 httpclientsetup where-vessels