2 # show your vessels on a map
4 # This is part of ypp-sc-tools, a set of third-party tools for assisting
5 # players of Yohoho Puzzle Pirates.
7 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
9 # This program is free software: you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation, either version 3 of the License, or
12 # (at your option) any later version.
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program. If not, see <http://www.gnu.org/licenses/>.
22 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
23 # are used without permission. This program is not endorsed or
24 # sponsored by Three Rings.
32 #---------- general utilities ----------
37 if {$debug} { puts "DEBUG $m" }
41 puts stderr "where-vessels: bad usage: $m"
50 #---------- argument parsing ----------
54 if {$ai >= [llength $argv]} {
55 badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
57 set v [lindex $argv $ai]
62 set notes_loc vessel-notes
63 set scraper {./yppedia-ocean-scraper --chart}
70 while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
72 switch -exact -- $arg {
74 --pirate { glset pirate [string totitle [nextarg]] }
75 --ocean { glset ocean [string totitle [nextarg]] }
76 --clipboard-file { load-clipboard-file [nextarg] }
77 --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
78 --notes { glset notes_loc [nextarg] }
79 --debug { incr debug }
80 default { badusage "unknown option $arg" }
83 set argv [lrange $argv $ai end]
84 if {[llength $argv]} { badusage "non-option args not allowed" }
88 global ocean notes_loc pirate scraper
89 if {![info exists ocean] || ![info exists pirate]} {
90 set cmd {./yarrg --find-window-only --quiet}
91 if {[info exists ocean]} { lappend cmd --ocean $ocean }
92 if {[info exists pirate]} { lappend cmd --pirate $pirate }
93 manyset [split [eval exec $cmd] " "] ocean pirate
95 lappend scraper $ocean
99 #---------- loading and parsing the vessel notes ----------
102 global notes_loc notes
103 catch { unset notes }
104 if {[regexp {^\w+\:} $notes_loc]} {
106 debug "FETCHING NOTES"
107 ::http::geturl $notes_loc
108 switch -glob [::http::status].[::http::ncode] {
110 ok.* { error "retrieving vessel-notes $url: [::http::code]" }
111 * { error "retrieving vessel-notes $url: [::http::error]" }
113 set notes_data [::http::data]
116 set vn [open $notes_loc]
117 set notes_data [read $vn]
120 foreach l [split $notes_data "\n"] {
121 regsub -all {\t+} $l "\t" l
122 manyset [split $l "\t"] vname vid owner note
125 set notes($nk) [list $owner $note]
130 #---------- loading and parsing the clipboard (vessel locations) ----------
133 global pirate notes_used
135 switch -exact $vi(vesselClass) {
136 smsloop { set sz 00sl }
137 lgsloop { set sz 01ct }
139 longship { set sz 03ls }
140 baghlah { set sz 04bg }
141 merchbrig { set sz 05mb }
142 warbrig { set sz 06wb }
143 xebec { set sz 07xe }
144 warfrig { set sz 08wf }
145 merchgal { set sz 09mg }
146 grandfrig { set sz 10gf }
147 default { error "$vi(vesselClass) ?" }
150 switch -exact $vi(vesselSubclass) {
152 icy { append abbrev F }
153 default { error "$vi(vesselSubclass) ?" }
155 switch -exact $vi(isLocked)/$vi(isBattleReady) {
156 true/false { append abbrev 2- }
157 false/false { append abbrev 1+ }
158 false/true { append abbrev 0* }
159 default { error "$vi(isLocked)/$vi(isBattleReady) ?" }
161 switch -exact $vi(inPort) {
163 false { append abbrev ? }
164 default { error "$vi(inPort) ?" }
166 set nk $vi(vesselId).$vi(vesselName)
167 upvar #0 notes($nk) note
168 if {[info exists note]} {
169 manyset $note owner xabbrev
170 if {![string compare $owner $pirate]} {
175 append abbrev $xabbrev
176 set notes_used($nk) 1
180 set kk "$vi(islandName) $abbrev"
181 upvar #0 count($kk) k
182 if {![info exists k]} { set k 0 }
187 proc parse-clipboard {} {
188 global clipboard count notes notes_used
190 catch { unset count }
191 catch { unset notes_used }
193 set itemre { (\w+) = ([^=]*) }
194 set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
197 foreach l [split $clipboard "\n"] {
198 if {![string length $l]} continue
201 if {![regexp -expanded $manyitemre $l dummy \
202 thiskey thisval rhs]} { error "$l ?" }
203 set vi($thiskey) $thisval
204 if {![string length $rhs]} break
205 regsub {^, } $rhs {} rhs
211 foreach nk [lsort [array names notes]] {
212 if {![info exists notes_used($nk)]} {
213 debug "IGNORED NOTE $nk"
218 proc load-clipboard-file {fn} {
220 glset clipboard [read $f]
225 #---------- loading and parsing the chart ----------
229 debug "FETCHING CHART"
230 set chart [eval exec $scraper [list | perl -we {
235 yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
236 sub { sprintf "%d %d", @_; },
237 sub { printf "archlabel %d %d %s\n", @_; },
238 sub { printf "island %s %s\n", @_; },
239 sub { printf "league %s %s %s.\n", @_; },
240 sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
242 STDOUT->error and die $!;
251 return [expr {$c * $scale}]
254 proc chart-got/archlabel {args} { }
255 proc chart-got/island {x y args} {
256 # debug "ISLE $x $y $args"
257 global canvas isleloc
258 set isleloc($args) [list $x $y]
260 # $canvas create oval \
261 # [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
262 # [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
264 $canvas create text [coord $x] [coord $y] \
265 -text $args -anchor s
267 proc chart-got/league {x1 y1 x2 y2 kind} {
268 # debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
270 set l [$canvas create line \
271 [coord $x1] [coord $y1] \
272 [coord $x2] [coord $y2]]
273 if {![string compare $kind .]} {
274 $canvas itemconfigure $l -dash .
279 global chart count isleloc canvas
283 foreach l [split $chart "\n"] {
284 # debug "CHART-GOT $l"
285 set proc [lindex $l 0]
286 eval chart-got/$proc [lrange $l 1 end]
289 set lastislandname {}
290 foreach key [lsort [array names count]] {
292 # debug "SHOWING $key $c"
293 regexp {^(.*) (\S+)$} $key dummy islandname abbrev
294 if {[string compare $lastislandname $islandname]} {
295 manyset $isleloc($islandname) x y
298 set lastislandname $islandname
302 regsub -all {[0-9]} $text {} text
304 set text [format "%2d%s" $c $text]
306 set text [format " %s" $text]
308 set id [$canvas create text $x $y \
309 -anchor nw -font fixed \
311 set bbox [$canvas bbox $id]
312 set bid [eval $canvas create rectangle $bbox -fill white]
313 $canvas lower $bid $id
314 manyset $bbox dummy dummy dummy y
318 panner::updatecanvas-bbox .ctrl.pan
322 #---------- user interface ----------
324 proc widgets-setup {} {
325 global canvas debug acqdeffont
327 frame .f -border 1 -relief groove
330 pack $canvas -expand 1 -fill both
331 pack .f -expand 1 -fill both -side left
334 pack .ctrl -side right
336 debug "BBOX [$canvas bbox all]"
338 panner::canvas-scroll-bbox .f.c
339 panner::create .ctrl.pan .f.c 120 120 $debug
341 pack .ctrl.pan -side top -pady 10 -padx 5
343 pack .ctrl.zoom -side top
345 button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
346 button .ctrl.zoom.in -text + -font {Courier 16} -command {zoom *2}
347 pack .ctrl.zoom.out .ctrl.zoom.in -side left
350 button .ctrl.acquire.do -text Acquire -command acquire
352 frame .ctrl.acquire.resframe -width 120 -height 32
353 button .ctrl.acquire.resframe.res -text {} -anchor nw \
354 -padx 1 -pady 1 -borderwidth 0 -justify left
355 glset acqdeffont [.ctrl.acquire.resframe.res cget -font]
356 place .ctrl.acquire.resframe.res -relx 0.5 -y 0 -anchor n
357 # -relheight 1.0 -relwidth 1.0
359 pack .ctrl.acquire.do -side top
360 pack .ctrl.acquire.resframe -side top -expand y -fill both
361 pack .ctrl.acquire -side top
363 wm geometry . 1024x480
368 set nscale [expr "\$scale $extail"]
369 debug "ZOOM $scale $nscale"
370 if {$nscale < 1 || $nscale > 200} return
375 proc acquire_showerror {} {
377 tk_messageBox -type ok \
378 -title "where-vessels: clipboard parsing error" \
383 global clipboard acqdeffont acqerr
386 set clipboard [clipboard get]
388 .ctrl.acquire.resframe.res configure \
389 -background blue -disabledforeground black -font $acqdeffont \
390 -state disabled -command {} \
391 -text " acquired ok "
393 set acqerr "clipboard parsing failed: $emsg"
395 regsub -all {.{18}} "error: [string trim $emsg]" "&\n" ewrap
396 .ctrl.acquire.resframe.res configure \
397 -background red -foreground white -font fixed \
398 -state normal -command acquire_showerror \
407 #---------- main program ----------
411 httpclientsetup where-vessels