From 9f61e96561e428dad8e20156731594b0be7d178e Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Sat, 12 Dec 2009 13:17:37 +0000 Subject: [PATCH] where-vessels: Organise properly --- yarrg/where-vessels | 223 ++++++++++++++++++++++++++++++-------------- 1 file changed, 153 insertions(+), 70 deletions(-) diff --git a/yarrg/where-vessels b/yarrg/where-vessels index 50c38b3..43d4a60 100755 --- a/yarrg/where-vessels +++ b/yarrg/where-vessels @@ -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 -- 2.30.2