1304202a |
1 | #! /usr/bin/tclsh |
b130b8f5 |
2 | # |
7da7c511 |
3 | # $Id: elite.tcl,v 1.6 2003/03/07 00:44:57 mdw Exp $ |
1304202a |
4 | |
7da7c511 |
5 | package require "elite-bits" "1.0.1" |
1304202a |
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 \ |
83b4563b |
38 | rich-ind avg-ind poor-ind mainly-ind \ |
39 | mainly-agri rich-agri avg-agri poor-agri |
1304202a |
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 | |
1ded87ba |
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 | |
1304202a |
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 | |
1304202a |
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 |
7da7c511 |
262 | return [elite-distance $f(x) $f(y) $t(x) $t(y)] |
1304202a |
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]} { |
7da7c511 |
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}]] } |
1304202a |
372 | } |
1304202a |
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 | |
7da7c511 |
391 | proc world-summary {s {ind 0} {spc 0}} { |
1304202a |
392 | global eco gov |
393 | elite-worldinfo p $s |
7da7c511 |
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) \ |
1304202a |
398 | $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)] |
399 | } |
400 | |
1ded87ba |
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 | |
1304202a |
439 | #----- That's all, folks ---------------------------------------------------- |
440 | |
7da7c511 |
441 | package provide "elite" "1.0.1" |