chiark / gitweb /
Fix nonexistent planet error. Make staying put cost nothing.
[rocl] / elite.tcl
CommitLineData
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 5package require "elite-bits" "1.0.1"
1304202a 6
7set 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
13proc 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
24tab government \
25 "anarchy" "feudal" "multi-government" "dictatorship" \
26 "communist" "confederacy" "democracy" "corporate state"
27
28tab economy \
29 "rich industrial" "average industrial" "poor industrial" \
30 "mainly industrial" "mainly agricultural" "rich agricultural" \
31 "average agricultural" "poor agricultural"
32
33tab gov \
34 anarchy feudal multi-gov dictator \
35 communist confed democracy corp-state
36
37tab eco \
83b4563b 38 rich-ind avg-ind poor-ind mainly-ind \
39 mainly-agri rich-agri avg-agri poor-agri
1304202a 40
41set 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
61foreach p $products { set unit($p) t }
62foreach p {gold platinum} { set unit($p) kg }
63set unit(gem-stones) g
64unset 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
71proc 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
84proc 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
97proc 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
116proc 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
137proc 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
161proc 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
174proc 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
196proc 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
211proc 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
251proc 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
259proc 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
270proc 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
282proc 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
295proc 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
319proc 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
352proc 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
381proc 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 391proc 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
405proc 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 441package provide "elite" "1.0.1"