chiark / gitweb /
Fix output formatting a little.
[rocl] / elite.tcl
1 #! /usr/bin/tclsh
2 #
3 # $Id: elite.tcl,v 1.6 2003/03/07 00:44:57 mdw Exp $
4
5 package require "elite-bits" "1.0.1"
6
7 set galaxy1 "4a5a480253b7"              ;# Seed for standard galaxy 1
8
9 # --- tab ARR NAME NAME ... ---
10 #
11 # Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.
12
13 proc tab {arr args} {
14   upvar 1 $arr a
15   set i 0
16   foreach v $args {
17     set a($i) $v
18     incr i
19   }
20 }
21
22 # --- Various standard tables ---
23
24 tab government \
25     "anarchy" "feudal" "multi-government" "dictatorship" \
26     "communist" "confederacy" "democracy" "corporate state"
27
28 tab economy \
29     "rich industrial" "average industrial" "poor industrial" \
30     "mainly industrial" "mainly agricultural" "rich agricultural" \
31     "average agricultural" "poor agricultural"
32
33 tab gov \
34     anarchy feudal multi-gov dictator \
35     communist confed democracy corp-state
36
37 tab eco \
38     rich-ind avg-ind poor-ind mainly-ind \
39     mainly-agri rich-agri avg-agri poor-agri
40
41 set products {
42   food          "Food"
43   textiles      "Textiles"
44   radioactives  "Radioactives"
45   slaves        "Slaves"
46   liquor-wines  "Liquor & wines"
47   luxuries      "Luxuries"
48   narcotics     "Narcotics"
49   computers     "Computers"
50   machinery     "Machinery"
51   alloys        "Alloys"
52   firearms      "Firearms"
53   furs          "Furs"
54   minerals      "Minerals"
55   gold          "Gold"
56   platinum      "Platinum"
57   gem-stones    "Gem-stones"
58   alien-items   "Alien items"
59 }
60
61 foreach p $products { set unit($p) t }
62 foreach p {gold platinum} { set unit($p) kg }
63 set unit(gem-stones) g
64 unset p
65
66 # --- galaxy N [GAL] ---
67 #
68 # Compute the seed of the Nth galaxy, if GAL is the seed of galaxy 1.  By
69 # default, GAL is the standard galaxy 1 seed.
70
71 proc galaxy [list n [list g $galaxy1]] {
72   for {set i 1} {$i < $n} {incr i} {
73     set g [elite-nextgalaxy $g]
74   }
75   return $g
76 }
77
78 # --- foreach-world GAL ARR SCRIPT ---
79 #
80 # For each world in galaxy GAL (a seed), set ARR to the world information
81 # and evaluate SCRIPT.  The usual loop control commands can be used in
82 # SCRIPT.
83
84 proc foreach-world {g p act} {
85   upvar 1 $p pp
86   for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} {
87     elite-worldinfo pp $g
88     uplevel 1 $act    
89   }
90 }
91
92 # --- find-world GAL PAT ---
93 #
94 # Return a list of seeds for the worlds in galaxy GAL (a seed) whose names
95 # match the glob pattern PAT.
96
97 proc find-world {g pat} {
98   set l {}
99   foreach-world $g p {
100     if {[string match -nocase $pat $p(name)]} {
101       lappend l $p(seed)
102     }
103   }
104   return $l
105 }
106
107 # --- destructure PAT LIST ---
108 #
109 # Destrcture LIST according to PAT.  If PAT is a single name, set the
110 # variable PAT to LIST; otherwise, if PAT is a list, each of its elements
111 # must correspond to an element of LIST, so recursively destructure the
112 # corresponding elements of each.  It is not an error if the PAT list is
113 # shorter than LIST.  The special variable name `.' indicates that no
114 # assignment is to be made.
115
116 proc destructure {pp xx} {
117   if {![string compare $pp "."]} {
118     return
119   } elseif {[llength $pp] == 0} {
120     return
121   } elseif {[llength $pp] == 1} {
122     upvar 1 $pp p
123     set p $xx
124   } else {
125     foreach p $pp x $xx {
126       uplevel 1 [list destructure $p $x]
127     }
128   }
129 }
130
131 # --- write-file NAME CONTENTS [TRANS] ---
132 #
133 # Write file NAME, storing CONTENTS translated according to TRANS (default
134 # `binary'.  The write is safe against errors -- we don't destroy the old
135 # data until the file is written.
136
137 proc write-file {name contents {trans binary}} {
138   if {[file exists $name]} {
139     if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
140       return -code $rc $err
141     }
142   }
143   if {[set rc [catch {
144     set f [open $name w]
145     fconfigure $f -translation $trans
146     puts -nonewline $f $contents
147     close $f
148   } err]]} {
149     catch { close $f }
150     catch { file rename -force "$name.old" $name }
151     return -code $rc $err
152   }
153   return ""
154 }
155
156 # --- read-file NAME [TRANS] ---
157 #
158 # Read the contents of the file NAME, translating it according to TRANS
159 # (default `binary').
160
161 proc read-file {name {trans binary}} {
162   set f [open $name]
163   fconfigure $f -translation $trans
164   set c [read $f]
165   close $f
166   return $c
167 }
168
169 # --- nearest-planet WW X Y ---
170 #
171 # Returns the seed of the `nearest' planet given in the worldinfo list WW to
172 # the point X Y (in decilightyears).
173
174 proc nearest-planet {ww x y} {
175   set min 10000
176   foreach {ss xx yy} $ww {
177     set dx [expr {abs($x - $xx)/4}]
178     set dy [expr {abs($y - $yy)/2}]
179     if {$dx > $dy} {
180       set d [expr {($dx * 2 + $dy)/2}]
181     } else {
182       set d [expr {($dx + $dy * 2)/2}]
183     }
184     if {$d < $min} {
185       set p $ss
186       set min $d
187     }
188   }
189   return $p
190 }
191
192 # --- worldname W ---
193 #
194 # Returns the name of the world with seed W.
195
196 proc worldname {w} {
197   elite-worldinfo p $w
198   return $p(name)
199 }
200
201 # --- shortest-path ADJ FROM TO WEIGHT ---
202 #
203 # Computes the shortest path and shortest distance between the worlds wose
204 # seeds are FROM and TO respectively.  ADJ must be an adjacency table for the
205 # galaxy containing FROM and TO.  WEIGHT is a command such that WEIGHT A B
206 # returns the `distance' for the simple path between A and B.  The return
207 # value is a list P D, where D is the weight of the path found, and P is a
208 # simple list of seeds for the worlds on the path.  P starts with FROM and
209 # ends with TO.
210
211 proc shortest-path {adjvar from to weight} {
212   upvar 1 $adjvar adj
213   if {[string equal $from $to]} { return [list $to 0] }
214   set l($from) 0
215   set p($from) $from
216   set c $from
217   while 1 {
218     foreach {n x y} $adj($c) {
219       if {[info exists l($n)]} {
220         continue
221       }
222       set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
223       if {![info exists ll($n)] || $w < $ll($n)} {
224         set ll($n) $w
225         set p($n) [concat $p($c) [list $n]]
226       }
227     }
228     set s [array startsearch ll]
229     if {![array anymore ll $s]} {
230       return {{} 0}
231     }
232     set c [array nextelement ll $s]
233     set w $ll($c)
234     while {[array anymore ll $s]} {
235       set n [array nextelement ll $s]
236       if {$ll($n) < $w} {
237         set c $n
238         set w $ll($n)
239       }
240     }
241     if {[string equal $c $to]} { return [list $p($to) $ll($to)] }
242     set l($c) $ll($c)
243     unset ll($c)
244   }
245 }
246
247 # --- weight-hops A B ---
248 #
249 # shortest-path weight function giving each hop the same weight.
250
251 proc weight-hops {from to} {
252   return 1
253 }
254
255 # --- weight-fuel A B ---
256 #
257 # shortest-path weight function measuring the distance between FROM and TO.
258
259 proc weight-fuel {from to} {
260   elite-worldinfo f $from
261   elite-worldinfo t $to
262   return [elite-distance $f(x) $f(y) $t(x) $t(y)]
263 }
264
265 # --- weight-safety A B ---
266 #
267 # shortest-path weight function attempting to maximize safety of the journey
268 # by giving high weight (square-law) to worlds with unstable governments.
269
270 proc weight-safety {from to} {
271   elite-worldinfo t $to
272   set w [expr {8 - $t(government)}]
273   return [expr {$w * $w}]
274 }
275
276 # --- weight-encounters A B ---
277 #
278 # shortest-path weight function attempting to maximize encounters on the
279 # journey by giving high weight (square law) to worlds with stable
280 # governments.
281
282 proc weight-encounters {from to} {
283   elite-worldinfo f $from
284   elite-worldinfo t $to
285   set w [expr {1 + $t(government)}]
286   return [expr {$w * $w}]
287 }
288
289 # --- weight-trading A B ---
290 #
291 # shortest-path weight function attempting to maximize trading opportunities
292 # along the journey by giving high weight (square law) to pairs of worlds
293 # with small differences between their economic statuses.
294
295 proc weight-trading {from to} {
296   elite-worldinfo f $from
297   elite-worldinfo t $to
298   set w [expr {8 - abs($f(economy) - $t(economy))}]
299   return [expr {$w * $w}]
300 }
301
302 # --- parse-galaxy-spec G ---
303 #
304 # Parses a galaxy spec and returns a list containing a description of the
305 # galaxy and the corresponding galaxy seed.  A galaxy spec is one of:
306 #
307 #   * a number between 1 and 8, corresponding to one of the standard
308 #     galaxies;
309 #
310 #   * a 12-digit hex string, which is a galaxy seed (and is returned
311 #     unchanged); or
312 #
313 #   * a string of the form S:N where S is a 12-hex-digit seed and N is a
314 #     galaxy number, corresponding to the Nth galaxy starting with S as
315 #     galaxy 1.
316 #
317 # If the string is unrecognized, an empty list is returned.
318
319 proc parse-galaxy-spec {g} {
320   switch -regexp -- $g {
321     {^[1-8]$} { return [list $g [galaxy $g]] }
322     {^[0-9a-fA-F]{12}$} { return [list $g $g] }
323     default {
324       if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} {
325         return [list $g [galaxy $n $b]]
326       }
327     }
328   }
329   return {}
330 }
331
332 # --- parse-planet-spec G P ---
333 #
334 # Parses a planet spec and returns the planet seed.  The planet spec P is
335 # interpreted relative to galaxy G.  A planet spec is one of:
336 #
337 #   * a simple integer, corresponding to a planet number;
338 #
339 #   * a 12-hex-digit seed, which is returned unchanged;
340 #
341 #   * a pair of integers separated by commas, corresponding to the nearest
342 #     planet to those coordinates;
343 #
344 #   * a glob pattern, corresponding to the lowest-numbered planet in the
345 #     galaxy whose name matches the pattern case-insensitively; or
346 #
347 #   * a string of the form G.P where G is a galaxy spec and P is a planet
348 #     spec, corresponding to the planet specified by P relative to galaxy G.
349 #
350 # If the string is unrecognized, an empty string is returned.
351
352 proc parse-planet-spec {g p} {
353   if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
354   if {[regexp {^(.+)\.(.+)$} $p . g p]} {
355     set g [parse-galaxy-spec $g]
356     if {[string equal $g ""]} { return {} }
357     destructure {. g} $g
358     return [parse-planet-spec $g $p]
359   }
360   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} {
361     for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {}
362     return $s
363   }
364   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
365       $p . x y]} {
366     return [nearest-planet [elite-galaxylist $g] $x $y]
367   }
368   if {[regexp {^([^/]*)(?:/([1-9]\d*))?$} $p . p i]} {
369     if {[string equal $i ""]} { set i 1 }
370     set l [find-world $g $p]
371     if {$i <= [llength $l]} { return [lindex $l [expr {$i - 1}]] }
372   }
373   return {}
374 }
375
376 # --- in-galaxy-p G PP ---
377 #
378 # Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
379 # Doesn't mind if the planet seeds are invalid.
380
381 proc in-galaxy-p {g pp} {
382   foreach-world $g i { set x($i(seed)) 1 }
383   foreach p $pp { if {![info exists x($p)]} { return 0 } }
384   return 1
385 }
386
387 # --- world-summary PLANET ---
388 #
389 # Return a one-line summary string for PLANET.
390
391 proc world-summary {s {ind 0} {spc 0}} {
392   global eco gov
393   elite-worldinfo p $s
394   set is [string repeat " " $ind]
395   set ss [string repeat " " $spc]
396   return [format "%s%-8s%s %4d %4d %-11s %-10s %2d %s" \
397       $is $p(name) $ss $p(x) $p(y) \
398       $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
399 }
400
401 # --- jameson ARR ---
402 #
403 # Fill ARR with the information about commander JAMESON.
404
405 proc jameson {arr} {
406   global galaxy1 products
407   upvar 1 $arr cmdr
408   array set cmdr {
409     mission           0
410     credits        1000
411     fuel             70
412     gal-number        1
413     front-laser    0x0f
414     rear-laser        0
415     left-laser        0
416     right-laser       0
417     cargo            20
418     missiles          3
419     legal-status      0
420     score             0
421     market-fluc       0
422   }
423   set cmdr(gal-seed) $galaxy1
424   foreach i {
425     ecm fuel-scoop energy-bomb energy-unit docking-computer
426     gal-hyperdrive escape-pod
427   } { set cmdr($i) 0 }
428   elite-worldinfo lave [find-world $galaxy1 "Lave"]
429   set cmdr(world-x) [expr {$lave(x)/4}]
430   set cmdr(world-y) [expr {$lave(y)/2}]
431   elite-market mkt $lave(seed) 0
432   foreach {t n} $products {
433     destructure [list . cmdr(station-$t)] $mkt($t)
434     set cmdr(hold-$t) 0
435   }
436   set cmdr(station-alien-items) 0
437 }
438
439 #----- That's all, folks ----------------------------------------------------
440
441 package provide "elite" "1.0.1"