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