3 # $Id: elite.tcl,v 1.6 2003/03/07 00:44:57 mdw Exp $
5 package require
"elite-bits" "1.0.1"
7 set galaxy1
"4a5a480253b7" ;# Seed for standard galaxy 1
9 # --- tab ARR NAME NAME ... ---
11 # Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.
22 # --- Various standard tables ---
25 "anarchy" "feudal" "multi-government" "dictatorship" \
26 "communist" "confederacy" "democracy" "corporate state"
29 "rich industrial" "average industrial" "poor industrial" \
30 "mainly industrial" "mainly agricultural" "rich agricultural" \
31 "average agricultural" "poor agricultural"
34 anarchy feudal multi-gov dictator
\
35 communist confed democracy corp-state
38 rich-ind avg-ind poor-ind mainly-ind
\
39 mainly-agri rich-agri avg-agri poor-agri
44 radioactives
"Radioactives"
46 liquor-wines
"Liquor & wines"
57 gem-stones
"Gem-stones"
58 alien-items
"Alien items"
61 foreach p
$products { set unit
($p) t
}
62 foreach p
{gold platinum
} { set unit
($p) kg
}
63 set unit
(gem-stones
) g
66 # --- galaxy N [GAL] ---
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.
71 proc galaxy
[list n
[list g
$galaxy1]] {
72 for {set i
1} {$i < $n} {incr i
} {
73 set g
[elite-nextgalaxy
$g]
78 # --- foreach-world GAL ARR SCRIPT ---
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
84 proc foreach-world
{g p act
} {
86 for {set i
0} {$i < 256} {incr i
; set g
[elite-nextworld
$g]} {
92 # --- find-world GAL PAT ---
94 # Return a list of seeds for the worlds in galaxy GAL (a seed) whose names
95 # match the glob pattern PAT.
97 proc find-world
{g pat
} {
100 if {[string match
-nocase $pat $p(name
)]} {
107 # --- destructure PAT LIST ---
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.
116 proc destructure
{pp xx
} {
117 if {![string compare
$pp "."]} {
119 } elseif
{[llength $pp] == 0} {
121 } elseif
{[llength $pp] == 1} {
125 foreach p
$pp x
$xx {
126 uplevel 1 [list destructure
$p $x]
131 # --- write-file NAME CONTENTS [TRANS] ---
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.
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
145 fconfigure $f -translation $trans
146 puts -nonewline $f $contents
150 catch { file rename -force "$name.old" $name }
151 return -code $rc $err
156 # --- read-file NAME [TRANS] ---
158 # Read the contents of the file NAME, translating it according to TRANS
159 # (default `binary').
161 proc read-file
{name
{trans
binary}} {
163 fconfigure $f -translation $trans
169 # --- nearest-planet WW X Y ---
171 # Returns the seed of the `nearest' planet given in the worldinfo list WW to
172 # the point X Y (in decilightyears).
174 proc nearest-planet
{ww x y
} {
176 foreach {ss xx yy
} $ww {
177 set dx
[expr {abs
($x - $xx)/4}]
178 set dy
[expr {abs
($y - $yy)/2}]
180 set d
[expr {($dx * 2 + $dy)/2}]
182 set d
[expr {($dx + $dy * 2)/2}]
192 # --- worldname W ---
194 # Returns the name of the world with seed W.
201 # --- shortest-path ADJ FROM TO WEIGHT ---
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
211 proc shortest-path
{adjvar from to weight
} {
213 if {[string equal
$from $to]} { return [list $to 0] }
218 foreach {n x y
} $adj($c) {
219 if {[info exists l
($n)]} {
222 set w
[expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
223 if {![info exists ll
($n)] ||
$w < $ll($n)} {
225 set p
($n) [concat $p($c) [list $n]]
228 set s
[array startsearch ll
]
229 if {![array anymore ll
$s]} {
232 set c
[array nextelement ll
$s]
234 while {[array anymore ll
$s]} {
235 set n
[array nextelement ll
$s]
241 if {[string equal
$c $to]} { return [list $p($to) $ll($to)] }
247 # --- weight-hops A B ---
249 # shortest-path weight function giving each hop the same weight.
251 proc weight-hops
{from to
} {
255 # --- weight-fuel A B ---
257 # shortest-path weight function measuring the distance between FROM and TO.
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
)]
265 # --- weight-safety A B ---
267 # shortest-path weight function attempting to maximize safety of the journey
268 # by giving high weight (square-law) to worlds with unstable governments.
270 proc weight-safety
{from to
} {
271 elite-worldinfo t
$to
272 set w
[expr {8 - $t(government
)}]
273 return [expr {$w * $w}]
276 # --- weight-encounters A B ---
278 # shortest-path weight function attempting to maximize encounters on the
279 # journey by giving high weight (square law) to worlds with stable
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}]
289 # --- weight-trading A B ---
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.
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}]
302 # --- parse-galaxy-spec G ---
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:
307 # * a number between 1 and 8, corresponding to one of the standard
310 # * a 12-digit hex string, which is a galaxy seed (and is returned
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
317 # If the string is unrecognized, an empty list is returned.
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] }
324 if {[regexp {^
([0-9a-fA-F
]{12}):([1-8])$} $g . b n
]} {
325 return [list $g [galaxy
$n $b]]
332 # --- parse-planet-spec G P ---
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:
337 # * a simple integer, corresponding to a planet number;
339 # * a 12-hex-digit seed, which is returned unchanged;
341 # * a pair of integers separated by commas, corresponding to the nearest
342 # planet to those coordinates;
344 # * a glob pattern, corresponding to the lowest-numbered planet in the
345 # galaxy whose name matches the pattern case-insensitively; or
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.
350 # If the string is unrecognized, an empty string is returned.
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 {} }
358 return [parse-planet-spec
$g $p]
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]} {}
364 if {[regexp {^
(0x
[0-9a-fA-F
]+|
[0-9]+),\s
*(0x
[0-9a-fA-F
]+|
[0-9]+)$} \
366 return [nearest-planet
[elite-galaxylist
$g] $x $y]
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}]] }
376 # --- in-galaxy-p G PP ---
378 # Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
379 # Doesn't mind if the planet seeds are invalid.
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 } }
387 # --- world-summary PLANET ---
389 # Return a one-line summary string for PLANET.
391 proc world-summary
{s
{ind
0} {spc
0}} {
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
)]
401 # --- jameson ARR ---
403 # Fill ARR with the information about commander JAMESON.
406 global galaxy1 products
423 set cmdr
(gal-seed
) $galaxy1
425 ecm fuel-scoop energy-bomb energy-unit docking-computer
426 gal-hyperdrive escape-pod
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)
436 set cmdr
(station-alien-items
) 0
439 #----- That's all, folks ----------------------------------------------------
441 package provide
"elite" "1.0.1"