From: Ian Jackson <ian@liberator.relativity.greenend.org.uk>
Date: Thu, 10 Dec 2009 00:39:05 +0000 (+0000)
Subject: WIP where-vessels: Can produce some kind of map
X-Git-Tag: 6.3.0~18
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=commitdiff_plain;h=c915c378bbed129861c419f671913f0113150007

WIP where-vessels: Can produce some kind of map
---

diff --git a/yarrg/where-vessels b/yarrg/where-vessels
new file mode 100755
index 0000000..a827892
--- /dev/null
+++ b/yarrg/where-vessels
@@ -0,0 +1,191 @@
+#!/usr/bin/wish
+
+set us Aristarchus
+
+proc manyset {list args} {
+    foreach val $list var $args {
+        upvar 1 $var my
+        set my $val
+    }
+}
+
+set itemre { (\w+) = ([^=]*) }
+set manyitemre "^\\\[ $itemre ( (?: ,\\ $itemre)* ) \\]\$"
+puts $manyitemre
+
+set vn [open vessel-notes]
+while {[gets $vn l] >= 0} {
+	regsub -all {\t+} $l "\t" l
+	manyset [split $l "\t"] vname vid owner note
+	set nk $vid.$vname
+	puts "SET NOTE $nk"
+	set notes($nk) [list $owner $note]
+}
+close $vn
+
+proc vessel {vin} {
+	global us
+	upvar #0 $vin vi
+	switch -exact $vi(vesselClass) {
+		smsloop		{ set sz 00sl }
+		lgsloop		{ set sz 01ct }
+		dhow		{ set sz 02dh }
+		longship	{ set sz 03ls }
+		baghlah		{ set sz 04bg }
+		merchbrig	{ set sz 05mb }
+		warbrig		{ set sz 06wb }
+		xebec		{ set sz 07xe }
+		warfrig		{ set sz 08wf }
+		merchgal	{ set sz 09mg }
+		grandfrig	{ set sz 10gf }
+		default		{ error "$vi(vesselClass) ?" }
+	}
+	set abbrev $sz
+	switch -exact $vi(vesselSubclass) {
+		null		{ }
+		icy		{ append abbrev F }
+		default		{ error "$vi(vesselSubclass) ?" }
+	}
+	switch -exact $vi(isLocked)/$vi(isBattleReady) {
+		true/false	{ append abbrev 2- }
+		false/false	{ append abbrev 1+ }
+		false/true	{ append abbrev 0* }
+		default		{ error "$vi(isLocked)/$vi(isBattleReady) ?" }
+	}
+	switch -exact $vi(inPort) {
+		true		{ }
+		false		{ append abbrev ? }
+		default		{ error "$vi(inPort) ?" }
+	}
+	set nk $vi(vesselId).$vi(vesselName)
+	upvar #0 notes($nk) note
+	if {[info exists note]} {
+		manyset $note owner xabbrev
+		if {![string compare $owner $us]} {
+			append abbrev =
+		} else {
+			append abbrev -
+		}
+		append abbrev $xabbrev
+		unset note
+	} else {
+#		puts "UNKNOWN $nk"
+	}
+	set kk "$vi(islandName) $abbrev"
+	upvar #0 count($kk) k
+	if {![info exists k]} { set k 0 }
+	incr k
+}
+
+set cl [open clipboard]
+while {[gets $cl l] >= 0} {
+#	puts "========"
+	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
+}
+close $cl
+
+set chart [open |[list perl -we {
+	use strict;
+	use CommodsScrape;
+	use IO::File;
+	use IO::Handle;
+	yppedia_chart_parse(\*STDIN, (new IO::File ">/dev/null"),
+		sub { sprintf "%d %d", @_; },
+		sub { printf "archlabel %d %d %s\n", @_; },
+		sub { printf "island %s %s\n", @_; },
+		sub { printf "league %s %s %s.\n", @_; },
+		sub { printf STDERR "warning: %s: incomprehensible: %s", @_; }
+			);
+	STDOUT->error and die $!;
+}] r]
+
+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
+
+set scale 15
+
+proc coord {c} {
+	global scale
+	return [expr {$c * $scale}]
+}
+
+proc chart-got/archlabel {args} { }
+proc chart-got/island {x y args} {
+#	puts "ISLE $x $y $args"
+	global canvas isleloc
+	set isleloc($args) [list $x $y]
+	set sz 5
+#	$canvas create oval \
+#		[expr {[coord $x] - $sz}] [expr {[coord $y] - $sz}] \
+#		[expr {[coord $x] + $sz}] [expr {[coord $y] + $sz}] \
+#		-fill blue
+	$canvas create text [coord $x] [coord $y] \
+		-text $args -anchor s
+}
+proc chart-got/league {x1 y1 x2 y2 kind} {
+#	puts "LEAGUE $x1 $y1 $x2 $y2 $kind"
+	global canvas
+	set l [$canvas create line \
+		[coord $x1] [coord $y1] \
+		[coord $x2] [coord $y2]]
+	if {![string compare $kind .]} {
+		$canvas itemconfigure $l -dash .
+	}
+}
+
+while {[gets $chart l] >= 0} {
+#	puts "CHART-GOT $l"
+	set proc [lindex $l 0]
+	eval chart-got/$proc [lrange $l 1 end]
+}
+
+puts WILLSHOW
+
+set lastislandname {}
+foreach key [lsort [array names count]] {
+	set c $count($key)
+#	puts "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"
+	}
+	set text $abbrev
+	regsub -all {[0-9]} $text {} text
+	if {$c > 1} {
+		set text [format "%2d%s" $c $text]
+	} else {
+		set text [format "  %s" $text]
+	}
+	set id [$canvas create text $x $y \
+		-anchor nw -font fixed \
+		-text $text]
+	set bbox [$canvas bbox $id]
+	set bid [eval $canvas create rectangle $bbox -fill white]
+	$canvas lower $bid $id
+	manyset $bbox dummy dummy dummy y
+#	puts "NEW Y $y"
+}
+
+foreach nk [lsort [array names $note]] {
+	puts "IGNORED NOTE $nk"
+}
+
+#puts "[$canvas bbox all]"