chiark - git - mdw - rocl/blob - elite.tcl

   1 ### -*-tcl-*-
   2 ###
   3 ### Common Elite hacking functions
   4 ###
   5 ### (c) 2003 Mark Wooding
   6 ###
   7
   8 ###----- Licensing notice ---------------------------------------------------
   9 ###
  10 ### This program is free software; you can redistribute it and/or modify
  11 ### it under the terms of the GNU General Public License as published by
  12 ### the Free Software Foundation; either version 2 of the License, or
  13 ### (at your option) any later version.
  14 ###
  15 ### This program is distributed in the hope that it will be useful,
  16 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ### GNU General Public License for more details.
  19 ###
  20 ### You should have received a copy of the GNU General Public License
  21 ### along with this program; if not, write to the Free Software Foundation,
  22 ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 package require "elite-bits" "1.0.1"
  25
  26 ###--------------------------------------------------------------------------
  27 ### Internal utilities.
  28
  29 proc _tab {arr args} {
  30   ## _tab ARR NAME NAME ... ---
  31   ##
  32   ## Construct an array mapping integers 0, 1, ... to the given NAMEs, in
  33   ## order.
  34
  35   upvar 1 $arr a
  36   set i 0
  37   foreach v $args {
  38     set a($i) $v
  39     incr i
  40   }
  41 }
  42
  43 ###--------------------------------------------------------------------------
  44 ### Magic constants and tables.
  45
  46 set galaxy1 "4a5a480253b7"              ;# Seed for standard galaxy 1
  47
  48 ## Government types.
  49 _tab government \
  50     "anarchy" "feudal" "multi-government" "dictatorship" \
  51     "communist" "confederacy" "democracy" "corporate state"
  52
  53 ## Economy types.
  54 _tab economy \
  55     "rich industrial" "average industrial" "poor industrial" \
  56     "mainly industrial" "mainly agricultural" "rich agricultural" \
  57     "average agricultural" "poor agricultural"
  58
  59 ## Abbreviated government types.
  60 _tab gov \
  61     anarchy feudal multi-gov dictator \
  62     communist confed democracy corp-state
  63
  64 ## Abbreviated economy types.
  65 _tab eco \
  66     rich-ind avg-ind poor-ind mainly-ind \
  67     mainly-agri rich-agri avg-agri poor-agri
  68
  69 ## Two-letter government and economy types.
  70 _tab gv Ay Fl MG Dp Ct Cy Dy CS
  71 _tab ec RI AI PI MI MA RA AA PA
  72
  73 ## Products for trading.
  74 set products {
  75   food          "Food"
  76   textiles      "Textiles"
  77   radioactives  "Radioactives"
  78   slaves        "Slaves"
  79   liquor-wines  "Liquor & wines"
  80   luxuries      "Luxuries"
  81   narcotics     "Narcotics"
  82   computers     "Computers"
  83   machinery     "Machinery"
  84   alloys        "Alloys"
  85   firearms      "Firearms"
  86   furs          "Furs"
  87   minerals      "Minerals"
  88   gold          "Gold"
  89   platinum      "Platinum"
  90   gem-stones    "Gem-stones"
  91   alien-items   "Alien items"
  92 }
  93
  94 foreach p $products { set unit($p) t }
  95 foreach p {gold platinum} { set unit($p) kg }
  96 set unit(gem-stones) g
  97 unset p
  98
  99 ###--------------------------------------------------------------------------
 100 ### External functions.
 101
 102 proc galaxy [list n [list g $galaxy1]] {
 103   ## Compute the seed of the Nth galaxy, if G is the seed of galaxy 1.  By
 104   ## default, G is the standard galaxy 1 seed.
 105
 106   for {set i 1} {$i < $n} {incr i} {
 107     set g [elite-nextgalaxy $g]
 108   }
 109   return $g
 110 }
 111
 112 proc foreach-world {g p act} {
 113   ## For each world in galaxy G (a seed), set P to the world information and
 114   ## evaluate ACT.  The usual loop control commands can be used in ACT.
 115   upvar 1 $p pp
 116   for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} {
 117     elite-worldinfo pp $g
 118     uplevel 1 $act
 119   }
 120 }
 121
 122 proc find-world {g pat} {
 123   ## Return a list of seeds for the worlds in galaxy G (a seed) whose names
 124   ## match the glob pattern PAT.
 125
 126   set l {}
 127   foreach-world $g p {
 128     if {[string match -nocase $pat $p(name)]} {
 129       lappend l $p(seed)
 130     }
 131   }
 132   return $l
 133 }
 134
 135 proc destructure {pp xx} {
 136   ## Destrcture an object XX according to the pattern PP.  If PP is a single
 137   ## name, set the variable PP to XX; otherwise, if PP is a list, each of its
 138   ## elements must correspond to an element of the list XX, so recursively
 139   ## destructure the corresponding elements of each.  It is not an error if
 140   ## the PP list is shorter than XX.  The special variable name `.' indicates
 141   ## that no assignment is to be made.
 142
 143   if {![string compare $pp "."]} {
 144     return
 145   } elseif {[llength $pp] == 0} {
 146     return
 147   } elseif {[llength $pp] == 1} {
 148     upvar 1 $pp p
 149     set p $xx
 150   } else {
 151     foreach p $pp x $xx {
 152       uplevel 1 [list destructure $p $x]
 153     }
 154   }
 155 }
 156
 157 proc write-file {name contents {trans binary}} {
 158   ## Write file NAME, storing CONTENTS translated according to TRANS (default
 159   ## `binary'.  The write is safe against errors -- we don't destroy the old
 160   ## data until the file is written.
 161
 162   if {[file exists $name]} {
 163     if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
 164       return -code $rc $err
 165     }
 166   }
 167   if {[set rc [catch {
 168     set f [open $name w]
 169     fconfigure $f -translation $trans
 170     puts -nonewline $f $contents
 171     close $f
 172   } err]]} {
 173     catch { close $f }
 174     catch { file rename -force "$name.old" $name }
 175     return -code $rc $err
 176   }
 177   return ""
 178 }
 179
 180 proc read-file {name {trans binary}} {
 181   ## Read the contents of the file NAME, translating it according to TRANS
 182   ## (default `binary').
 183
 184   set f [open $name]
 185   fconfigure $f -translation $trans
 186   set c [read $f]
 187   close $f
 188   return $c
 189 }
 190
 191 proc nearest-planet {ww x y} {
 192   ## Returns the seed of the `nearest' planet given in the worldinfo list WW
 193   ## to the point X Y (in decilightyears).
 194
 195   set min 10000
 196   foreach {ss xx yy} $ww {
 197     set dx [expr {abs($x - $xx)/4}]
 198     set dy [expr {abs($y - $yy)/2}]
 199     if {$dx > $dy} {
 200       set d [expr {($dx * 2 + $dy)/2}]
 201     } else {
 202       set d [expr {($dx + $dy * 2)/2}]
 203     }
 204     if {$d < $min} {
 205       set p $ss
 206       set min $d
 207     }
 208   }
 209   return $p
 210 }
 211
 212 proc worldname {w} {
 213   ## Returns the name of the world with seed W.
 214
 215   elite-worldinfo p $w
 216   return $p(name)
 217 }
 218
 219 proc shortest-path {adjvar from to weight} {
 220   ## Computes the shortest path and shortest distance between the worlds wose
 221   ## seeds are FROM and TO respectively.  ADJVAR must be the name of a
 222   ## variable holding an adjacency table for the galaxy containing FROM and
 223   ## TO.  WEIGHT is a command such that WEIGHT A B returns the `distance' for
 224   ## the simple path between A and B.  The return value is a list P D, where
 225   ## D is the weight of the path found, and P is a simple list of seeds for
 226   ## the worlds on the path.  P starts with FROM and ends with TO.
 227
 228   upvar 1 $adjvar adj
 229   if {[string equal $from $to]} { return [list $to 0] }
 230   set l($from) 0
 231   set p($from) $from
 232   set c $from
 233   while 1 {
 234     foreach {n x y} $adj($c) {
 235       if {[info exists l($n)]} {
 236         continue
 237       }
 238       set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}]
 239       if {![info exists ll($n)] || $w < $ll($n)} {
 240         set ll($n) $w
 241         set p($n) [concat $p($c) [list $n]]
 242       }
 243     }
 244     set s [array startsearch ll]
 245     if {![array anymore ll $s]} {
 246       return {{} 0}
 247     }
 248     set c [array nextelement ll $s]
 249     set w $ll($c)
 250     while {[array anymore ll $s]} {
 251       set n [array nextelement ll $s]
 252       if {$ll($n) < $w} {
 253         set c $n
 254         set w $ll($n)
 255       }
 256     }
 257     if {[string equal $c $to]} { return [list $p($to) $ll($to)] }
 258     set l($c) $ll($c)
 259     unset ll($c)
 260   }
 261 }
 262
 263 proc weight-hops {from to} {
 264   ## shortest-path weight function giving each hop the same weight.
 265   return 1
 266 }
 267
 268 proc weight-fuel {from to} {
 269   ## shortest-path weight function measuring the distance between FROM and
 270   ## TO.
 271
 272   elite-worldinfo f $from
 273   elite-worldinfo t $to
 274   return [elite-distance $f(x) $f(y) $t(x) $t(y)]
 275 }
 276
 277 proc weight-safety {from to} {
 278   ## shortest-path weight function attempting to maximize safety of the
 279   ## journey by giving high weight (square-law) to worlds with unstable
 280   ## governments.
 281
 282   elite-worldinfo t $to
 283   set w [expr {8 - $t(government)}]
 284   return [expr {$w * $w}]
 285 }
 286
 287 proc weight-encounters {from to} {
 288   ## shortest-path weight function attempting to maximize encounters on the
 289   ## journey by giving high weight (square law) to worlds with stable
 290   ## governments.
 291
 292   elite-worldinfo f $from
 293   elite-worldinfo t $to
 294   set w [expr {1 + $t(government)}]
 295   return [expr {$w * $w}]
 296 }
 297
 298 proc weight-trading {from to} {
 299   ## shortest-path weight function attempting to maximize trading
 300   ## opportunities along the journey by giving high weight (square law) to
 301   ## pairs of worlds with small differences between their economic statuses.
 302
 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 proc parse-galaxy-spec {g} {
 310   ## Parses a galaxy spec and returns a list containing a description of the
 311   ## galaxy and the corresponding galaxy seed.  A galaxy spec is one of:
 312   ##
 313   ##   * a number between 1 and 8, corresponding to one of the standard
 314   ##     galaxies;
 315   ##
 316   ##   * a 12-digit hex string, which is a galaxy seed (and is returned
 317   ##     unchanged); or
 318   ##
 319   ##   * a string of the form S:N where S is a 12-hex-digit seed and N is a
 320   ##     galaxy number, corresponding to the Nth galaxy starting with S as
 321   ##     galaxy 1.
 322   ##
 323   ## If the string is unrecognized, an empty list is returned.
 324
 325   switch -regexp -- $g {
 326     {^[1-8]$} { return [list $g [galaxy $g]] }
 327     {^[0-9a-fA-F]{12}$} { return [list $g $g] }
 328     default {
 329       if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} {
 330         return [list $g [galaxy $n $b]]
 331       }
 332     }
 333   }
 334   return {}
 335 }
 336
 337 proc parse-planet-spec {g p} {
 338   ## Parses a planet spec and returns the planet seed.  The planet spec P is
 339   ## interpreted relative to galaxy G.  A planet spec is one of:
 340   ##
 341   ##   * a simple integer, corresponding to a planet number;
 342   ##
 343   ##   * a 12-hex-digit seed, which is returned unchanged;
 344   ##
 345   ##   * a pair of integers separated by commas, corresponding to the nearest
 346   ##     planet to those coordinates;
 347   ##
 348   ##   * a glob pattern, corresponding to the lowest-numbered planet in the
 349   ##     galaxy whose name matches the pattern case-insensitively; or
 350   ##
 351   ##   * a string of the form G.P where G is a galaxy spec and P is a planet
 352   ##     spec, corresponding to the planet specified by P relative to galaxy
 353   ##     G.
 354   ##
 355   ## If the string is unrecognized, an empty string is returned.
 356
 357   if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p }
 358   if {[regexp {^(.+)\.(.+)$} $p . g p]} {
 359     set g [parse-galaxy-spec $g]
 360     if {[string equal $g ""]} { return {} }
 361     destructure {. g} $g
 362     return [parse-planet-spec $g $p]
 363   }
 364   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} {
 365     for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {}
 366     return $s
 367   }
 368   if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+),\s*(0x[0-9a-fA-F]+|[0-9]+)$} \
 369       $p . x y]} {
 370     return [nearest-planet [elite-galaxylist $g] $x $y]
 371   }
 372   if {[regexp {^([^/]*)(?:/([1-9]\d*))?$} $p . p i]} {
 373     if {[string equal $i ""]} { set i 1 }
 374     set l [find-world $g $p]
 375     if {$i <= [llength $l]} { return [lindex $l [expr {$i - 1}]] }
 376   }
 377   return {}
 378 }
 379
 380 proc in-galaxy-p {g pp} {
 381   ## Returns nonzero if the planets (seeds) listed in PP are in galaxy G.
 382   ## Doesn't mind if the planet seeds are invalid.
 383
 384   foreach-world $g i { set x($i(seed)) 1 }
 385   foreach p $pp { if {![info exists x($p)]} { return 0 } }
 386   return 1
 387 }
 388
 389 proc world-summary {s {ind 0} {spc 0}} {
 390   ## Return a one-line summary string for planet S.  IND and SPC are numbers
 391   ## of additional spaces to insert at the start of the line and after the
 392   ## planet name, respectively.
 393
 394   global eco gov
 395   elite-worldinfo p $s
 396   set is [string repeat " " $ind]
 397   set ss [string repeat " " $spc]
 398   return [format "%s%-8s%s %4d %4d %-11s %-10s %2d %s" \
 399       $is $p(name) $ss $p(x) $p(y) \
 400       $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
 401 }
 402
 403 proc world-brief {s} {
 404   ## Return a very brief summary string for planet S.
 405
 406   global gv ec
 407   elite-worldinfo p $s
 408   return [format "%-8s (%s, %s, %2d)" \
 409               $p(name) $ec($p(economy)) $gv($p(government)) $p(techlevel)]
 410 }
 411
 412 proc jameson {arr} {
 413   ## Fill ARR with the information about commander JAMESON.
 414
 415   global galaxy1 products
 416   upvar 1 $arr cmdr
 417   array set cmdr {
 418     mission           0
 419     credits        1000
 420     fuel             70
 421     gal-number        1
 422     front-laser    0x0f
 423     rear-laser        0
 424     left-laser        0
 425     right-laser       0
 426     cargo            20
 427     missiles          3
 428     legal-status      0
 429     score             0
 430     market-fluc       0
 431   }
 432   set cmdr(gal-seed) $galaxy1
 433   foreach i {
 434     ecm fuel-scoop energy-bomb energy-unit docking-computer
 435     gal-hyperdrive escape-pod
 436   } { set cmdr($i) 0 }
 437   elite-worldinfo lave [find-world $galaxy1 "Lave"]
 438   set cmdr(world-x) [expr {$lave(x)/4}]
 439   set cmdr(world-y) [expr {$lave(y)/2}]
 440   elite-market mkt $lave(seed) 0
 441   foreach {t n} $products {
 442     destructure [list . cmdr(station-$t)] $mkt($t)
 443     set cmdr(hold-$t) 0
 444   }
 445   set cmdr(station-alien-items) 0
 446 }
 447
 448 ###----- That's all, folks --------------------------------------------------
 449
 450 package provide "elite" "1.0.1"