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

   1 #! /usr/bin/tclsh
   2 #
   3 # $Id: elite.tcl,v 1.5 2003/03/04 10:26:47 mdw Exp $
   4
   5 package require "elite-bits" "1.0.0"
   6
   7 set 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
  13 proc 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
  24 tab government \
  25     "anarchy" "feudal" "multi-government" "dictatorship" \
  26     "communist" "confederacy" "democracy" "corporate state"
  27
  28 tab economy \
  29     "rich industrial" "average industrial" "poor industrial" \
  30     "mainly industrial" "mainly agricultural" "rich agricultural" \
  31     "average agricultural" "poor agricultural"
  32
  33 tab gov \
  34     anarchy feudal multi-gov dictator \
  35     communist confed democracy corp-state
  36
  37 tab eco \
  38     rich-ind avg-ind poor-ind mainly-ind \
  39     mainly-agri rich-agri avg-agri poor-agri
  40
  41 set 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
  61 foreach p $products { set unit($p) t }
  62 foreach p {gold platinum} { set unit($p) kg }
  63 set unit(gem-stones) g
  64 unset 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
  71 proc 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
  84 proc 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
  97 proc 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
 116 proc 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
 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
 137 proc 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
 161 proc 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
 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
 175 proc 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
 187 proc 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
 198 proc 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
 223 proc 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
 243 proc 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
 258 proc 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
 298 proc 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
 306 proc weight-fuel {from to} {
 307   elite-worldinfo f $from
 308   elite-worldinfo t $to
 309   return [expr {[world-distance $f(x) $f(y) $t(x) $t(y)]/10.0}]
 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
 317 proc 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
 329 proc 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
 342 proc 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
 366 proc 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
 399 proc 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
 425 proc 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
 435 proc world-summary {s} {
 436   global eco gov
 437   elite-worldinfo p $s
 438   return [format "%-8s %4d %4d %-11s %-10s %2d %s" \
 439       $p(name) $p(x) $p(y) \
 440       $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)]
 441 }
 442
 443 # --- jameson ARR ---
 444 #
 445 # Fill ARR with the information about commander JAMESON.
 446
 447 proc 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
 481 #----- That's all, folks ----------------------------------------------------
 482
 483 package provide "elite" "1.0.0"