where-vessels: Organise properly

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
index 50c38b3595e0f399ba4f8e61590bb06136bba099..43d4a60db0cda0fb3e2af0608cc94e524622176b 100755 (executable)
--- a/yarrg/where-vessels
+++ b/yarrg/where-vessels
@@ -2,15 +2,19 @@
 
 source yarrglib.tcl
 source panner.tcl
 
 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
 }
 
 
 proc badusage {m} {
     puts stderr "where-vessels: bad usage: $m"
     exit 1
 }
 

-set ai 0

 proc nextarg {} {
     global ai argv
     if {$ai >= [llength $argv]} {
 proc nextarg {} {
     global ai argv
     if {$ai >= [llength $argv]} {


@@ -21,37 +25,79 @@ proc nextarg {} {
     return $v
 }
 
     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
        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]
        set notes($nk) [list $owner $note]

+    }

 }
 }

-close $vn
+

 
 proc vessel {vin} {
 
 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 }
        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]} {
        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 {
        } else {

-#              puts "UNKNOWN $nk"
+           debug "UNKNOWN $nk"

        }
        set kk "$vi(islandName) $abbrev"
        upvar #0 count($kk) k
        }
        set kk "$vi(islandName) $abbrev"
        upvar #0 count($kk) k


@@ -103,24 +149,48 @@ proc vessel {vin} {
        incr k
 }
 
        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 ?" }
        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
                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;
        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 $!;
                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
 
 
 set scale 16
 


@@ -151,7 +216,7 @@ proc coord {c} {
 
 proc chart-got/archlabel {args} { }
 proc chart-got/island {x y args} {
 
 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
        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} {
                -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] \
        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"] {
     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]
     }
        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)
     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
        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
        }
        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
        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"]
 
 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
     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