chiark / gitweb /
where-vessels: Organise properly
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sat, 12 Dec 2009 13:17:37 +0000 (13:17 +0000)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sat, 12 Dec 2009 13:17:37 +0000 (13:17 +0000)
yarrg/where-vessels

index 50c38b3..43d4a60 100755 (executable)
@@ -2,15 +2,19 @@
 
 source yarrglib.tcl
 source panner.tcl
+package require http
 
-set pirate { }
+set debug 0
+proc debug {m} {
+    global debug
+    if {$debug} { puts "DEBUG $m" }
+}
 
 proc badusage {m} {
     puts stderr "where-vessels: bad usage: $m"
     exit 1
 }
 
-set ai 0
 proc nextarg {} {
     global ai argv
     if {$ai >= [llength $argv]} {
@@ -21,37 +25,79 @@ proc nextarg {} {
     return $v
 }
 
-while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
-    incr ai
-    switch -exact -- $arg {
-       -- { break }
-       --pirate { set pirate [string totitle [nextarg]] }
-       --ocean { set ocean [string totitle [nextarg]] }
-       --clipboard-file { set clipboard_file [nextarg] }
-       --notes { set notes_loc [nextarg] }
-       default { badusage "unknown option $arg" }
+proc glset {n val} {
+    upvar #0 $n var
+    set var $val
+}
+
+set notes_loc vessel-notes
+set scraper {./yppedia-ocean-scraper --chart}
+
+proc parseargs {} {
+    global ai argv
+    global debug scraper
+    set ai 0
+
+    while {[regexp {^\-} [set arg [lindex $argv $ai]]]} {
+       incr ai
+       switch -exact -- $arg {
+           -- { break }
+           --pirate { glset pirate [string totitle [nextarg]] }
+           --ocean { glset ocean [string totitle [nextarg]] }
+           --clipboard-file { load-clipboard-file [nextarg] }
+           --local-html-dir { lappend scraper --local-html-dir=[nextarg] }
+           --notes { glset notes_loc [nextarg] }
+           --debug { incr debug }
+           default { badusage "unknown option $arg" }
+       }
     }
+    set argv [lrange $argv $ai end]
+    if {[llength $argv]} { badusage "non-option args not allowed" }
+}
+
+proc argdefaults {} {
+    global ocean notes_loc pirate scraper
+    if {![info exists ocean] || ![info exists pirate]} {
+       set cmd {./yarrg --find-window-only --quiet}
+       if {[info exists ocean]} { lappend cmd --ocean $ocean }
+       if {[info exists pirate]} { lappend cmd --pirate $pirate }
+       manyset [split [eval exec $cmd] " "] ocean pirate
+    }
+    lappend scraper $ocean
 }
-set argv [lrange $argv $ai end]
-if {[llength $argv]} { badusage "non-option args not allowed" }
-    
-set itemre { (\w+) = ([^=]*) }
-set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
-puts $manyitemre
 
-set vn [open vessel-notes]
-while {[gets $vn l] >= 0} {
+proc load-notes {} {
+    global notes_loc notes
+    catch { unset notes }
+    if {[regexp {^\w+\:} $notes_loc]} {
+       vwait idletasks
+       debug "FETCHING NOTES"
+       ::http::geturl $notes_loc
+       switch -glob [::http::status].[::http::ncode] {
+           ok.200 { }
+           ok.* { error "retrieving vessel-notes $url: [::http::code]" }
+           * { error "retrieving vessel-notes $url: [::http::error]" }
+       }
+       set notes_data [::http::data]
+       ::http::cleanup
+    } else {
+       set vn [open $notes_loc]
+       set notes_data [read $vn]
+       close $vn
+    }
+    foreach l [split $notes_data "\n"] {
        regsub -all {\t+} $l "\t" l
        manyset [split $l "\t"] vname vid owner note
        set nk $vid.$vname
-       puts "SET NOTE $nk"
+       debug "SET NOTE $nk"
        set notes($nk) [list $owner $note]
+    }
 }
-close $vn
+
 
 proc vessel {vin} {
-       global pirate
-       upvar #0 $vin vi
+       global pirate notes_used
+       upvar 1 $vin vi
        switch -exact $vi(vesselClass) {
                smsloop         { set sz 00sl }
                lgsloop         { set sz 01ct }
@@ -86,16 +132,16 @@ proc vessel {vin} {
        set nk $vi(vesselId).$vi(vesselName)
        upvar #0 notes($nk) note
        if {[info exists note]} {
-               manyset $note owner xabbrev
-               if {![string compare $owner $pirate]} {
-                       append abbrev =
-               } else {
-                       append abbrev -
-               }
-               append abbrev $xabbrev
-               unset note
+           manyset $note owner xabbrev
+           if {![string compare $owner $pirate]} {
+               append abbrev =
+           } else {
+               append abbrev -
+           }
+           append abbrev $xabbrev
+           set notes_used($nk) 1
        } else {
-#              puts "UNKNOWN $nk"
+           debug "UNKNOWN $nk"
        }
        set kk "$vi(islandName) $abbrev"
        upvar #0 count($kk) k
@@ -103,24 +149,48 @@ proc vessel {vin} {
        incr k
 }
 
-set cl [open clipboard]
-while {[gets $cl l] >= 0} {
-#      puts "========"
+set clipboard {}
+proc parse-clipboard {} {
+    global clipboard count notes notes_used
+
+    catch { unset count }
+    catch { unset notes_used }
+    
+    set itemre { (\w+) = ([^=]*) }
+    set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
+    debug $manyitemre
+
+    foreach l [split $clipboard "\n"] {
+       if {![string length $l]} continue
        catch { unset vi }
        while 1 {
                if {![regexp -expanded $manyitemre $l dummy \
                        thiskey thisval rhs]} { error "$l ?" }
-#              puts "KEY $thiskey VAL $thisval"
                set vi($thiskey) $thisval
                if {![string length $rhs]} break
                regsub {^, } $rhs {} rhs
                set l "\[$rhs\]"
        }
        vessel vi
+    }
+
+    foreach nk [lsort [array names notes]] {
+       if {![info exists notes_used($nk)]} {
+           debug "IGNORED NOTE $nk"
+       }
+    }
+}
+
+proc load-clipboard-file {fn} {
+    set f [open $fn]
+    glset clipboard [read $f]
+    close $f
 }
-close $cl
 
-set chart [exec perl -we {
+proc load-chart {} {
+    global chart scraper
+    debug "FETCHING CHART"
+    set chart [eval exec $scraper [list | perl -we {
        use strict;
        use CommodsScrape;
        use IO::File;
@@ -133,14 +203,9 @@ set chart [exec perl -we {
                sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
                        );
        STDOUT->error and die $!;
-}]
+    }]]
+}
 
-frame .f -border 1 -relief groove
-set canvas .f.c
-canvas $canvas
-#$canvas configure -width 1000 -height 800
-pack $canvas -expand 1 -fill both
-pack .f -expand 1 -fill both -side left
 
 set scale 16
 
@@ -151,7 +216,7 @@ proc coord {c} {
 
 proc chart-got/archlabel {args} { }
 proc chart-got/island {x y args} {
-#      puts "ISLE $x $y $args"
+#      debug "ISLE $x $y $args"
        global canvas isleloc
        set isleloc($args) [list $x $y]
        set sz 5
@@ -163,7 +228,7 @@ proc chart-got/island {x y args} {
                -text $args -anchor s
 }
 proc chart-got/league {x1 y1 x2 y2 kind} {
-#      puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
+#      debug "LEAGUE $x1 $y1 $x2 $y2 $kind"
        global canvas
        set l [$canvas create line \
                [coord $x1] [coord $y1] \
@@ -177,7 +242,7 @@ proc draw {} {
     global chart count isleloc canvas
     
     foreach l [split $chart "\n"] {
-#      puts "CHART-GOT $l"
+#      debug "CHART-GOT $l"
        set proc [lindex $l 0]
        eval chart-got/$proc [lrange $l 1 end]
     }
@@ -185,14 +250,14 @@ proc draw {} {
     set lastislandname {}
     foreach key [lsort [array names count]] {
        set c $count($key)
-#      puts "SHOWING $key $c"
+#      debug "SHOWING $key $c"
        regexp {^(.*) (\S+)$} $key dummy islandname abbrev
        if {[string compare $lastislandname $islandname]} {
                manyset $isleloc($islandname) x y
                set x [coord $x]
                set y [coord $y]
                set lastislandname $islandname
-#              puts "START Y $y"
+#              debug "START Y $y"
        }
        set text $abbrev
        regsub -all {[0-9]} $text {} text
@@ -208,42 +273,60 @@ proc draw {} {
        set bid [eval $canvas create rectangle $bbox -fill white]
        $canvas lower $bid $id
        manyset $bbox dummy dummy dummy y
-#      puts "NEW Y $y"
+#      debug "NEW Y $y"
     }
+
+    panner::updatecanvas-bbox .ctrl.pan
 }
 
-draw
 
-foreach nk [lsort [array names $note]] {
-       puts "IGNORED NOTE $nk"
-}
+proc widgets-setup {} {
+    global canvas debug
 
-frame .ctrl
-pack .ctrl -side right
+    frame .f -border 1 -relief groove
+    set canvas .f.c
+    canvas $canvas
+    pack $canvas -expand 1 -fill both
+    pack .f -expand 1 -fill both -side left
 
-panner::canvas-scroll-bbox .f.c
-panner::create .ctrl.pan .f.c 120 120
+    frame .ctrl
+    pack .ctrl -side right
+
+    debug "BBOX [$canvas bbox all]"
+
+    panner::canvas-scroll-bbox .f.c
+    panner::create .ctrl.pan .f.c 120 120 $debug
+
+    pack .ctrl.pan -side top -pady 10 -padx 5
+    frame .ctrl.zoom
+    pack .ctrl.zoom -side top
+
+    button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
+    button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
+    pack .ctrl.zoom.out .ctrl.zoom.in -side left
+
+    wm geometry . 1024x480
+}
 
-pack .ctrl.pan -side top -pady 10 -padx 5
-frame .ctrl.zoom
-pack .ctrl.zoom -side top
 
 proc zoom {extail} {
     global scale canvas
     set nscale [expr "\$scale $extail"]
-    puts "ZOOM $scale $nscale"
+    debug "ZOOM $scale $nscale"
     if {$nscale < 1 || $nscale > 200} return
     set scale $nscale
     $canvas delete all
     draw
-    panner::updatecanvas-bbox .ctrl.pan
 }
 
-button .ctrl.zoom.out -text - -font {Courier 16} -command {zoom /2}
-button .ctrl.zoom.in  -text + -font {Courier 16} -command {zoom *2}
-pack .ctrl.zoom.out .ctrl.zoom.in -side left
 
-#. configure -width 640 -height 480
-wm geometry . 1024x480
+parseargs
+argdefaults
+httpclientsetup where-vessels
+load-chart
+widgets-setup
 
-#puts "[$canvas bbox all]"
+load-notes
+parse-clipboard
+
+draw