yarrg/where-vessels

   1 #!/usr/bin/wish
   2
   3 source yarrglib.tcl
   4 source panner.tcl
   5 package require http
   6
   7 set debug 0
   8 proc debug {m} {
   9     global debug
  10     if {$debug} { puts "DEBUG $m" }
  11 }
  12
  13 proc badusage {m} {
  14     puts stderr "where-vessels: bad usage: $m"
  15     exit 1
  16 }
  17
  18 proc nextarg {} {
  19     global ai argv
  20     if {$ai >= [llength $argv]} {
  21         badusage "option [lindex $argv [expr {$ai-1}]] needs a value"
  22     }
  23     set v [lindex $argv $ai]
  24     incr ai
  25     return $v
  26 }
  27
  28 proc glset {n val} {
  29     upvar #0 $n var
  30     set var $val
  31 }
  32
  33 set notes_loc vessel-notes
  34 set scraper {./yppedia-ocean-scraper --chart}
  35
  36 proc parseargs {} {
  37     global ai argv
  38     global debug scraper
  39     set ai 0
  40
  41     while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
  42         incr ai
  43         switch -exact -- $arg {
  44             -- { break }
  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" }
  52         }
  53     }
  54     set argv [lrange $argv $ai end]
  55     if {[llength $argv]} { badusage "non-option args not allowed" }
  56 }
  57
  58 proc argdefaults {} {
  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
  65     }
  66     lappend scraper $ocean
  67 }
  68
  69 proc load-notes {} {
  70     global notes_loc notes
  71     catch { unset notes }
  72     if {[regexp {^\w+\:} $notes_loc]} {
  73         vwait idletasks
  74         debug "FETCHING NOTES"
  75         ::http::geturl $notes_loc
  76         switch -glob [::http::status].[::http::ncode] {
  77             ok.200 { }
  78             ok.* { error "retrieving vessel-notes $url: [::http::code]" }
  79             * { error "retrieving vessel-notes $url: [::http::error]" }
  80         }
  81         set notes_data [::http::data]
  82         ::http::cleanup
  83     } else {
  84         set vn [open $notes_loc]
  85         set notes_data [read $vn]
  86         close $vn
  87     }
  88     foreach l [split $notes_data "\n"] {
  89         regsub -all {\t+} $l "\t" l
  90         manyset [split $l "\t"] vname vid owner note
  91         set nk $vid.$vname
  92         debug "SET NOTE $nk"
  93         set notes($nk) [list $owner $note]
  94     }
  95 }
  96
  97
  98 proc vessel {vin} {
  99         global pirate notes_used
 100         upvar 1 $vin vi
 101         switch -exact $vi(vesselClass) {
 102                 smsloop         { set sz 00sl }
 103                 lgsloop         { set sz 01ct }
 104                 dhow            { set sz 02dh }
 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) ?" }
 114         }
 115         set abbrev $sz
 116         switch -exact $vi(vesselSubclass) {
 117                 null            { }
 118                 icy             { append abbrev F }
 119                 default         { error "$vi(vesselSubclass) ?" }
 120         }
 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) ?" }
 126         }
 127         switch -exact $vi(inPort) {
 128                 true            { }
 129                 false           { append abbrev ? }
 130                 default         { error "$vi(inPort) ?" }
 131         }
 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]} {
 137                 append abbrev =
 138             } else {
 139                 append abbrev -
 140             }
 141             append abbrev $xabbrev
 142             set notes_used($nk) 1
 143         } else {
 144             debug "UNKNOWN $nk"
 145         }
 146         set kk "$vi(islandName) $abbrev"
 147         upvar #0 count($kk) k
 148         if {![info exists k]} { set k 0 }
 149         incr k
 150 }
 151
 152 set clipboard {}
 153 proc parse-clipboard {} {
 154     global clipboard count notes notes_used
 155
 156     catch { unset count }
 157     catch { unset notes_used }
 158
 159     set itemre { (\w+) = ([^=]*) }
 160     set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
 161     debug $manyitemre
 162
 163     foreach l [split $clipboard "\n"] {
 164         if {![string length $l]} continue
 165         catch { unset vi }
 166         while 1 {
 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
 172                 set l "\[$rhs\]"
 173         }
 174         vessel vi
 175     }
 176
 177     foreach nk [lsort [array names notes]] {
 178         if {![info exists notes_used($nk)]} {
 179             debug "IGNORED NOTE $nk"
 180         }
 181     }
 182 }
 183
 184 proc load-clipboard-file {fn} {
 185     set f [open $fn]
 186     glset clipboard [read $f]
 187     close $f
 188 }
 189
 190 proc load-chart {} {
 191     global chart scraper
 192     debug "FETCHING CHART"
 193     set chart [eval exec $scraper [list | perl -we {
 194         use strict;
 195         use CommodsScrape;
 196         use IO::File;
 197         use IO::Handle;
 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", @_; }
 204                         );
 205         STDOUT->error and die $!;
 206     }]]
 207 }
 208
 209
 210 set scale 16
 211
 212 proc coord {c} {
 213         global scale
 214         return [expr {$c * $scale}]
 215 }
 216
 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]
 222         set sz 5
 223 #       $canvas create oval \
 224 #               [expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
 225 #               [expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
 226 #               -fill blue
 227         $canvas create text [coord $x] [coord $y] \
 228                 -text $args -anchor s
 229 }
 230 proc chart-got/league {x1 y1 x2 y2 kind} {
 231 #       debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
 232         global canvas
 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 .
 238         }
 239 }
 240
 241 proc draw {} {
 242     global chart count isleloc canvas
 243
 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]
 248     }
 249
 250     set lastislandname {}
 251     foreach key [lsort [array names count]] {
 252         set c $count($key)
 253 #       debug "SHOWING $key $c"
 254         regexp {^(.*) (\S+)$} $key dummy islandname abbrev
 255         if {[string compare $lastislandname $islandname]} {
 256                 manyset $isleloc($islandname) x y
 257                 set x [coord $x]
 258                 set y [coord $y]
 259                 set lastislandname $islandname
 260 #               debug "START Y $y"
 261         }
 262         set text $abbrev
 263         regsub -all {[0-9]} $text {} text
 264         if {$c > 1} {
 265                 set text [format "%2d%s" $c $text]
 266         } else {
 267                 set text [format "  %s" $text]
 268         }
 269         set id [$canvas create text $x $y \
 270                 -anchor nw -font fixed \
 271                 -text $text]
 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
 276 #       debug "NEW Y $y"
 277     }
 278
 279     panner::updatecanvas-bbox .ctrl.pan
 280 }
 281
 282
 283 proc widgets-setup {} {
 284     global canvas debug
 285
 286     frame .f -border 1 -relief groove
 287     set canvas .f.c
 288     canvas $canvas
 289     pack $canvas -expand 1 -fill both
 290     pack .f -expand 1 -fill both -side left
 291
 292     frame .ctrl
 293     pack .ctrl -side right
 294
 295     debug "BBOX [$canvas bbox all]"
 296
 297     panner::canvas-scroll-bbox .f.c
 298     panner::create .ctrl.pan .f.c 120 120 $debug
 299
 300     pack .ctrl.pan -side top -pady 10 -padx 5
 301     frame .ctrl.zoom
 302     pack .ctrl.zoom -side top
 303
 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
 307
 308     wm geometry . 1024x480
 309 }
 310
 311
 312 proc zoom {extail} {
 313     global scale canvas
 314     set nscale [expr "\$scale $extail"]
 315     debug "ZOOM $scale $nscale"
 316     if {$nscale < 1 || $nscale > 200} return
 317     set scale $nscale
 318     $canvas delete all
 319     draw
 320 }
 321
 322
 323 parseargs
 324 argdefaults
 325 httpclientsetup where-vessels
 326 load-chart
 327 widgets-setup
 328
 329 load-notes
 330 parse-clipboard
 331
 332 draw