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