X-Git-Url: https://git.distorted.org.uk/~mdw/rocl/blobdiff_plain/7da7c511de7c7655734ed685c3e2293b09386d2e..refs/heads/master:/elite.tcl

diff --git a/elite.tcl b/elite.tcl
index 127d72c..8da3279 100644
--- a/elite.tcl
+++ b/elite.tcl
@@ -1,16 +1,37 @@
-#! /usr/bin/tclsh
-#
-# $Id: elite.tcl,v 1.6 2003/03/07 00:44:57 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"
 
-set galaxy1 "4a5a480253b7"		;# Seed for standard galaxy 1
+###--------------------------------------------------------------------------
+### Internal utilities.
 
-# --- tab ARR NAME NAME ... ---
-#
-# Construct an array mapping integers 0, 1, ... to the given NAMEs, in order.
+proc _tab {arr args} {
+  ## _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.
+
+set galaxy1 "4a5a480253b7"		;# Seed for standard galaxy 1
 
-tab government \
+## 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,12 +188,10 @@ proc read-file {name {trans binary}} {
   return $c
 }
 
-# --- 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}]
@@ -189,26 +209,22 @@ proc nearest-planet {ww x y} {
   return $p
 }
 
-# --- 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
@@ -244,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 [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] }
@@ -329,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]
@@ -373,22 +377,20 @@ proc parse-planet-spec {g p} {
   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.
+
   global eco gov
   elite-worldinfo p $s
   set is [string repeat " " $ind]
@@ -398,27 +400,34 @@ proc world-summary {s {ind 0} {spc 0}} {
       $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 {
@@ -436,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.1"