chiark / gitweb /
And then screwed the code over...
[rocl] / elite-map
1 #! /usr/bin/tclsh
2 #
3 # $Id: elite-map,v 1.4 2003/03/07 00:41:46 mdw Exp $
4
5 package require "elite" "1.0.0"
6
7 set syms "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
8 proc symbol {i} {
9   global syms
10   if {$i < [string length $syms]} {
11     return [string index $syms $i]
12   }
13   set hi [expr {$i / [string length $syms]}]
14   set lo [expr {$i % [string length $syms]}]
15   return [string index $syms $hi][string index $syms $lo]
16 }
17
18 proc show-map {asp wx wy ww {n {}} {p {}}} {
19   set minx 10000
20   set miny 10000
21   set maxx 0
22   set maxy 0
23
24   set lmain {}
25   set lmagic {}
26   set lpath {}
27   if {[llength $n] == 1} {
28     set w [lindex $n 0]
29     set fancy($w) "*"
30     lappend lmagic $fancy($w) $w
31   } else {
32     set i 0
33     foreach w $n {
34       if {![info exists fancy($w)]} {
35         set fancy($w) "*[symbol $i]"
36         lappend lmagic $fancy($w) $w
37         incr i
38       }
39     }
40   }
41   set i 0
42   foreach w $p {
43     if {![info exists fancy($w)]} {
44       set fancy($w) "+[symbol $i]"
45       lappend lpath $fancy($w) $w
46       incr i
47     }
48   }
49   foreach {s x y} $ww {
50     if {$x < $minx} { set minx $x}
51     if {$y < $miny} { set miny $y}
52     if {$x > $maxx} { set maxx $x}
53     if {$y > $maxy} { set maxy $y}
54   }
55   set dx [expr {$maxx - $minx}]
56   set dy [expr {$maxy - $miny}]
57   if {$dx == 0} { set dx 1 }
58   if {$dy == 0} { set dy 1 }
59
60   set sc [expr {$wx/double($dx)}]
61   if {$dy * $sc/$asp > $wy} {
62     set sc [expr {$wy * $asp/double($dy)}]
63   }
64   set gw {}
65   foreach {s x y} $ww {
66     set gx [expr {int(($x - $minx) * $sc + 0.5)}]
67     set gy [expr {int(($y - $miny) * $sc/$asp + 0.5)}]
68     lappend gw [list $s $gx $gy]
69   }
70
71   set pw [lsort -index 1 -integer -increasing $gw]
72   set pw [lsort -index 2 -integer -increasing $pw]
73   set x 0
74   set y 0
75   set i 0
76   foreach w $pw {
77     destructure {s px py} $w
78     if {$y < $py} {
79       puts -nonewline [string repeat "\n" [expr {$py - $y}]]
80       set x 0
81       set y $py
82     }
83     if {$x < $px} {
84       puts -nonewline [string repeat " " [expr {$px - $x}]]
85       set x $px
86     }
87     set l lmain
88     if {[info exists fancy($s)]} {
89       set sy $fancy($s)
90     } else {
91       set sy [symbol $i]
92       lappend $l $sy $s
93       incr i
94     }
95     puts -nonewline $sy
96     incr x [string length $sy]
97   }
98   puts -nonewline "\n"
99   return [list $lmagic $lpath $lmain]
100 }
101
102 proc show-key {l {n {}}} {
103   global gov eco
104   if {[llength $n]} {
105     elite-worldinfo p [lindex $n 0]
106   }
107   foreach {sy s} $l {
108     elite-worldinfo pp $s
109     set out [format "%2s %s" $sy [world-summary $s]]
110     if {[llength $n]} {
111       append out [format " (%.1f LY)" \
112         [expr {[elite-distance $p(x) $p(y) $pp(x) $pp(y)]/10.0}]]
113     }
114     puts $out
115   }
116 }
117
118 set g $galaxy1
119 set wx 72
120 set wy 10
121 set asp 2.17
122 set d 70
123 set v 2
124 set weight {}
125 set usage "usage: $argv0 \[-qv\] \[-g GAL\] \[-d DIST\] \[-w WEIGHT\]\n\t\[-W WD,HT\] \[-a ASP\] \[PLANET ...\]"
126 for {set i 0} {$i < [llength $argv]} {incr i} {
127   set a [lindex $argv $i]
128   switch -glob -- $a {
129     "-g" {
130       incr i
131       set a [lindex $argv $i]
132       set g [parse-galaxy-spec $a]
133       if {[string equal $g ""]} {
134         puts stderr "$argv0: bad galaxy string `$a'"
135         exit 1
136       }
137       destructure {. g} $g
138     }
139     "-d" {
140       incr i
141       set d [expr {int([lindex $argv $i] * 10)}]
142     }
143     "-W" {
144       incr i
145       if {![regexp {^(\d+),(\d+)$} [lindex $argv $i] . wx wy]} {
146         puts stderr "$argv0: bad window size string"
147         exit 1
148       }
149     }
150     "-w" {
151       incr i
152       set a [lindex $argv $i]
153       set weight "weight-$a"
154       if {[lsearch -exact [info commands "weight-*"] $weight] == -1} {
155         puts stderr "$argv0: unknown weight function `$a'"
156         puts stderr "$argv0: I know [info commands weight-*]"
157         exit 1
158       }
159     }
160     "-a" {
161       incr i
162       set asp [lindex $argv $i]
163     }
164     "-v" {
165       incr v
166     }
167     "-q" {
168       incr v -1
169     }
170     "--" {
171       incr i
172       break
173     }
174     "-*" {
175       puts stderr $usage
176       exit 1
177     }
178     default {
179       break
180     }
181   }
182 }
183
184 set p [lrange $argv $i end]
185 set ww [elite-galaxylist $g]
186 if {![llength $p]} {
187   set n {}
188   set rt {}
189   set w $ww
190   incr v -1
191 } else {
192   if {![string equal $weight ""]} { elite-adjacency adj $ww $d }
193   set n {}
194   foreach a $p {
195     set s [parse-planet-spec $g $a]
196     if {[string equal $s ""]} {
197       puts stderr "$argv0: unknown planet `$a'"
198       exit 1
199     }
200     lappend n $s
201   }
202   set rt {}
203   if {![string equal $weight ""]} {
204     set home [lindex $n 0]
205     foreach w [lrange $n 1 end] {
206       destructure {p .} [shortest-path adj $home $w $weight]
207       if {![llength $p]} {
208         puts stderr \
209             "$argv0: no route from [worldname $home] to [worldname $w]"
210         exit 1
211       }
212       eval lappend rt $p
213       set home $w
214     }
215   }
216   set x0 1024
217   set y0 1024
218   set x1 0
219   set y1 0
220   set w {}
221   foreach p [concat $n $rt] {
222     elite-worldinfo ii $p
223     if {$ii(x) < $x0} { set x0 $ii(x) }
224     if {$ii(y) < $y0} { set y0 $ii(y) }
225     if {$ii(x) > $x1} { set x1 $ii(x) }
226     if {$ii(y) > $y1} { set y1 $ii(y) }
227   }
228   set x0 [expr {$x0 - $d - 5}]
229   set y0 [expr {$y0 - $d - 5}]
230   set x1 [expr {$x1 + $d + 5}]
231   set y1 [expr {$y1 + $d + 5}]
232   set w {}
233   foreach {p x y} $ww {
234     if {$x >= $x0 && $y >= $y0 && $x <= $x1 && $y <= $y1} {
235       lappend w $p $x $y
236     }
237   }
238 }
239 destructure {lmagic lpath lmain} [show-map $asp $wx $wy $w $n $rt]
240 if {$v > 0} {
241   puts ""
242   show-key $lmagic $n
243 }
244 if {$v > 1} {
245   if {[string equal $weight ""]} {
246     show-key $lmain $n
247   } else {
248     show-key $lpath $n
249     if {$v > 2} {
250       show-key $lmain $n
251     }
252   }
253 }
254
255       
256