chiark / gitweb /
where-vessels: can acquire
[ypp-sc-tools.db-live.git] / yarrg / where-vessels
1 #!/usr/bin/wish
2 # show your vessels on a map
3
4 # This is part of ypp-sc-tools, a set of third-party tools for assisting
5 # players of Yohoho Puzzle Pirates.
6 #
7 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
8 #
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.
13 #
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.
18 #
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/>.
21 #
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.
25
26
27
28 source yarrglib.tcl
29 source panner.tcl
30 package require http
31
32 #---------- general utilities ----------
33
34 set debug 0
35 proc debug {m} {
36     global debug
37     if {$debug} { puts "DEBUG $m" }
38 }
39
40 proc badusage {m} {
41     puts stderr "where-vessels: bad usage: $m"
42     exit 1
43 }
44
45 proc glset {n val} {
46     upvar #0 $n var
47     set var $val
48 }
49
50 #---------- argument parsing ----------
51
52 proc nextarg {} {
53     global ai argv
54     if {$ai >= [llength $argv]} {
55         badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
56     }
57     set v [lindex $argv $ai]
58     incr ai
59     return $v
60 }
61
62 set notes_loc vessel-notes
63 set scraper {./yppedia-ocean-scraper --chart}
64
65 proc parseargs {} {
66     global ai argv
67     global debug scraper
68     set ai 0
69
70     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
71         incr ai
72         switch -exact -- $arg {
73             -- { break }
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" }
81         }
82     }
83     set argv [lrange $argv $ai end]
84     if {[llength $argv]} { badusage "non-option args not allowed" }
85 }
86
87 proc argdefaults {} {
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
94     }
95     lappend scraper $ocean
96 }
97
98
99 #---------- loading and parsing the vessel notes ----------
100
101 proc load-notes {} {
102     global notes_loc notes
103     catch { unset notes }
104     if {[regexp {^\w+\:} $notes_loc]} {
105         vwait idletasks
106         debug "FETCHING NOTES"
107         ::http::geturl $notes_loc
108         switch -glob [::http::status].[::http::ncode] {
109             ok.200 { }
110             ok.* { error "retrieving vessel-notes $url: [::http::code]" }
111             * { error "retrieving vessel-notes $url: [::http::error]" }
112         }
113         set notes_data [::http::data]
114         ::http::cleanup
115     } else {
116         set vn [open $notes_loc]
117         set notes_data [read $vn]
118         close $vn
119     }
120     foreach l [split $notes_data "\n"] {
121         regsub -all {\t+} $l "\t" l
122         manyset [split $l "\t"] vname vid owner note
123         set nk $vid.$vname
124         debug "SET NOTE $nk"
125         set notes($nk) [list $owner $note]
126     }
127 }
128
129
130 #---------- loading and parsing the clipboard (vessel locations) ----------
131
132 proc vessel {vin} {
133         global pirate notes_used
134         upvar 1 $vin vi
135         switch -exact $vi(vesselClass) {
136                 smsloop         { set sz 00sl }
137                 lgsloop         { set sz 01ct }
138                 dhow            { set sz 02dh }
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) ?" }
148         }
149         set abbrev $sz
150         switch -exact $vi(vesselSubclass) {
151                 null            { }
152                 icy             { append abbrev F }
153                 default         { error "$vi(vesselSubclass) ?" }
154         }
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) ?" }
160         }
161         switch -exact $vi(inPort) {
162                 true            { }
163                 false           { append abbrev ? }
164                 default         { error "$vi(inPort) ?" }
165         }
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]} {
171                 append abbrev =
172             } else {
173                 append abbrev -
174             }
175             append abbrev $xabbrev
176             set notes_used($nk) 1
177         } else {
178             debug "UNKNOWN $nk"
179         }
180         set kk "$vi(islandName) $abbrev"
181         upvar #0 count($kk) k
182         if {![info exists k]} { set k 0 }
183         incr k
184 }
185
186 set clipboard {}
187 proc parse-clipboard {} {
188     global clipboard count notes notes_used
189
190     catch { unset count }
191     catch { unset notes_used }
192     
193     set itemre { (\w+) = ([^=]*) }
194     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
195     debug $manyitemre
196
197     foreach l [split $clipboard "\n"] {
198         if {![string length $l]} continue
199         catch { unset vi }
200         while 1 {
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
206                 set l "\[$rhs\]"
207         }
208         vessel vi
209     }
210
211     foreach nk [lsort [array names notes]] {
212         if {![info exists notes_used($nk)]} {
213             debug "IGNORED NOTE $nk"
214         }
215     }
216 }
217
218 proc load-clipboard-file {fn} {
219     set f [open $fn]
220     glset clipboard [read $f]
221     close $f
222 }
223
224
225 #---------- loading and parsing the chart ----------
226
227 proc load-chart {} {
228     global chart scraper
229     debug "FETCHING CHART"
230     set chart [eval exec $scraper [list | perl -we {
231         use strict;
232         use CommodsScrape;
233         use IO::File;
234         use IO::Handle;
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", @_; }
241                         );
242         STDOUT->error and die $!;
243     }]]
244 }
245
246
247 set scale 16
248
249 proc coord {c} {
250         global scale
251         return [expr {$c * $scale}]
252 }
253
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]
259         set sz 5
260 #       $canvas create oval \
261 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
262 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
263 #               -fill blue
264         $canvas create text [coord $x] [coord $y] \
265                 -text $args -anchor s
266 }
267 proc chart-got/league {x1 y1 x2 y2 kind} {
268 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
269         global canvas
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 .
275         }
276 }
277
278 proc draw {} {
279     global chart count isleloc canvas
280     
281     $canvas delete all
282
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]
287     }
288
289     set lastislandname {}
290     foreach key [lsort [array names count]] {
291         set c $count($key)
292 #       debug "SHOWING $key $c"
293         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
294         if {[string compare $lastislandname $islandname]} {
295                 manyset $isleloc($islandname) x y
296                 set x [coord $x]
297                 set y [coord $y]
298                 set lastislandname $islandname
299 #               debug "START Y $y"
300         }
301         set text $abbrev
302         regsub -all {[0-9]} $text {} text
303         if {$c > 1} {
304                 set text [format "%2d%s" $c $text]
305         } else {
306                 set text [format "  %s" $text]
307         }
308         set id [$canvas create text $x $y \
309                 -anchor nw -font fixed \
310                 -text $text]
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
315 #       debug "NEW Y $y"
316     }
317
318     panner::updatecanvas-bbox .ctrl.pan
319 }
320
321
322 #---------- user interface ----------
323
324 proc widgets-setup {} {
325     global canvas debug acqdeffont
326
327     frame .f -border 1 -relief groove
328     set canvas .f.c
329     canvas $canvas
330     pack $canvas -expand 1 -fill both
331     pack .f -expand 1 -fill both -side left
332
333     frame .ctrl
334     pack .ctrl -side right
335
336     debug "BBOX [$canvas bbox all]"
337
338     panner::canvas-scroll-bbox .f.c
339     panner::create .ctrl.pan .f.c 120 120 $debug
340
341     pack .ctrl.pan -side top -pady 10 -padx 5
342     frame .ctrl.zoom
343     pack .ctrl.zoom -side top
344
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
348
349     frame .ctrl.acquire
350     button .ctrl.acquire.do -text Acquire -command acquire
351
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
358
359     pack .ctrl.acquire.do -side top
360     pack .ctrl.acquire.resframe -side top -expand y -fill both
361     pack .ctrl.acquire -side top
362
363     wm geometry . 1024x480
364 }
365
366 proc zoom {extail} {
367     global scale canvas
368     set nscale [expr "\$scale $extail"]
369     debug "ZOOM $scale $nscale"
370     if {$nscale < 1 || $nscale > 200} return
371     set scale $nscale
372     draw
373 }
374
375 proc acquire_showerror {} {
376     global acqerr
377     tk_messageBox -type ok \
378         -title "where-vessels: clipboard parsing error" \
379         -message $acqerr
380 }
381
382 proc acquire {} {
383     global clipboard acqdeffont acqerr
384     set old $clipboard
385     if {[catch {
386         set clipboard [clipboard get]
387         parse-clipboard
388         .ctrl.acquire.resframe.res configure \
389             -background blue -disabledforeground black -font $acqdeffont \
390             -state disabled -command {} \
391             -text " acquired ok "
392     } emsg]} {
393         set acqerr "clipboard parsing failed: $emsg"
394         puts stderr $acqerr
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 \
399             -text $ewrap
400         set clipboard $old
401         parse-clipboard
402     }
403     draw
404 }
405
406
407 #---------- main program ----------
408
409 parseargs
410 argdefaults
411 httpclientsetup where-vessels
412 load-chart
413 widgets-setup
414
415 load-notes
416 parse-clipboard
417
418 draw