-#! /usr/bin/tclsh
-#
-# $Id: elite.tcl,v 1.4 2003/03/01 17:47:07 mdw Exp $
+### -*-tcl-*-
+###
+### Common Elite hacking functions
+###
+### (c) 2003 Mark Wooding
+###
+
+###----- Licensing notice ---------------------------------------------------
+###
+### This program is free software; you can redistribute it and/or modify
+### it under the terms of the GNU General Public License as published by
+### the Free Software Foundation; either version 2 of the License, or
+### (at your option) any later version.
+###
+### This program is distributed in the hope that it will be useful,
+### but WITHOUT ANY WARRANTY; without even the implied warranty of
+### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+### GNU General Public License for more details.
+###
+### You should have received a copy of the GNU General Public License
+### along with this program; if not, write to the Free Software Foundation,
+### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+package require "elite-bits" "1.0.1"
+
+###--------------------------------------------------------------------------
+### Internal utilities.
+
+proc _tab {arr args} {
+ ## _tab ARR NAME NAME ... ---
+ ##
+ ## Construct an array mapping integers 0, 1, ... to the given NAMEs, in
+ ## order.
-package require "elite-bits" "1.0.0"
-
-set galaxy1 "4a5a480253b7" ;# Seed for standard galaxy 1
-
-# --- tab ARR NAME NAME ... ---
-#
-# Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.
-
-proc tab {arr args} {
upvar 1 $arr a
set i 0
foreach v $args {
}
}
-# --- Various standard tables ---
+###--------------------------------------------------------------------------
+### Magic constants and tables.
-tab government \
+set galaxy1 "4a5a480253b7" ;# Seed for standard galaxy 1
+
+## Government types.
+_tab government \
"anarchy" "feudal" "multi-government" "dictatorship" \
"communist" "confederacy" "democracy" "corporate state"
-tab economy \
+## Economy types.
+_tab economy \
"rich industrial" "average industrial" "poor industrial" \
"mainly industrial" "mainly agricultural" "rich agricultural" \
"average agricultural" "poor agricultural"
-tab gov \
+## Abbreviated government types.
+_tab gov \
anarchy feudal multi-gov dictator \
communist confed democracy corp-state
-tab eco \
+## Abbreviated economy types.
+_tab eco \
rich-ind avg-ind poor-ind mainly-ind \
mainly-agri rich-agri avg-agri poor-agri
+## Two-letter government and economy types.
+_tab gv Ay Fl MG Dp Ct Cy Dy CS
+_tab ec RI AI PI MI MA RA AA PA
+
+## Products for trading.
set products {
food "Food"
textiles "Textiles"
set unit(gem-stones) g
unset p
-# --- galaxy N [GAL] ---
-#
-# Compute the seed of the Nth galaxy, if GAL is the seed of galaxy 1. By
-# default, GAL is the standard galaxy 1 seed.
+###--------------------------------------------------------------------------
+### External functions.
proc galaxy [list n [list g $galaxy1]] {
+ ## Compute the seed of the Nth galaxy, if G is the seed of galaxy 1. By
+ ## default, G is the standard galaxy 1 seed.
+
for {set i 1} {$i < $n} {incr i} {
set g [elite-nextgalaxy $g]
}
return $g
}
-# --- foreach-world GAL ARR SCRIPT ---
-#
-# For each world in galaxy GAL (a seed), set ARR to the world information
-# and evaluate SCRIPT. The usual loop control commands can be used in
-# SCRIPT.
-
proc foreach-world {g p act} {
+ ## For each world in galaxy G (a seed), set P to the world information and
+ ## evaluate ACT. The usual loop control commands can be used in ACT.
upvar 1 $p pp
for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} {
elite-worldinfo pp $g
- uplevel 1 $act
+ uplevel 1 $act
}
}
-# --- find-world GAL PAT ---
-#
-# Return a list of seeds for the worlds in galaxy GAL (a seed) whose names
-# match the glob pattern PAT.
-
proc find-world {g pat} {
+ ## Return a list of seeds for the worlds in galaxy G (a seed) whose names
+ ## match the glob pattern PAT.
+
set l {}
foreach-world $g p {
if {[string match -nocase $pat $p(name)]} {
return $l
}
-# --- destructure PAT LIST ---
-#
-# Destrcture LIST according to PAT. If PAT is a single name, set the
-# variable PAT to LIST; otherwise, if PAT is a list, each of its elements
-# must correspond to an element of LIST, so recursively destructure the
-# corresponding elements of each. It is not an error if the PAT list is
-# shorter than LIST. The special variable name `.' indicates that no
-# assignment is to be made.
-
proc destructure {pp xx} {
+ ## Destrcture an object XX according to the pattern PP. If PP is a single
+ ## name, set the variable PP to XX; otherwise, if PP is a list, each of its
+ ## elements must correspond to an element of the list XX, so recursively
+ ## destructure the corresponding elements of each. It is not an error if
+ ## the PP list is shorter than XX. The special variable name `.' indicates
+ ## that no assignment is to be made.
+
if {![string compare $pp "."]} {
return
} elseif {[llength $pp] == 0} {
}
}
-# --- write-file NAME CONTENTS [TRANS] ---
-#
-# Write file NAME, storing CONTENTS translated according to TRANS (default
-# `binary'. The write is safe against errors -- we don't destroy the old
-# data until the file is written.
-
proc write-file {name contents {trans binary}} {
+ ## Write file NAME, storing CONTENTS translated according to TRANS (default
+ ## `binary'. The write is safe against errors -- we don't destroy the old
+ ## data until the file is written.
+
if {[file exists $name]} {
if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
return -code $rc $err
return ""
}
-# --- read-file NAME [TRANS] ---
-#
-# Read the contents of the file NAME, translating it according to TRANS
-# (default `binary').
-
proc read-file {name {trans binary}} {
+ ## Read the contents of the file NAME, translating it according to TRANS
+ ## (default `binary').
+
set f [open $name]
fconfigure $f -translation $trans
set c [read $f]
return $c
}
-# --- worldinfo GAL ---
-#
-# Return a list describing the worlds in galaxy GAL (a seed). The list
-# contains a group of three elements for each world: the seed, x and y
-# coordinates (in decilightyears).
-
-proc worldinfo {g} {
- foreach-world $g p {
- lappend i $p(seed) $p(x) $p(y)
- }
- return $i
-}
-
-# --- world-distance X Y XX YY ---
-#
-# Computes the correct game distance in decilightyears between two worlds,
-# one at X, Y and the other at XX, YY.
-
-proc world-distance {x y xx yy} {
- set dx [expr {abs($x - $xx)/4}]
- set dy [expr {abs($y - $yy)/4}]
- return [expr {4 * floor(sqrt($dx * $dx + $dy * $dy))}]
-}
-
-# --- nearest-planet WW X Y ---
-#
-# Returns the seed of the `nearest' planet given in the worldinfo list WW to
-# the point X Y (in decilightyears).
-
proc nearest-planet {ww x y} {
+ ## Returns the seed of the `nearest' planet given in the worldinfo list WW
+ ## to the point X Y (in decilightyears).
+
set min 10000
foreach {ss xx yy} $ww {
set dx [expr {abs($x - $xx)/4}]
return $p
}
-# --- adjacency WW ADJ [D] ---
-#
-# Fill in the array ADJ with the adjacency table for the worlds listed in the
-# worldinfo list WW. That is, for each world seed S, ADJ(S) is set to a
-# worldinfo list containing the worlds within D (default 70) decilightyears
-# of S.
-
-proc adjacency {p adj {d 70}} {
- upvar 1 $adj a
- array set a {}
- foreach {s x y} $p {
- set done($s) 1
- lappend a($s)
- foreach {ss xx yy} $p {
- if {[info exists done($ss)]} { continue }
- if {abs($x - $xx) > $d + 10 || abs($y - $yy) > $d + 10 ||
- [world-distance $x $y $xx $yy] > $d} { continue }
- lappend a($s) $ss $xx $yy
- lappend a($ss) $s $x $y
- }
- }
-}
-
-# --- worldname W ---
-#
-# Returns the name of the world with seed W.
-
proc worldname {w} {
+ ## Returns the name of the world with seed W.
+
elite-worldinfo p $w
return $p(name)
}
-# --- shortest-path ADJ FROM TO WEIGHT ---
-#
-# Computes the shortest path and shortest distance between the worlds wose
-# seeds are FROM and TO respectively. ADJ must be an adjacency table for the
-# galaxy containing FROM and TO. WEIGHT is a command such that WEIGHT A B
-# returns the `distance' for the simple path between A and B. The return
-# value is a list P D, where D is the weight of the path found, and P is a
-# simple list of seeds for the worlds on the path. P starts with FROM and
-# ends with TO.
-
proc shortest-path {adjvar from to weight} {
+ ## Computes the shortest path and shortest distance between the worlds wose
+ ## seeds are FROM and TO respectively. ADJVAR must be the name of a
+ ## variable holding an adjacency table for the galaxy containing FROM and
+ ## TO. WEIGHT is a command such that WEIGHT A B returns the `distance' for
+ ## the simple path between A and B. The return value is a list P D, where
+ ## D is the weight of the path found, and P is a simple list of seeds for
+ ## the worlds on the path. P starts with FROM and ends with TO.
+
upvar 1 $adjvar adj
if {[string equal $from $to]} { return [list $to 0] }
set l($from) 0
}
}
-# --- weight-hops A B ---
-#
-# shortest-path weight function giving each hop the same weight.
-
proc weight-hops {from to} {
+ ## shortest-path weight function giving each hop the same weight.
return 1
}
-# --- weight-fuel A B ---
-#
-# shortest-path weight function measuring the distance between FROM and TO.
-
proc weight-fuel {from to} {
+ ## shortest-path weight function measuring the distance between FROM and
+ ## TO.
+
elite-worldinfo f $from
elite-worldinfo t $to
- return [world-distance $f(x) $f(y) $t(x) $t(y)]
+ return [elite-distance $f(x) $f(y) $t(x) $t(y)]
}
-# --- weight-safety A B ---
-#
-# shortest-path weight function attempting to maximize safety of the journey
-# by giving high weight (square-law) to worlds with unstable governments.
-
proc weight-safety {from to} {
+ ## shortest-path weight function attempting to maximize safety of the
+ ## journey by giving high weight (square-law) to worlds with unstable
+ ## governments.
+
elite-worldinfo t $to
set w [expr {8 - $t(government)}]
return [expr {$w * $w}]
}
-# --- weight-encounters A B ---
-#
-# shortest-path weight function attempting to maximize encounters on the
-# journey by giving high weight (square law) to worlds with stable
-# governments.
-
proc weight-encounters {from to} {
+ ## shortest-path weight function attempting to maximize encounters on the
+ ## journey by giving high weight (square law) to worlds with stable
+ ## governments.
+
elite-worldinfo f $from
elite-worldinfo t $to
set w [expr {1 + $t(government)}]
return [expr {$w * $w}]
}
-# --- weight-trading A B ---
-#
-# shortest-path weight function attempting to maximize trading opportunities
-# along the journey by giving high weight (square law) to pairs of worlds
-# with small differences between their economic statuses.
-
proc weight-trading {from to} {
+ ## shortest-path weight function attempting to maximize trading
+ ## opportunities along the journey by giving high weight (square law) to
+ ## pairs of worlds with small differences between their economic statuses.
+
elite-worldinfo f $from
elite-worldinfo t $to
set w [expr {8 - abs($f(economy) - $t(economy))}]
return [expr {$w * $w}]
}
-# --- parse-galaxy-spec G ---
-#
-# Parses a galaxy spec and returns a list containing a description of the
-# galaxy and the corresponding galaxy seed. A galaxy spec is one of:
-#
-# * a number between 1 and 8, corresponding to one of the standard
-# galaxies;
-#
-# * a 12-digit hex string, which is a galaxy seed (and is returned
-# unchanged); or
-#
-# * a string of the form S:N where S is a 12-hex-digit seed and N is a
-# galaxy number, corresponding to the Nth galaxy starting with S as
-# galaxy 1.
-#
-# If the string is unrecognized, an empty list is returned.
-
proc parse-galaxy-spec {g} {
+ ## Parses a galaxy spec and returns a list containing a description of the
+ ## galaxy and the corresponding galaxy seed. A galaxy spec is one of:
+ ##
+ ## * a number between 1 and 8, corresponding to one of the standard
+ ## galaxies;
+ ##
+ ## * a 12-digit hex string, which is a galaxy seed (and is returned
+ ## unchanged); or
+ ##
+ ## * a string of the form S:N where S is a 12-hex-digit seed and N is a
+ ## galaxy number, corresponding to the Nth galaxy starting with S as
+ ## galaxy 1.
+ ##
+ ## If the string is unrecognized, an empty list is returned.
+
switch -regexp -- $g {
{^[1-8]$} { return [list $g [galaxy $g]] }
{^[0-9a-fA-F]{12}$} { return [list $g $g] }
return {}
}
-# --- parse-planet-spec G P ---
-#
-# Parses a planet spec and returns the planet seed. The planet spec P is
-# interpreted relative to galaxy G. A planet spec is one of:
-#
-# * a simple integer, corresponding to a planet number;
-#
-# * a 12-hex-digit seed, which is returned unchanged;
-#
-# * a pair of integers separated by commas, corresponding to the nearest
-# planet to those coordinates;
-#
-# * a glob pattern, corresponding to the lowest-numbered planet in the
-# galaxy whose name matches the pattern case-insensitively; or
-#
-# * a string of the form G.P where G is a galaxy spec and P is a planet
-# spec, corresponding to the planet specified by P relative to galaxy G.
-#
-# If the string is unrecognized, an empty string is returned.
-
proc parse-planet-spec {g p} {
+ ## Parses a planet spec and returns the planet seed. The planet spec P is
+ ## interpreted relative to galaxy G. A planet spec is one of:
+ ##
+ ## * a simple integer, corresponding to a planet number;
+ ##
+ ## * a 12-hex-digit seed, which is returned unchanged;
+ ##
+ ## * a pair of integers separated by commas, corresponding to the nearest
+ ## planet to those coordinates;
+ ##
+ ## * a glob pattern, corresponding to the lowest-numbered planet in the
+ ## galaxy whose name matches the pattern case-insensitively; or
+ ##
+ ## * a string of the form G.P where G is a galaxy spec and P is a planet
+ ## spec, corresponding to the planet specified by P relative to galaxy
+ ## G.
+ ##
+ ## If the string is unrecognized, an empty string is returned.
+
if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
if {[regexp {^(.+)\.(.+)$} $p . g p]} {
set g [parse-galaxy-spec $g]
}
if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
$p . x y]} {
- return [nearest-planet [worldinfo $g] $x $y]
+ return [nearest-planet [elite-galaxylist $g] $x $y]
+ }
+ if {[regexp {^([^/]*)(?:/([1-9]\d*))?$} $p . p i]} {
+ if {[string equal $i ""]} { set i 1 }
+ set l [find-world $g $p]
+ if {$i <= [llength $l]} { return [lindex $l [expr {$i - 1}]] }
}
- set l [find-world $g $p]
- if {[llength $l]} { return [lindex $l 0] }
return {}
}
-# --- in-galaxy-p G PP ---
-#
-# Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
-# Doesn't mind if the planet seeds are invalid.
-
proc in-galaxy-p {g pp} {
+ ## Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
+ ## Doesn't mind if the planet seeds are invalid.
+
foreach-world $g i { set x($i(seed)) 1 }
foreach p $pp { if {![info exists x($p)]} { return 0 } }
return 1
}
-# --- world-summary PLANET ---
-#
-# Return a one-line summary string for PLANET.
+proc world-summary {s {ind 0} {spc 0}} {
+ ## Return a one-line summary string for planet S. IND and SPC are numbers
+ ## of additional spaces to insert at the start of the line and after the
+ ## planet name, respectively.
-proc world-summary {s} {
global eco gov
elite-worldinfo p $s
- return [format "%-12s %4d %4d %-11s %-10s %2d %s" \
- $p(name) $p(x) $p(y) \
+ set is [string repeat " " $ind]
+ set ss [string repeat " " $spc]
+ return [format "%s%-8s%s %4d %4d %-11s %-10s %2d %s" \
+ $is $p(name) $ss $p(x) $p(y) \
$eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
}
-# --- jameson ARR ---
-#
-# Fill ARR with the information about commander JAMESON.
+proc world-brief {s} {
+ ## Return a very brief summary string for planet S.
+
+ global gv ec
+ elite-worldinfo p $s
+ return [format "%-8s (%s, %s, %2d)" \
+ $p(name) $ec($p(economy)) $gv($p(government)) $p(techlevel)]
+}
proc jameson {arr} {
+ ## Fill ARR with the information about commander JAMESON.
+
global galaxy1 products
upvar 1 $arr cmdr
array set cmdr {
- mission 0
- credits 1000
- fuel 70
- gal-number 1
- front-laser 0x0f
- rear-laser 0
- left-laser 0
- right-laser 0
- cargo 20
- missiles 3
+ mission 0
+ credits 1000
+ fuel 70
+ gal-number 1
+ front-laser 0x0f
+ rear-laser 0
+ left-laser 0
+ right-laser 0
+ cargo 20
+ missiles 3
legal-status 0
- score 0
- market-fluc 0
+ score 0
+ market-fluc 0
}
set cmdr(gal-seed) $galaxy1
foreach i {
set cmdr(station-alien-items) 0
}
-#----- That's all, folks ----------------------------------------------------
+###----- That's all, folks --------------------------------------------------
-package provide "elite" "1.0.0"
+package provide "elite" "1.0.1"
~mdw / rocl / blobdiff