X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/rocl/blobdiff_plain/e93bc0bd3227e7274d5e16cb97b1df04d41acf40..378b623cd2af34d37c8cee518bec145f1f92a0d2:/elite.tcl

diff --git a/elite.tcl b/elite.tcl
index fa81e4c..fa55eea 100644
--- a/elite.tcl
+++ b/elite.tcl
@@ -1,16 +1,37 @@
-#! /usr/bin/tclsh
-#
-# $Id: elite.tcl,v 1.5 2003/03/04 10:26:47 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 {
@@ -19,25 +40,37 @@ proc tab {arr 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"
@@ -63,38 +96,33 @@ foreach p {gold platinum} { set unit($p) kg }
 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)]} {
@@ -104,16 +132,14 @@ proc find-world {g pat} {
   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} {
@@ -128,13 +154,11 @@ proc destructure {pp xx} {
   }
 }
 
-# --- 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
@@ -153,12 +177,10 @@ proc write-file {name contents {trans binary}} {
   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]
@@ -166,36 +188,10 @@ proc read-file {name {trans binary}} {
   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}]
@@ -213,49 +209,22 @@ proc nearest-planet {ww x y} {
   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
@@ -291,79 +260,68 @@ proc shortest-path {adjvar from to weight} {
   }
 }
 
-# --- 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 [expr {[world-distance $f(x) $f(y) $t(x) $t(y)]/10.0}]
+  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] }
@@ -376,27 +334,26 @@ proc parse-galaxy-spec {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]
@@ -410,57 +367,67 @@ proc parse-planet-spec {g p} {
   }
   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 "%-8s %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 {
@@ -478,6 +445,6 @@ proc jameson {arr} {
   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"