chiark / gitweb /
Move adjacency map stuff to C for performance reasons.
[rocl] / elite.tcl
CommitLineData
1304202a 1#! /usr/bin/tclsh
b130b8f5 2#
e93bc0bd 3# $Id: elite.tcl,v 1.5 2003/03/04 10:26:47 mdw Exp $
1304202a 4
5package require "elite-bits" "1.0.0"
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# --- worldinfo GAL ---
170#
171# Return a list describing the worlds in galaxy GAL (a seed). The list
172# contains a group of three elements for each world: the seed, x and y
173# coordinates (in decilightyears).
174
175proc worldinfo {g} {
176 foreach-world $g p {
177 lappend i $p(seed) $p(x) $p(y)
178 }
179 return $i
180}
181
182# --- world-distance X Y XX YY ---
183#
184# Computes the correct game distance in decilightyears between two worlds,
185# one at X, Y and the other at XX, YY.
186
187proc world-distance {x y xx yy} {
188 set dx [expr {abs($x - $xx)/4}]
189 set dy [expr {abs($y - $yy)/4}]
190 return [expr {4 * floor(sqrt($dx * $dx + $dy * $dy))}]
191}
192
193# --- nearest-planet WW X Y ---
194#
195# Returns the seed of the `nearest' planet given in the worldinfo list WW to
196# the point X Y (in decilightyears).
197
198proc nearest-planet {ww x y} {
199 set min 10000
200 foreach {ss xx yy} $ww {
201 set dx [expr {abs($x - $xx)/4}]
202 set dy [expr {abs($y - $yy)/2}]
203 if {$dx > $dy} {
204 set d [expr {($dx * 2 + $dy)/2}]
205 } else {
206 set d [expr {($dx + $dy * 2)/2}]
207 }
208 if {$d < $min} {
209 set p $ss
210 set min $d
211 }
212 }
213 return $p
214}
215
216# --- adjacency WW ADJ [D] ---
217#
218# Fill in the array ADJ with the adjacency table for the worlds listed in the
219# worldinfo list WW. That is, for each world seed S, ADJ(S) is set to a
220# worldinfo list containing the worlds within D (default 70) decilightyears
221# of S.
222
223proc adjacency {p adj {d 70}} {
224 upvar 1 $adj a
225 array set a {}
226 foreach {s x y} $p {
227 set done($s) 1
228 lappend a($s)
229 foreach {ss xx yy} $p {
230 if {[info exists done($ss)]} { continue }
231 if {abs($x - $xx) > $d + 10 || abs($y - $yy) > $d + 10 ||
232 [world-distance $x $y $xx $yy] > $d} { continue }
233 lappend a($s) $ss $xx $yy
234 lappend a($ss) $s $x $y
235 }
236 }
237}
238
239# --- worldname W ---
240#
241# Returns the name of the world with seed W.
242
243proc worldname {w} {
244 elite-worldinfo p $w
245 return $p(name)
246}
247
248# --- shortest-path ADJ FROM TO WEIGHT ---
249#
250# Computes the shortest path and shortest distance between the worlds wose
251# seeds are FROM and TO respectively. ADJ must be an adjacency table for the
252# galaxy containing FROM and TO. WEIGHT is a command such that WEIGHT A B
253# returns the `distance' for the simple path between A and B. The return
254# value is a list P D, where D is the weight of the path found, and P is a
255# simple list of seeds for the worlds on the path. P starts with FROM and
256# ends with TO.
257
258proc shortest-path {adjvar from to weight} {
259 upvar 1 $adjvar adj
260 if {[string equal $from $to]} { return [list $to 0] }
261 set l($from) 0
262 set p($from) $from
263 set c $from
264 while 1 {
265 foreach {n x y} $adj($c) {
266 if {[info exists l($n)]} {
267 continue
268 }
269 set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
270 if {![info exists ll($n)] || $w < $ll($n)} {
271 set ll($n) $w
272 set p($n) [concat $p($c) [list $n]]
273 }
274 }
275 set s [array startsearch ll]
276 if {![array anymore ll $s]} {
277 return {{} 0}
278 }
279 set c [array nextelement ll $s]
280 set w $ll($c)
281 while {[array anymore ll $s]} {
282 set n [array nextelement ll $s]
283 if {$ll($n) < $w} {
284 set c $n
285 set w $ll($n)
286 }
287 }
288 if {[string equal $c $to]} { return [list $p($to) $ll($to)] }
289 set l($c) $ll($c)
290 unset ll($c)
291 }
292}
293
294# --- weight-hops A B ---
295#
296# shortest-path weight function giving each hop the same weight.
297
298proc weight-hops {from to} {
299 return 1
300}
301
302# --- weight-fuel A B ---
303#
304# shortest-path weight function measuring the distance between FROM and TO.
305
306proc weight-fuel {from to} {
307 elite-worldinfo f $from
308 elite-worldinfo t $to
e93bc0bd 309 return [expr {[world-distance $f(x) $f(y) $t(x) $t(y)]/10.0}]
1304202a 310}
311
312# --- weight-safety A B ---
313#
314# shortest-path weight function attempting to maximize safety of the journey
315# by giving high weight (square-law) to worlds with unstable governments.
316
317proc weight-safety {from to} {
318 elite-worldinfo t $to
319 set w [expr {8 - $t(government)}]
320 return [expr {$w * $w}]
321}
322
323# --- weight-encounters A B ---
324#
325# shortest-path weight function attempting to maximize encounters on the
326# journey by giving high weight (square law) to worlds with stable
327# governments.
328
329proc weight-encounters {from to} {
330 elite-worldinfo f $from
331 elite-worldinfo t $to
332 set w [expr {1 + $t(government)}]
333 return [expr {$w * $w}]
334}
335
336# --- weight-trading A B ---
337#
338# shortest-path weight function attempting to maximize trading opportunities
339# along the journey by giving high weight (square law) to pairs of worlds
340# with small differences between their economic statuses.
341
342proc weight-trading {from to} {
343 elite-worldinfo f $from
344 elite-worldinfo t $to
345 set w [expr {8 - abs($f(economy) - $t(economy))}]
346 return [expr {$w * $w}]
347}
348
349# --- parse-galaxy-spec G ---
350#
351# Parses a galaxy spec and returns a list containing a description of the
352# galaxy and the corresponding galaxy seed. A galaxy spec is one of:
353#
354# * a number between 1 and 8, corresponding to one of the standard
355# galaxies;
356#
357# * a 12-digit hex string, which is a galaxy seed (and is returned
358# unchanged); or
359#
360# * a string of the form S:N where S is a 12-hex-digit seed and N is a
361# galaxy number, corresponding to the Nth galaxy starting with S as
362# galaxy 1.
363#
364# If the string is unrecognized, an empty list is returned.
365
366proc parse-galaxy-spec {g} {
367 switch -regexp -- $g {
368 {^[1-8]$} { return [list $g [galaxy $g]] }
369 {^[0-9a-fA-F]{12}$} { return [list $g $g] }
370 default {
371 if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} {
372 return [list $g [galaxy $n $b]]
373 }
374 }
375 }
376 return {}
377}
378
379# --- parse-planet-spec G P ---
380#
381# Parses a planet spec and returns the planet seed. The planet spec P is
382# interpreted relative to galaxy G. A planet spec is one of:
383#
384# * a simple integer, corresponding to a planet number;
385#
386# * a 12-hex-digit seed, which is returned unchanged;
387#
388# * a pair of integers separated by commas, corresponding to the nearest
389# planet to those coordinates;
390#
391# * a glob pattern, corresponding to the lowest-numbered planet in the
392# galaxy whose name matches the pattern case-insensitively; or
393#
394# * a string of the form G.P where G is a galaxy spec and P is a planet
395# spec, corresponding to the planet specified by P relative to galaxy G.
396#
397# If the string is unrecognized, an empty string is returned.
398
399proc parse-planet-spec {g p} {
400 if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
401 if {[regexp {^(.+)\.(.+)$} $p . g p]} {
402 set g [parse-galaxy-spec $g]
403 if {[string equal $g ""]} { return {} }
404 destructure {. g} $g
405 return [parse-planet-spec $g $p]
406 }
407 if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} {
408 for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {}
409 return $s
410 }
411 if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
412 $p . x y]} {
413 return [nearest-planet [worldinfo $g] $x $y]
414 }
415 set l [find-world $g $p]
416 if {[llength $l]} { return [lindex $l 0] }
417 return {}
418}
419
420# --- in-galaxy-p G PP ---
421#
422# Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
423# Doesn't mind if the planet seeds are invalid.
424
425proc in-galaxy-p {g pp} {
426 foreach-world $g i { set x($i(seed)) 1 }
427 foreach p $pp { if {![info exists x($p)]} { return 0 } }
428 return 1
429}
430
431# --- world-summary PLANET ---
432#
433# Return a one-line summary string for PLANET.
434
435proc world-summary {s} {
436 global eco gov
437 elite-worldinfo p $s
e93bc0bd 438 return [format "%-8s %4d %4d %-11s %-10s %2d %s" \
1304202a 439 $p(name) $p(x) $p(y) \
440 $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
441}
442
1ded87ba 443# --- jameson ARR ---
444#
445# Fill ARR with the information about commander JAMESON.
446
447proc jameson {arr} {
448 global galaxy1 products
449 upvar 1 $arr cmdr
450 array set cmdr {
451 mission 0
452 credits 1000
453 fuel 70
454 gal-number 1
455 front-laser 0x0f
456 rear-laser 0
457 left-laser 0
458 right-laser 0
459 cargo 20
460 missiles 3
461 legal-status 0
462 score 0
463 market-fluc 0
464 }
465 set cmdr(gal-seed) $galaxy1
466 foreach i {
467 ecm fuel-scoop energy-bomb energy-unit docking-computer
468 gal-hyperdrive escape-pod
469 } { set cmdr($i) 0 }
470 elite-worldinfo lave [find-world $galaxy1 "Lave"]
471 set cmdr(world-x) [expr {$lave(x)/4}]
472 set cmdr(world-y) [expr {$lave(y)/2}]
473 elite-market mkt $lave(seed) 0
474 foreach {t n} $products {
475 destructure [list . cmdr(station-$t)] $mkt($t)
476 set cmdr(hold-$t) 0
477 }
478 set cmdr(station-alien-items) 0
479}
480
1304202a 481#----- That's all, folks ----------------------------------------------------
482
483package provide "elite" "1.0.0"