From 1304202ad2001c85d3eae3a37c51e001794c24c8 Mon Sep 17 00:00:00 2001 Message-Id: <1304202ad2001c85d3eae3a37c51e001794c24c8.1714621907.git.mdw@distorted.org.uk> From: Mark Wooding Date: Mon, 24 Feb 2003 01:13:12 +0000 Subject: [PATCH] Initial import. Organization: Straylight/Edgeware From: mdw --- .cvsignore | 4 + Makefile | 66 +++ README | 293 ++++++++++++ elite-describe | 57 +++ elite-editor | 1208 ++++++++++++++++++++++++++++++++++++++++++++++++ elite-find | 71 +++ elite-map | 183 ++++++++ elite-pairs | 84 ++++ elite-path | 86 ++++ elite-prices | 58 +++ elite-reach | 84 ++++ elite.c | 856 ++++++++++++++++++++++++++++++++++ elite.def | 3 + elite.tcl | 405 ++++++++++++++++ 14 files changed, 3458 insertions(+) create mode 100644 .cvsignore create mode 100644 Makefile create mode 100644 README create mode 100755 elite-describe create mode 100755 elite-editor create mode 100755 elite-find create mode 100755 elite-map create mode 100755 elite-pairs create mode 100755 elite-path create mode 100755 elite-prices create mode 100755 elite-reach create mode 100644 elite.c create mode 100644 elite.def create mode 100644 elite.tcl diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..75593fa --- /dev/null +++ b/.cvsignore @@ -0,0 +1,4 @@ +elite.so +pkgIndex.tcl +rocl-1.0.0.tar.gz +elite.o diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..83c1977 --- /dev/null +++ b/Makefile @@ -0,0 +1,66 @@ +# Makefile for RIGHT ON COMMAND-LINE + +#----- Configuration stuff -------------------------------------------------- + +# --- Compiling and linking --- + +CC = gcc +INCLUDES = +CFLAGS = -O2 -g -pedantic -Wall $(INCLUDES) +LD = gcc +LDFLAGS = -shared + +# --- Installation --- + +INST = +prefix = /usr/local +tcllibdir = $(prefix)/lib +pkglibdir = $(tcllibdir)/elite +bindir = $(prefix)/bin + +INSTALL = install +RM = rm + +#----- Main machinery ------------------------------------------------------- +# +# Shouldn't need to fiddle with thiis stuff. + +PACKAGE = rocl +VERSION = 1.0.0 + +TCLSCRIPTS = \ + elite-editor elite-pairs elite-path elite-find elite-map \ + elite-prices elite-describe elite-reach + +all: elite.so pkgIndex.tcl + +elite.so: elite.o + $(LD) $(LDFLAGS) elite.o -o elite.so + +.SUFFIXES: .c .o +.c.o:; $(CC) -c $(CFLAGS) -o $@ $< + +pkgIndex.tcl: elite.so elite.tcl + echo "pkg_mkIndex -verbose -direct . elite.so elite.tcl" | tclsh + +install: all + $(INSTALL) -d $(INST)$(bindir) $(INST)$(pkglibdir) + $(INSTALL) -m 644 elite.so elite.tcl pkgIndex.tcl $(INST)$(pkglibdir) + $(INSTALL) -m 755 $(TCLSCRIPTS) $(INST)$(bindir) + +clean: + $(RM) -f elite.o elite.so pkgIndex.tcl + +DISTDIR = $(PACKAGE)-$(VERSION) +DISTFILES = README Makefile elite.c elite.def $(TCLSCRIPTS) +distdir: $(DISTFILES) + $(RM) -rf $(DISTDIR) + mkdir $(DISTDIR) + for i in $(DISTFILES); do ln -s ../$$i $(DISTDIR); done +dist: distdir + tar chofz $(DISTDIR).tar.gz $(DISTDIR) + $(RM) -rf $(DISTDIR) + +.PHONY: all install clean dist distdir + +#----- That's all, folks ---------------------------------------------------- diff --git a/README b/README new file mode 100644 index 0000000..690dcbc --- /dev/null +++ b/README @@ -0,0 +1,293 @@ +RIGHT ON COMMAND-LINE + Elite tools for the discerning player + +1. Installation + + You need a C compiler and a working Tcl/Tk installation. (The + elite-editor program needs Tk; the rest of the tools don't.) + The Makefile works on my Debian GNU/Linux box, but I'm not + making any promises about anyone else's. I've successfully + built earlier versions of everything under Cygwin, against + ActiveState's Tcl 8.4, but I've forgotten the Holy Runes. I do + have the `.def' file I used to build the DLL, though, for + whatever that's worth. (If you want to hack the Makefile to + work under Windows, I'll take a patch.) + + The theory is that you should edit the Makefile for your system + and say `make'; then, as some suitably privileged person, say + `make install' and stand well back. Everything should then be + installed. + + In practice: + + * If you can't build `pkgIndex.tcl', run `tclsh' and say + + % pkg_mkIndex -verbose -direct . elite.so elite.tcl + + to it. (Use `elite.dll' if you're on Windows.) Say + + % set tcl_pkgPath + + to see a list of suitable places for putting the kit. Pick + one. The directory `/usr/local/lib' appears in my + installation, so that's what I use. + + * Make a subdirectory in the place you chose, and copy + `elite.so', `elite.tcl' and `pkgIndex.tcl' into it. All + should now be hunky-dory. + + * Run (say) `elite-describe lave' to check that things are set + up properly. + + +2. The command-line tools + + A `galaxy-spec' is + + * a number, between 1 and 8, for one of the standard eight + galaxies; + + * a `galaxy seed' of 12 hex digits (a 48-bit value), for any + arbitrary galaxy; or + + * a string `SEED:N' where SEED is a galaxy seed and N is a + number between 1 and 8, for the Nth galaxy in some custom + universe. + + A `planet-spec' is interpreted relative to some parent galaxy. + It may be + + * a number N, for the Nth planet in the galaxy (planets are + numbered pseudorandomly -- this is not often a helpful + option); + + * a `planet seed' of 12 hex digits (a 48-bit value), for any + arbitrary planet; + + * a pair of numbers `X,Y', for the planet nearest the point X + decilightyears rightwards and T decilightyears down from the + top left of the galaxy; + + * a glob pattern (a string containing `*' and `?' wildcards, + matching any substring or any single character, + respectively), for the first planet whose name matches the + pattern; or + + * a string `GAL:P', where GAL is a galaxy-spec and P is a + planet-spec, for the planet P in galaxy GAL. + + + elite-describe [-g GAL] PLANET ... + + For each PLANET, print the planet data for that PLANET. The + PLANETs are interpreted relative to GAL, or standard galaxy 1 if + GAL is not specified. + + + elite-map [-qv] [-g GALAXY] [-d DIST] [-w WD,HT] [-a ASP] [PLANET] + + Prints a map of (part of) a galaxy to the terminal. + + If PLANET is specified (which it usually is), a map of the area + around PLANET in GALAXY (default standard galaxy 1) is printed, + showing other planets within DIST lightyears (default 7) of + PLANET. + + If PLANET is not specified, the entire galaxy is printed. This + is usually unhelpful. + + Planets are shown as numbers or letters. The home PLANET is + shown as a `*'. Below the map is printed a key describing the + planets in a strict left-to-right top-to-bottom order. + + The size of the map may be controlled by the -w option -- set WD + to the maximum allowable width, and HT to the maximum allowable + height (in columns and rows, respectively). The map will be + scaled so as to fit. The -a option sets the aspect ratio of + your characters, height to width (the default is about 2, and + seems right for viewing in an xterm with the standard fixed + font). + + + elite-path [-g GALAXY] [-w WEIGHT] PLANET PLANET ... + + Computes a route through a GALAXY (default is standard galaxy + 1), starting at the first PLANET listed, via the second, via the + third, etc., and ending at the last. For each planet you're + meant to stop at on the way, a summary line is printed giving + the planet's name, position, government type, economy type and + tech level. + + You can affect how elite-path selects its routes using the `-w' + option. The default is to minimize the number of hops. Other + possibilities are: + + hops Minimize number of hops. This is the default. + + safety Maximize stability of the planets in the route, + to attempt to improve safety. Useful during the + early stages of the game. + + encounters The opposite of `safety' -- minimizes stability + of planets in the route. Useful if you want to + maximize kills. + + trading Maximize the difference in economy type between + successive planets in the route. This should + give you an opportunity to make a good profit as + you go. + + fuel Minimize absolute distance. For those on a + tight budget. + + + elite-reach [-d DIST] [GALAXY ...] + + For each GALAXY (default is the 8 standard ones), print summary + information for each planet, with blank lines separating + disconnected groups of planets, i.e., groups where a ship + capable of travelling DIST lightyears (default 7) can't get from + one to the other. + + + elite-find [-g GALAXY] [EXPR] + + Without EXPR, simply prints summary information for each planet + in GALAXY (default standard 1). + + If EXPR is specified, it must be a Tcl expression (as for the + `expr' command). Information is printed for each planet for + which EXPR returns nonzero. The EXPR may use the following + variables: + + name The planet name, with initial capital letter. + + x, y X and Y coordinates, from top left, in + decilightyears. + + economy From 0 (rich industrial) to 7 (poor + agricultural). + + government From 0 (anarchy) to 7 (corporate state). + + techlevel From 1 to 15. + + radius In kilometres. + + productivity In millions of credits. + + population In hundreds of millions. + + inhabitants A Tcl list of words describing the inhabitants. + + description As a Tcl list of words. + + + elite-pairs [-g GALAXY] [-d DIST] AEXPR BEXPR + + Prints the names of pairs of planets A and B in GALAXY (default + standard 1), no further than DIST (default 7) lightyears apart, + such that AEXPR returns nonzero for planet A and BEXPR returns + nonzero for planet B. + + The expressions AEXPR and BEXPR may use the same variables as + for elite-find. In addition, BEXPR may use + + d The distance between planets A and B. + + a An array containing the information about planet + A. The indices have the same names and meanings + as the variables described above. + + +3. The graphical editor + + elite-editor [GALAXY | FILE] + + Starts the RIGHT ON COMMAND-LINE Commander Editor and Map. This + is a Tk program -- you'll need that installed to run it. + + I'll not go into excruciating detail about how to work the + program. It's fairly simple, really. + + The map view lets you colour-code planets according to + techlevel, government or economy. The colours ought to be as + follows: + + Colour Government Economy Techlevel + + Red Anarchy Poor agri 1 + Orange Feudal Average agri 2 or 3 + Yellow Multi-gov Rich agri 4 or 5 + Green Dictatorship Mainly agri 6 or 7 + Blue Communist Mainly indust 8 or 9 + Magenta Confederacy Poor indust 10 or 11 + Violet Democracy Average indust 12 or 13 + White Corporate Rich indust 14 or 15 + + The connectivity map shows how you can get around the galaxy + using hops of up to 7 light years. + + Planet names are unhelpful except at small scales. The + placement algorithm could do with a lot of work. + + Clicking on the map with button 1 (usually the left one) sets + the destination world, marked with an orange cross. Clicking + with button 3 (usually the right one) sets the home world, + marked with a red cross, and with a green hyperspace-range + circle around it. (The circle doesn't actually correspond + exactly with hyperspace reachability, because there are rounding + errors in the distance computation. ROCL correctly emulates the + rounding errors from the original game.) + + Double-clicking opens a window showing information about a + planet. Two info windows can be open at any time, one for the + home world and one for the destination. + + The bar along the bottom of the map window shows the names of + the home and destination worlds, and the distance between them. + You can type new names (or any old planet spec) into either to + select different planets. The change will take place when you + press return or when the input focus moves. + + The `Compute path' lets you do the same kinds of computations as + the elite-path tool. It plots a route from the home to the + destination. The path is shown in orange on the map. + + The commander editor should be self-explanatory, but maybe a few + pointers might be helpful. + + The entry fields for items with pop-up menus are disabled when + the menus show values other than `Custom', so you must first + choose `Custom' from the menu if you want a fancy value. + + The `Show galaxy map' button opens a map which will be tied to + the commander window. When you select a home world (button 3), + this will set the world where the commander will start. Note + that the market prices (in the `Cargo' window) update + automatically as you move about the universe. It is quite + possible to travel about entirely new universes by turning off + the `Standard galaxy' button and typing some hex number into the + `Galaxy seed' box. All of the ROCL tools work in these custom + universes. Note that your docked planet is recorded as an x, y + coordinate pair, so Elite can't tell which of two coincident + planets you're docked at (yes, there are such pairs). ROCL + won't cope with this at the moment. + + Lasers are a bit odd. Bit 7 is a `rapid-fire' bit. It doesn't + affect the strength of the laser, but means that there's no + delay between shots. The low 7 bits control the strength, but + without the rapid-fire bit, powerful lasers will tend to fire + more slowly than weak ones. Some comparisons in the program are + for exact laser power: you can't damage the Constrictor or + Cougar ships unless you have military (or 0x17 slow-firing) + lasers; and you can't fragment asteroids unless you have mining + or 0xb2 rapid-fire lasers. (The 0xb2's pack a serious punch. I + recommend them as an upgrade for commanders who don't wish to + cheat completely.) + + + +Local variables: +mode: text +End: diff --git a/elite-describe b/elite-describe new file mode 100755 index 0000000..1c0c774 --- /dev/null +++ b/elite-describe @@ -0,0 +1,57 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +proc describe n { + global economy government + elite-worldinfo p $n + puts "Name: $p(name)" + puts "Position: $p(x), $p(y) LY" + puts "Economy: $economy($p(economy))" + puts "Government: $government($p(government))" + puts "Tech. level: $p(techlevel)" + puts [format "Population: %s billion (%s)" \ + [expr {$p(population)/10.0}] $p(inhabitants)] + puts "Gross productivity: $p(productivity) M Cr" + puts "Radius: $p(radius) km" + puts "" + set ll {} + set l 0 + foreach w $p(description) { + incr l + incr l [string length $w] + if {$l > 72} { puts $ll; set ll {}; set l 0 } + lappend ll $w + } + puts $ll +} + +if {[llength $argv] < 1} { + puts stderr "usage: $argv0 \[-g GALAXY\] PLANET ..." + exit 1 +} +set g $galaxy1 +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -- $a { + "-g" { + incr i + set a [lindex $argv $i] + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy string `$a'" + exit 1 + } + destructure {. g} $g + } + default { + set n [parse-planet-spec $g $a] + if {[string equal $n ""]} { + puts stderr "$argv0: unknown planet `$a'" + continue + } + describe $n + puts "" + } + } +} diff --git a/elite-editor b/elite-editor new file mode 100755 index 0000000..22a6033 --- /dev/null +++ b/elite-editor @@ -0,0 +1,1208 @@ +#! /usr/bin/wish + +package require "elite" "1.0.0" + +# --- Utility procedures ---------------------------------------------------- + +proc moan {msg} { + global argv0 + tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error +} + +proc debug-array {name} { + upvar \#0 $name a + set tl .debug-$name + if {[winfo exists .$tl]} { return } + set s [array startsearch a] + toplevel $tl + set r 0 + set n 0 + while {[array anymore a $s]} { + set k [array nextelement a $s] + label $tl.k-$n -text $k -justify right + entry $tl.v-$n -textvariable ${name}($k) -state disabled + grid configure $tl.k-$n -row $r -column 0 -sticky e + grid configure $tl.v-$n -row $r -column 1 -sticky we + incr r + incr n + } + array donesearch a $s +} + +proc write-file {name contents {trans binary}} { + if {[file exists $name]} { + if {[set rc [catch { file copy -force $name "$name.old" } err]]} { + return -code $rc $err + } + } + if {[set rc [catch { + set f [open $name w] + fconfigure $f -translation $trans + puts -nonewline $f $contents + close $f + } err]]} { + catch { close $f } + catch { file rename -force "$name.old" $name } + return -code $rc $err + } + return "" +} + +proc read-file {name {trans binary}} { + set f [open $name] + fconfigure $f -translation $trans + set c [read $f] + close $f + return $c +} + +proc get-line-done {tl cmd} { + if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} { + destroy $tl + } +} + +proc get-line {tl title prompt def cmd} { + if {[winfo exists $tl]} { +# raise $tl + return + } + toplevel $tl + wm title $tl $title + label $tl.label -text "$prompt: " + entry $tl.entry; $tl.entry insert 0 $def + button $tl.ok -text OK -default active \ + -command [list get-line-done $tl $cmd] + bind $tl [list get-line-done $tl $cmd] + bind $tl [list destroy $tl] + pack $tl.label $tl.entry $tl.ok -side left -padx 2 -pady 2 +} + +proc entry-on-change {widget what} { + bind $widget $what + bind $widget $what +} + +#----- Map editing machinery ------------------------------------------------ + +tab col red orange yellow green blue magenta violet white + +set seq 0 +set nwin 0 +array set default {scale 15 colourby off connect 0} + +proc set-scale {seq sc} { + if {![regexp {^[0-9]+$} $sc]} { + moan "bad scale factor `$sc'" + return 1 + } + map-setscale $seq $sc + return 0 +} + +proc new-view {gs} { + set g [parse-galaxy-spec $gs] + if {![llength $g]} { + moan "bad galaxy spec `$gs'" + return 1 + } + destructure {ng g} $g + map-new $ng $g + return 0 +} + +# --- Colour-coding planets --- + +proc colour-by {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + global col + switch -exact -- $map(colourby) { + off { + foreach-world $map(galaxy) p { + $tl.map itemconfigure $p(seed) -fill white -outline white + } + } + economy { + foreach-world $map(galaxy) p { + set c [expr {7 - $p(economy)}] + $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) + } + } + government { + foreach-world $map(galaxy) p { + set c $p(government) + $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) + } + } + techlevel { + foreach-world $map(galaxy) p { + set c [expr {$p(techlevel) / 2}] + $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c) + } + } + } +} + +proc set-colour-by {seq} { + global default + upvar \#0 map-$seq map + set default(colourby) $map(colourby) + colour-by $seq +} + +# --- Connectivity maps --- + +proc show-connectivity {seq} { + upvar \#0 map-$seq map + upvar \#0 adj-$map(galaxy) adj + upvar \#0 ww-$map(galaxy) ww + set tl .map-$seq + $tl.map delete conn + if {!$map(connect)} { + return + } + if {![info exists adj]} { adjacency $ww adj } + foreach {s x y} $ww { + set done($s) 1 + foreach {ss xx yy} $adj($s) { + if {[info exists done($ss)]} { continue } + $tl.map create line \ + [to-map $seq $x] [to-map $seq $y] \ + [to-map $seq $xx] [to-map $seq $yy] \ + -fill darkblue -tags conn + } + } + $tl.map lower conn sep +} + +proc set-connectivity {seq} { + global default + upvar \#0 map-$seq map + set default(connect) $map(connect) + show-connectivity $seq +} + +# --- Planet names --- + +proc show-names {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + $tl.map delete names + if {!$map(names)} { + return + } + foreach-world $map(galaxy) p { + set anc nw + set px [to-map $seq $p(x)] + set py [to-map $seq $p(y)] + set offx [expr {$px + [to-map $seq 2]}] + set offy [expr {$py + [to-map $seq 2]}] + set what {} + foreach {a ox oy dx x y xx yy} { + nw 2 2 0 0 0 30 10 + nw 2 2 -10 0 0 30 10 + sw 2 -2 0 0 -10 30 0 + sw 2 -2 -10 0 -10 30 0 + se -2 -2 0 -30 -10 0 0 + se -2 -2 10 -30 -10 0 0 + ne -2 2 0 -30 0 0 10 + ne -2 2 10 -30 0 0 10 + } { + set ox [expr {$px + [to-map $seq $ox] + $dx}] + set oy [expr {$py + [to-map $seq $oy]}] + if {![llength [$tl.map find overlapping \ + [expr {$ox + $x}] [expr {$ox + $y}] \ + [expr {$ox + $xx}] [expr {$ox + $yy}]]]} { + set offx $ox + set offy $oy + set anc $a + break + } + lappend what $a + } + $tl.map create text $offx $offy -text $p(name) \ + -fill white -anchor $a -tags names + } +} + +proc set-names {seq} { + global default + upvar \#0 map-$seq map + set default(names) $map(names) + show-names $seq +} + +# --- Shortest path handling --- + +proc show-path {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + $tl.map delete path + if {![info exists map(path)]} { return } + foreach n $map(path) { + elite-worldinfo p $n + if {[info exists x]} { + $tl.map create line \ + [to-map $seq $x] [to-map $seq $y] \ + [to-map $seq $p(x)] [to-map $seq $p(y)] \ + -fill darkorange -tags path + } + set x $p(x) + set y $p(y) + } + $tl.map lower path sep +} + +proc show-shortest-path {seq weight} { + upvar \#0 map-$seq map + upvar \#0 adj-$map(galaxy) adj + upvar \#0 ww-$map(galaxy) ww + set tl .map-$seq + $tl.map delete path + if {[info exists map(path)]} { unset map(path) } + if {![info exists map(select)] || ![info exists map(dest)]} { + moan "no source or destination set" + return + } + if {![info exists adj]} { adjacency $ww adj } + destructure {path weight} \ + [shortest-path adj $map(select) $map(dest) $weight] + if {![llength $path]} { + moan "no path exists" + return + } + set map(path) $path + show-path $seq +} + +# --- Planet information box --- + +proc do-getinfo {tag seq x y} { + global economy government + upvar \#0 info-$tag info + set tl .world-info-$tag + elite-worldinfo info [find-click $seq $x $y] + if {[winfo exists $tl]} { +# raise $tl + } else { + toplevel $tl + set r 0 + foreach {item label} { + name "Name" + seed "Seed" + position "Position" + eco-name "Economy" + gov-name "Government" + techlevel "Tech. level" + pop-str "Population" + prod-str "Productivity" + radius-km "Radius" + } { + label $tl.l-$item -text "$label: " -justify right + entry $tl.$item -textvariable info-${tag}($item) -state disabled + grid configure $tl.l-$item -row $r -column 0 -sticky e + grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we + incr r + } + scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview] + text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \ + -width 40 -height 4 + grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew + grid configure $tl.descscr -row $r -column 2 -sticky ns + grid columnconfigure $tl 1 -weight 1 + grid rowconfigure $tl $r -weight 1 + } + wm title $tl "Info: $info(name)" + set info(position) "$info(x), $info(y)" + set info(eco-name) $economy($info(economy)) + set info(gov-name) $government($info(government)) + set info(pop-str) \ + [format "%s billion (%s)" \ + [expr {$info(population)/10}] \ + $info(inhabitants)] + set info(prod-str) [format "%d M Cr" $info(productivity)] + set info(radius-km) [format "%d km" $info(radius)] + $tl.desc configure -state normal + $tl.desc delete 1.0 end + $tl.desc insert end $info(description) + $tl.desc configure -state disabled +} + +# --- Messing with selections --- + +proc to-ly {seq x} { + upvar \#0 map-$seq map + return [expr {$x * $map(scale) / 10.0}] +} + +proc to-map {seq x} { + upvar \#0 map-$seq map + return [expr {$x * 10 / $map(scale)}] +} + +proc find-click {seq x y} { + upvar \#0 map-$seq map + upvar \#0 ww-$map(galaxy) ww + set tl .map-$seq + + set x [to-ly $seq [$tl.map canvasx $x]] + set y [to-ly $seq [$tl.map canvasy $y]] + set best 100000 + foreach {seed px py} $ww { + set dx [expr {$x - $px}] + set dy [expr {$y - $py}] + set d [expr {$dx * $dx + $dy * $dy}] + if {$d < $best} { + set best $d + set p $seed + } + } + $tl.map delete here + + if 0 { + $tl.map create line \ + [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \ + [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \ + -tags here -fill green + $tl.map create line \ + [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \ + [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \ + -tags here -fill green + } + return $p +} + +proc destination-world {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + if {![info exists map(dest)]} { return } + $tl.map delete dest + elite-worldinfo p $map(dest) + set px [to-map $seq $p(x)] + set py [to-map $seq $p(y)] + $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \ + -tags {dest cross} -fill darkorange + $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \ + -tags {dest cross} -fill darkorange + $tl.map raise dest sel +} + +proc select-world {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + if {![info exists map(select)]} { return } + $tl.map delete sel dest + elite-worldinfo p $map(select) + set r [to-map $seq $map(fuel)] + set px [to-map $seq $p(x)] + set py [to-map $seq $p(y)] + $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \ + -tags {sel cross} -fill darkred + $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \ + -tags {sel cross} -fill darkred + $tl.map create oval \ + [expr {$px - $r}] [expr {$py - $r}] \ + [expr {$px + $r}] [expr {$py + $r}] \ + -tags {sel radius} -outline darkgreen + $tl.map raise sel sep +} + +proc select-byname {seq name seed proc} { + upvar \#0 map-$seq map + set p [parse-planet-spec $map(galaxy) $map($name)] + if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} { + $proc $seq $p + } elseif {[info exists map($seed)]} { + bell + set map($name) [worldname $map($seed)] + } else { + bell + set map($name) "" + } +} + +proc set-selection {seq p} { + upvar \#0 map-$seq map + set map(select) $p + elite-worldinfo pp $p + select-world $seq + set map(sel-name) $pp(name) + if {![info exists map(dest)]} { + set-destination $seq $p + } else { + set-destination $seq $map(dest) + } + if {[info exists map(cmdr)]} { + cmdr-set-world $map(cmdr) $p + } +} + +proc do-select {seq x y} { + set-selection $seq [find-click $seq $x $y] +} + +proc set-destination {seq p} { + upvar \#0 map-$seq map + if {![info exists map(select)]} { + set-selection $seq $p + } else { + elite-worldinfo ps $map(select) + elite-worldinfo pd $p + set map(dest) $p + destination-world $seq + set map(dest-name) $pd(name) + set map(distance) \ + [format "%.1f" \ + [expr {[world-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]] + } +} + +proc do-destination {seq x y} { + set-destination $seq [find-click $seq $x $y] +} + +# --- Redrawing a map --- + +proc map-populate {seq} { + global colourby-$seq connect-$seq + upvar \#0 map-$seq map + upvar \#0 ww-$map(galaxy) ww + set tl .map-$seq + + set scale $map(scale) + $tl.map delete all + $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep + if {![info exists ww]} { set ww [worldinfo $map(galaxy)] } + foreach {seed x y} $ww { + elite-worldinfo p $seed + set x [expr {$x * 10 / $map(scale)}] + set y [expr {$y * 10 / $map(scale)}] + set r [expr {$p(radius) / (500 * $map(scale))}] + $tl.map create oval \ + [expr {$x - $r}] [expr {$y - $r}] \ + [expr {$x + $r}] [expr {$y + $r}] \ + -fill white -outline white \ + -tags [list $seed world] + } + + colour-by $seq + show-connectivity $seq + show-path $seq + show-names $seq + select-world $seq + destination-world $seq +} + +# --- Miscellaneous stuff --- + +proc map-setscale {seq sc} { + global default + upvar \#0 map-$seq map + set tl .map-$seq + set wd [expr {10240/$sc + 40}] + set ht [expr {5120/$sc} + 10] + $tl.map configure -scrollregion [list -40 -10 $wd $ht] + set map(scale) $sc + set default(scale) $sc + map-populate $seq +} + +proc map-destroy {seq} { + global nwin + upvar \#0 map-$seq map + if {[info exists map(cmdr)]} { + upvar \#0 cmdr-$map(cmdr) cmdr + unset cmdr(map) + } + unset map + destroy .map-$seq .set-scale-$seq + incr nwin -1 + if {!$nwin} { exit } +} + +proc map-attach-cmdr {seq cmdr} { + upvar \#0 map-$seq map + set map(cmdr) $cmdr + map-set-title $seq +} + +proc map-set-title {seq} { + upvar \#0 map-$seq map + set tl .map-$seq + set t "Galaxy $map(galaxy-num)" + if {[info exists map(cmdr)]} { + append t " (commander [cmdr-name $map(cmdr)])" + } + wm title $tl $t +} + +proc map-set-galaxy {seq ng g} { + upvar \#0 map-$seq map + if {[string equal $g $map(galaxy)]} { return } + set map(galaxy-num) $ng + map-set-title $seq + set map(galaxy) $g + map-populate $seq + foreach i {select select-name dest dest-name} { + catch { unset map($i) } + } +} + +proc map-set-fuel {seq qty} { + upvar \#0 map-$seq map + set map(fuel) $qty + select-world $seq +} + +# --- Making a new map window --- + +proc map-new {ng g} { + global seq nwin default + incr seq + incr nwin + upvar \#0 map-$seq map + + array set map [array get default] + set sc $map(scale) + set map(galaxy) $g + set map(galaxy-num) $ng + set tl [toplevel .map-$seq] + set wd [expr {10240/$sc + 80}] + set ht [expr {5120/$sc + 20}] + set vwd $wd; if {$vwd > 1120} { set vwd 768 } + set vht $ht; if {$vht > 1024} { set vht 768 } + set map(fuel) 70 + canvas $tl.map \ + -background black \ + -xscrollcommand [list $tl.hscr set] \ + -yscrollcommand [list $tl.vscr set] \ + -width $vwd -height $vht + frame $tl.info + label $tl.info.lhome -text "Home: " + entry $tl.info.home -textvariable map-${seq}(sel-name) + label $tl.info.ldest -text "Destination: " + entry $tl.info.dest -textvariable map-${seq}(dest-name) + label $tl.info.ldist -text "Distance: " + entry $tl.info.dist -textvariable map-${seq}(distance) \ + -state disabled -width 6 + pack \ + $tl.info.lhome $tl.info.home \ + $tl.info.ldest $tl.info.dest \ + $tl.info.ldist $tl.info.dist \ + -side left + + scrollbar $tl.hscr -orient horizontal \ + -command [list $tl.map xview] + scrollbar $tl.vscr -orient vertical \ + -command [list $tl.map yview] + menu $tl.menu + menu $tl.menu.file + $tl.menu.file add command -label "New commander" -command cmdr-new + $tl.menu.file add command -label "Load commander..." \ + -command { cmdr-loadfile } + $tl.menu.file add separator + $tl.menu.file add command -label "Close" -command [list map-destroy $seq] + $tl.menu.file add command -label "Quit" -command { exit } + $tl.menu add cascade -label "File" -menu $tl.menu.file + menu $tl.menu.view + $tl.menu.view add command -label "New map..." \ + -command [list get-line .new-view "New view" "Galaxy" $ng new-view] + $tl.menu.view add command -label "Set scale..." \ + -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \ + \[set map-${seq}(scale)\] [list [list set-scale $seq]]] + $tl.menu.view add separator + $tl.menu.view add radiobutton -label "Off" \ + -variable map-${seq}(colourby) -value off \ + -command [list set-colour-by $seq] + $tl.menu.view add radiobutton -label "Economy" \ + -variable map-${seq}(colourby) -value economy \ + -command [list set-colour-by $seq] + $tl.menu.view add radiobutton -label "Government" \ + -variable map-${seq}(colourby) -value government \ + -command [list set-colour-by $seq] + $tl.menu.view add radiobutton -label "Tech level" \ + -variable map-${seq}(colourby) -value techlevel \ + -command [list set-colour-by $seq] + $tl.menu.view add separator + $tl.menu.view add checkbutton -label "Connectivity" \ + -variable map-${seq}(connect) \ + -command [list set-connectivity $seq] + $tl.menu.view add checkbutton -label "Planet names" \ + -variable map-${seq}(names) \ + -command [list set-names $seq] + $tl.menu add cascade -label "View" -menu $tl.menu.view + menu $tl.menu.path + $tl.menu.path add command -label "Minimize hops" \ + -command [list show-shortest-path $seq weight-hops] + $tl.menu.path add command -label "Minimize fuel" \ + -command [list show-shortest-path $seq weight-fuel] + $tl.menu.path add command -label "Maximize safety" \ + -command [list show-shortest-path $seq weight-safety] + $tl.menu.path add command -label "Minimize safety" \ + -command [list show-shortest-path $seq weight-encounters] + $tl.menu.path add command -label "Maximize trading" \ + -command [list show-shortest-path $seq weight-trading] + $tl.menu add cascade -label "Compute path" -menu $tl.menu.path + $tl configure -menu $tl.menu + + wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq] + + grid $tl.map -column 0 -row 0 -sticky nsew + grid $tl.hscr -column 0 -row 1 -sticky ew + grid $tl.vscr -column 1 -row 0 -sticky ns + grid rowconfigure $tl 0 -weight 1 + grid columnconfigure $tl 0 -weight 1 + grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew + + bind $tl.map <3> [list do-select $seq %x %y] + bind $tl.map <1> [list do-destination $seq %x %y] + bind $tl.map [list do-getinfo dest $seq %x %y] + bind $tl.map [list do-getinfo home $seq %x %y] + + map-set-title $seq + entry-on-change $tl.info.home \ + [list select-byname $seq sel-name select set-selection] + entry-on-change $tl.info.dest \ + [list select-byname $seq dest-name dest set-destination] + map-setscale $seq $sc + return $seq +} + +#----- Commander editing machinery ------------------------------------------ + +# --- Validation and factor-of-10 fixing --- + +proc fix-tenth {tag arrvar full op} { + upvar \#0 $arrvar arr + catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] } +} + +proc numericp {min max n} { + if {[catch { expr {$n + 0} }]} { return 0 } + if {$n < $min || $n > $max} { return 0 } + return 1 +} + +proc integerp {min max n} { + if {[catch { incr n 0}]} { return 0 } + if {$n < $min || $n > $max} { return 0 } + return 1 +} + +proc galaxyp {s} { + if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 } + return 1 +} + +proc cmdr-do-validate {seq widget check value} { + upvar \#0 cmdr-$seq cmdr + if {$cmdr(ok/$widget)} { incr cmdr(bogus) } + if {![eval $check [list $value]]} { + set cmdr(ok/$widget) 0 + $widget configure -foreground red + } else { + set cmdr(ok/$widget) 1 + $widget configure -foreground black + incr cmdr(bogus) -1 + } + return 1 +} + +proc cmdr-validate-widget {seq widget check} { + upvar \#0 cmdr-$seq cmdr + set cmdr(ok/$widget) 1 + $widget configure -validate key \ + -vcmd [list cmdr-do-validate $seq $widget $check %P] +} + +# --- Cargo window handling --- + +proc cmdr-set-fluc {seq} { + upvar \#0 cmdr-$seq cmdr + global products + set tl .cmdr-$seq.cargo-qty + if {!$cmdr(ok/$tl.fluc)} { bell; return } + elite-market m $cmdr(world-seed) $cmdr(market-fluc) + foreach {i .} $products { + set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]] + } +} + +proc cmdr-cargo {seq} { + upvar \#0 cmdr-$seq cmdr + set tl .cmdr-$seq.cargo-qty + if {[winfo exists $tl]} { +# raise $tl + return + } + toplevel $tl + wm title $tl "Cargo for commander $cmdr(name)" + global products + set r 0 + label $tl.l-fluc -text "Fluctuation: " -justify right + entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right + cmdr-validate-widget $seq $tl.fluc [list integerp 0 255] + entry-on-change $tl.fluc [list cmdr-set-fluc $seq] + grid configure $tl.l-fluc -row $r -column 0 -sticky e + grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we + incr r + label $tl.l-item -text "Item" -justify center + label $tl.l-price -text "Price" -justify center + label $tl.l-station -text "Station" -justify center + label $tl.l-hold -text "Hold" -justify center + grid configure $tl.l-item -row $r -column 0 -sticky e + grid configure $tl.l-price -row $r -column 1 -sticky we + grid configure $tl.l-station -row $r -column 2 -sticky we + grid configure $tl.l-hold -row $r -column 3 -sticky we + incr r + foreach {tag label} $products { + label $tl.l-$tag -text "$label: " -justify right + entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \ + -justify right -state disabled -width 4 + foreach {pre col} {station 2 hold 3} { + entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \ + -justify right -width 4 + cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255] + grid configure $tl.${pre}-${tag} -row $r -column $col -stick we + } + grid configure $tl.l-$tag -row $r -column 0 -sticky e + grid configure $tl.price-$tag -row $r -column 1 -sticky we + incr r + } + grid columnconfigure $tl 1 -weight 1 + grid columnconfigure $tl 2 -weight 1 + grid columnconfigure $tl 3 -weight 1 +} + +# --- Miscellaneous stuff --- + +proc cmdr-destroy {seq} { + upvar \#0 cmdr-$seq cmdr + global nwin + set tl .cmdr-$seq + if {[info exists cmdr(map)]} { map-destroy $cmdr(map) } + unset cmdr + destroy $tl + incr nwin -1 + if {!$nwin} { exit } +} + +proc cmdrdb-set {seq tag value} { + upvar \#0 cmdr-$seq cmdr + set tl .cmdr-$seq + set cmdr($tag) $value + $tl.$tag configure -state disabled +} + +proc cmdrdb-custom {seq tag} { + set tl .cmdr-$seq + $tl.$tag configure -state normal +} + +proc cmdr-set-world {seq p} { + upvar \#0 cmdr-$seq cmdr + elite-worldinfo i $p + set cmdr(world-seed) $p + set cmdr(world-name) $i(name) + set cmdr(world-x) [expr {$i(x)/4}] + set cmdr(world-y) [expr {$i(y)/2}] + cmdr-set-fluc $seq +} + +proc cmdr-update-world {seq} { + upvar \#0 cmdr-$seq cmdr + upvar \#0 ww-$cmdr(gal-seed) ww + if {![info exists ww]} { set ww [worldinfo $cmdr(gal-seed)] } + set tl .cmdr-$seq + set w [nearest-planet $ww \ + [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]] + if {[info exists cmdr(map)]} { + if {$cmdr(std-gal)} { + set ng $cmdr(gal-number) + } else { + set ng $cmdr(gal-seed) + } + map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed) + set-selection $cmdr(map) $w + } + cmdr-set-world $seq $w +} + +proc cmdr-set-gal-num {seq} { + upvar \#0 cmdr-$seq cmdr + set tl .cmdr-$seq + if {!$cmdr(ok/$tl.gal-number)} { bell; return } + if {$cmdr(std-gal)} { + set cmdr(gal-seed) [galaxy $cmdr(gal-number)] + cmdr-update-world $seq + } +} + +proc cmdr-std-gal {seq} { + upvar \#0 cmdr-$seq cmdr + set tl .cmdr-$seq + if {$cmdr(std-gal)} { + if {!$cmdr(ok/$tl.gal-number)} { bell; return } + set cmdr(gal-seed) [galaxy $cmdr(gal-number)] + cmdr-update-world $seq + $tl.gal-seed configure -state disabled + } else { + $tl.gal-seed configure -state normal + } +} + +proc cmdr-set-fuel {seq} { + upvar \#0 cmdr-$seq cmdr + if {[info exists cmdr(map)]} { + map-set-fuel $cmdr(map) $cmdr(fuel) + } +} + +proc cmdr-name {seq} { + upvar \#0 cmdr-$seq cmdr + return $cmdr(name) +} + +proc cmdr-show-map {seq} { + upvar \#0 cmdr-$seq cmdr + if {[info exists cmdr(map)]} { + return + } + if {$cmdr(std-gal)} { + set ng $cmdr(gal-number) + } else { + set ng $cmdr(gal-seed) + } + set cmdr(map) [map-new $ng $cmdr(gal-seed)] + map-attach-cmdr $cmdr(map) $seq + map-set-fuel $cmdr(map) $cmdr(fuel) + set-selection $cmdr(map) $cmdr(world-seed) +} + +proc cmdr-set-name {seq} { + upvar \#0 cmdr-$seq cmdr + if {[info exists cmdr(file)]} { + set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]] + } else { + set cmdr(name) JAMESON + } + set tl .cmdr-$seq + wm title $tl "Commander $cmdr(name)" + if {[info exists cmdr(map)]} { map-set-title $cmdr(map) } + if {[winfo exists $tl.cargo-qty]} { + wm title $tl.cargo-qty "Cargo for commander $cmdr(name)" + } +} + +proc cmdr-check {seq} { + upvar \#0 cmdr-$seq cmdr + if {$cmdr(bogus)} { + moan("invalid values in commander data -- fix items highlighted in red") + return 0 + } + return 1 +} + +# --- Initial population --- + +proc cmdr-open {seq} { + upvar \#0 cmdr-$seq cmdr + global cmdr-$seq + set tl .cmdr-$seq + global nwin + toplevel $tl + set laser { + dropbox 255 + "None" 0 + "Pulse" 0x0f + "Beam" 0x8f + "Military" 0x97 + "Mining" 0x32 + } + set r 0 + set cmdr(bogus) 0 + foreach {tag label kind} [list \ + mission "Mission" { entry 2 255 } \ + score "Rating" { dropbox 65535\ + "Harmless" 0 \ + "Mostly harmless" 8 \ + "Poor" 6 \ + "Average" 32 \ + "Above average" 64 \ + "Competent" 128 \ + "Dangerous" 512 \ + "Deadly" 2560 \ + "Elite" 6400 } \ + legal-status "Legal status" { dropbox 255 \ + "Clean" 0 \ + "Offender" 1 \ + "Fugitive" 50 } \ + world "Location" where \ + credits "Credits" { tenth 10 429496729.5 } \ + fuel "Fuel" { tenth 4 25.5 } \ + missiles "Missiles" { entry 4 255 } \ + energy-unit "Energy unit" { dropbox 255 \ + "None" 0 \ + "Standard" 1 \ + "Naval" 2 } \ + front-laser "Front laser" $laser \ + rear-laser "Front laser" $laser \ + left-laser "Left laser" $laser \ + right-laser "Right laser" $laser \ + ecm "ECM" toggle \ + fuel-scoop "Fuel scoops" toggle \ + energy-bomb "Energy bomb" toggle \ + escape-pod "Escape pod" toggle \ + docking-computer "Docking computers" toggle \ + gal-hyperdrive "Galactic hyperdrive" toggle \ + cargo "Cargo capacity" { entry 4 255 } \ + stuff "Cargo" cargo \ + ] { + switch -exact -- [lindex $kind 0] { + entry { + destructure {. wd max} $kind + label $tl.l-$tag -text "$label: " -justify right + entry $tl.$tag -textvariable cmdr-${seq}($tag) \ + -width $wd -justify right + cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max] + grid configure $tl.l-$tag -row $r -column 0 -sticky e + grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we + } + tenth { + destructure {. wd max} $kind + label $tl.l-$tag -text "$label: " -justify right + entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \ + -width $wd -justify right + set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]] + trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag] + cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max] + grid configure $tl.l-$tag -row $r -column 0 -sticky e + grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we + } + toggle { + checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag) + grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w + } + dropbox { + label $tl.l-$tag -text "$label: " -justify right + set menu $tl.m-$tag.menu + menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \ + -indicatoron 1 -relief raised -menu $menu -width 8 \ + -direction flush + entry $tl.$tag -textvariable cmdr-${seq}($tag) \ + -justify right -width 4 + cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]] + menu $menu -tearoff 0 + set cmdr(r-$tag) "Custom" + foreach {name value} [lrange $kind 2 end] { + $menu add radiobutton -label "$name ($value)" \ + -value $name -variable cmdr-${seq}(r-$tag) \ + -command [list cmdrdb-set $seq $tag $value] + if {$cmdr($tag) == $value} { + set cmdr(r-$tag) $name + set cmdr($tag) $value + $tl.$tag configure -state disabled + } + } + $menu add radiobutton -label "Custom" \ + -value "Custom" -variable cmdr-${seq}(r-$tag) \ + -command [list cmdrdb-custom $seq $tag] + grid configure $tl.l-$tag -row $r -column 0 -sticky e + grid configure $tl.m-$tag -row $r -column 1 -sticky we + grid configure $tl.$tag -row $r -column 2 -sticky we + } + cargo { + button $tl.$tag -text $label -command [list cmdr-cargo $seq] + grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we + } + where { + label $tl.l-gal-number -text "Galaxy number: " -justify right + entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \ + -justify right -width 2 + cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8] + checkbutton $tl.std-gal -text "Standard galaxy" \ + -variable cmdr-${seq}(std-gal) -justify left \ + -command [list cmdr-std-gal $seq] + entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq] + grid configure $tl.l-gal-number -row $r -column 0 -sticky e + grid configure $tl.std-gal -row $r -column 1 -sticky w + grid configure $tl.gal-number -row $r -column 2 -sticky we + incr r + label $tl.l-gal-seed -text "Galaxy seed: " -justify right + entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12 + cmdr-validate-widget $seq $tl.gal-seed galaxyp + entry-on-change $tl.gal-seed [list cmdr-update-world $seq] + grid configure $tl.l-gal-seed -row $r -column 0 -sticky e + grid configure $tl.gal-seed -row $r \ + -column 1 -columnspan 2 -sticky we + incr r + if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} { + set cmdr(std-gal) 1 + $tl.gal-seed configure -state disabled + } else { + set cmdr(std-gal) 0 + } + label $tl.l-world-name -text "Planet: " -justify right + entry $tl.world-name -textvariable cmdr-${seq}(world-name) \ + -state disabled -width 10 -justify left + grid configure $tl.l-world-name -row $r -column 0 -sticky e + grid configure $tl.world-name -row $r \ + -column 1 -columnspan 2 -sticky we + incr r + button $tl.$tag -text "Show galaxy map" \ + -command [list cmdr-show-map $seq] + grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we + } + default { + label $tl.l-$tag -text "($label)" -justify left + grid configure $tl.l-$tag -row $r -column 0 -sticky w + } + } + incr r + } + entry-on-change $tl.fuel [list cmdr-set-fuel $seq] + menu $tl.menu + menu $tl.menu.file + $tl.menu.file add command -label "New commander" -command cmdr-new + $tl.menu.file add command -label "Load commander..." \ + -command { cmdr-loadfile } + $tl.menu.file add command -label "Save commander" \ + -command [list cmdr-save $seq] + $tl.menu.file add command -label "Save as..." \ + -command [list cmdr-saveas $seq] + $tl.menu.file add separator + $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq] + $tl.menu.file add command -label "Quit" -command { exit } + $tl.menu add cascade -label "File" -menu $tl.menu.file + $tl configure -menu $tl.menu + grid columnconfigure $tl 2 -weight 1 + wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq] + set cmdr(ok/$tl.cargo-qty.fluc) 1 + cmdr-update-world $seq + cmdr-set-name $seq + incr nwin + return $seq +} + +# --- File handling --- + +proc cmdr-load {file} { + global seq + incr seq + set c [read-file $file] + upvar \#0 cmdr-$seq cmdr + elite-unpackcmdr cmdr $c + set cmdr(file) $file + cmdr-open $seq +} + +set cmdr-filetypes { + { "Commander file" ".nkc" } +} + +proc cmdr-loadfile {} { + global cmdr-filetypes + set f [tk_getOpenFile \ + -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \ + -title "Load commander"] + if {![string equal $f ""]} { + cmdr-load $f + } +} + +proc cmdr-save-file {seq file} { + upvar \#0 cmdr-$seq cmdr + set tl .cmdr-$seq + if {[catch { write-file $file [elite-packcmdr cmdr] } err]} { + moan $err + } else { + set cmdr(file) $file + cmdr-set-name $seq + } +} + +proc cmdr-saveas {seq} { + upvar \#0 cmdr-$seq cmdr + global cmdr-filetypes + if {![cmdr-check $seq]} { return } + set opts [list \ + -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \ + -title "Save commander"] + if {[info exists cmdr(file)]} { + lappend opts -initialdir [file dirname $cmdr(file)] + lappend opts -initialfile [file tail $cmdr(file)] + } else { + lappend opts -initialfile "JAMESON.nkc" + } + set f [eval tk_getSaveFile $opts] + if {[string equal $f ""]} { return } + cmdr-save-file $seq $f +} + +proc cmdr-save {seq} { + upvar \#0 cmdr-$seq cmdr + if {![info exists cmdr(file)]} { + cmdr-saveas $seq + return + } + if {![cmdr-check $seq]} { return } + cmdr-save-file $seq $cmdr(file) +} + +proc cmdr-new {} { + global seq galaxy1 products + incr seq + upvar \#0 cmdr-$seq 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 + legal-status 0 + score 0 + market-fluc 0 + } + set cmdr(gal-seed) $galaxy1 + foreach i { + ecm fuel-scoop energy-bomb energy-unit docking-computer + gal-hyperdrive escape-pod + } { set cmdr($i) 0 } + elite-worldinfo lave [find-world $galaxy1 "Lave"] + set cmdr(world-x) [expr {$lave(x)/4}] + set cmdr(world-y) [expr {$lave(y)/2}] + elite-market mkt $lave(seed) 0 + foreach {t n} $products { + destructure [list . cmdr(station-$t)] $mkt($t) + set cmdr(hold-$t) 0 + } + set cmdr(station-alien-items) 0 + cmdr-open $seq +} + +#----- Main program --------------------------------------------------------- + +wm withdraw . + +if {[llength $argv]} { + foreach a $argv { + set g [parse-galaxy-spec $a] + if {[llength $g]} { + destructure {ng g} $g + map-new $ng $g + } else { + cmdr-load $a + } + } +} else { + map-new 1 $galaxy1 +} +if {!$nwin} { exit } + +#----- That's all, folks ---------------------------------------------------- diff --git a/elite-find b/elite-find new file mode 100755 index 0000000..c8dcabe --- /dev/null +++ b/elite-find @@ -0,0 +1,71 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +proc ok {s vv expr} { + global argv0 + set ip [interp create] + foreach v $vv { + upvar 1 $v var + if {[array exists var]} { + foreach {k d} [array get var] { + $ip eval [list set ${v}($k) $d] + } + } else { + $ip eval [list set $v $var] + } + } + elite-worldinfo p $s + foreach {k v} [array get p] { + $ip eval [list set $k $v] + } + if {[catch { $ip eval [list expr $expr] } rc]} { + puts stderr "$argv0: error in expression: $rc" + exit 1 + } + interp delete $ip + return $rc +} + +set g $galaxy1 +set d 70 +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -glob -- $a { + "-g" { + incr i + set a [lindex $argv $i] + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy string `$a'" + exit 1 + } + destructure {. g} $g + } + "--" { + incr i + break + } + "-*" { + puts stderr "usage: $argv0 \[-g GALAXY\] \[EXPR\]" + exit 1 + } + default { + break + } + } +} + +set expr {} +if {$i == [llength $argv] - 1} { + set expr [lindex $argv $i] +} elseif {$i != [llength $argv]} { + puts stderr "usage: $argv0 \[-g GALAXY\] \[EXPR\]" + exit 1 +} +set ww [worldinfo $g] +foreach {s x y} $ww { + if {[string equal $expr ""] || [ok $s {} $expr]} { + puts [world-summary $s] + } +} diff --git a/elite-map b/elite-map new file mode 100755 index 0000000..7ae2044 --- /dev/null +++ b/elite-map @@ -0,0 +1,183 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +set syms "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +proc symbol {i} { + global syms + if {$i < [string length $syms]} { + return [string index $syms $i] + } + set hi [expr {$i / [string length $syms]}] + set lo [expr {$i % [string length $syms]}] + return [string index $syms $hi][string index $syms $lo] +} + +proc show-map {asp wx wy ww {n ""}} { + set minx 10000 + set miny 10000 + set maxx 0 + set maxy 0 + + foreach {s x y} $ww { + if {$x < $minx} { set minx $x} + if {$y < $miny} { set miny $y} + if {$x > $maxx} { set maxx $x} + if {$y > $maxy} { set maxy $y} + } + set dx [expr {$maxx - $minx}] + set dy [expr {$maxy - $miny}] + if {$dx == 0} { set dx 1 } + if {$dy == 0} { set dy 1 } + + set sc [expr {$wx/double($dx)}] + if {$dy * $sc/$asp > $wy} { + set sc [expr {$wy * $asp/double($dy)}] + } + set gw {} + foreach {s x y} $ww { + set gx [expr {int(($x - $minx) * $sc + 0.5)}] + set gy [expr {int(($y - $miny) * $sc/$asp + 0.5)}] + lappend gw [list $s $gx $gy] + } + + set pw [lsort -index 1 -integer -increasing $gw] + set pw [lsort -index 2 -integer -increasing $pw] + set x 0 + set y 0 + set i 0 + set l {} + foreach w $pw { + destructure {s px py} $w + if {$y < $py} { + puts -nonewline [string repeat "\n" [expr {$py - $y}]] + set x 0 + set y $py + } + if {$x < $px} { + puts -nonewline [string repeat " " [expr {$px - $x}]] + set x $px + } + if {[string equal $s $n]} { + set sy "*" + } else { + set sy [symbol $i] + incr i + } + puts -nonewline $sy + incr x [string length $sy] + lappend l $sy $s + } + puts -nonewline "\n" + return $l +} + +proc show-key {l n} { + global gov eco + if {![string equal $n ""]} { + elite-worldinfo p $n + } + foreach {sy s} $l { + elite-worldinfo pp $s + set out [format "%2s %s" $sy [world-summary $s]] + if {![string equal $n ""]} { + append out [format " (%.1f LY)" \ + [expr {[world-distance $p(x) $p(y) $pp(x) $pp(y)]/10.0}]] + } + puts $out + } +} + +proc local-area {g d n} { + set ww [worldinfo $g] + elite-worldinfo p $n + + set w {} + foreach {s x y} $ww { + if {abs($p(x) - $x) > $d + 10 || abs($p(y) - $y) > $d + 10 || + [world-distance $p(x) $p(y) $x $y] > $d} { continue } + lappend w $s $x $y + } + return $w +} + +set g $galaxy1 +set wx 72 +set wy 10 +set asp 2.17 +set d 70 +set v 1 +set usage "usage: $argv0 \[-qv\] \[-g GAL\] \[-d DIST\] \[-w WD,HT\] \[-a ASP\] \[PLANET\]" +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -glob -- $a { + "-g" { + incr i + set a [lindex $argv $i] + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy string `$a'" + exit 1 + } + destructure {. g} $g + } + "-d" { + incr i + set d [expr {[lindex $argv $i] * 10}] + } + "-w" { + incr i + if {![regexp {^(\d+),(\d+)$} [lindex $argv $i] . wx wy]} { + puts stderr "$argv0: bad window size string" + exit 1 + } + } + "-a" { + incr i + set asp [lindex $argv $i] + } + "-v" { + incr v + } + "-q" { + incr v -1 + } + "--" { + incr i + break + } + "-*" { + puts stderr $usage + exit 1 + } + default { + break + } + } +} + +set p [lrange $argv $i end] +switch -exact [llength $p] { + 0 { + set n "" + set w [worldinfo $g] + incr v -1 + } + 1 { + set n [parse-planet-spec $g $a] + if {[string equal $n ""]} { + puts stderr "$argv0: unknown planet `$a'" + exit 1 + } + set w [local-area $g $d $n] + } + default { + puts stderr $usage + exit 1 + } +} +set l [show-map $asp $wx $wy $w $n] +if {$v > 0} { + puts "" + show-key $l $n +} diff --git a/elite-pairs b/elite-pairs new file mode 100755 index 0000000..6f81995 --- /dev/null +++ b/elite-pairs @@ -0,0 +1,84 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +proc ok {s vv expr} { + global argv0 + set ip [interp create] + foreach v $vv { + upvar 1 $v var + if {[array exists var]} { + foreach {k d} [array get var] { + $ip eval [list set ${v}($k) $d] + } + } else { + $ip eval [list set $v $var] + } + } + elite-worldinfo p $s + foreach {k v} [array get p] { + $ip eval [list set $k $v] + } + if {[catch { $ip eval [list expr $expr] } rc]} { + puts stderr "$argv0: error in expression: $rc" + exit 1 + } + interp delete $ip + return $rc +} + +set g $galaxy1 +set d 70 +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -glob -- $a { + "-g" { + incr i + set a [lindex $argv $i] + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy string `$a'" + exit 1 + } + destructure {. g} $g + } + "-d" { + incr i + set d [expr {[lindex $argv $i] * 10}] + } + "--" { + incr i + break + } + "-*" { + puts stderr "usage: $argv0 \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR" + exit 1 + } + default { + break + } + } +} +if {$i != [llength $argv] - 2} { + puts stderr "usage: $argv0 \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR" + exit 1 +} +destructure {aexpr bexpr} [lrange $argv $i end] +puts -nonewline stderr "\[computing adjacency table..." +flush stderr +set ww [worldinfo $g] +adjacency $ww adj $d +puts stderr " done\]" +unset a +foreach {s x y} $ww { + if {![ok $s {} $aexpr]} { continue } + elite-worldinfo a $s + set l {} + foreach {ss xx yy} $adj($s) { + set d [world-distance $x $y $xx $yy] + if {[ok $ss {a d} $bexpr]} { + puts [format "%-11s %-11s (%.1f LY)" $a(name) [worldname $ss] \ + [expr {[world-distance $x $y $xx $yy]/10.0}]] + } + } +} diff --git a/elite-path b/elite-path new file mode 100755 index 0000000..1c0afcf --- /dev/null +++ b/elite-path @@ -0,0 +1,86 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +set g $galaxy1 +set ng 1 +set weight weight-hops +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -glob -- $a { + "-g" { + incr i + set a [lindex $argv $i] + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy string `$a'" + exit 1 + } + destructure {ng g} $g + } + "-w" { + incr i + set a [lindex $argv $i] + set weight "weight-$a" + if {[lsearch -exact [info commands "weight-*"] $weight] == -1} { + puts stderr "$argv0: unknown weight function `$a'" + puts stderr "$argv0: I know [info commands weight-*]" + exit 1 + } + } + "--" { + incr i + break + } + "-*" { + puts stderr "unknown switch `$a'" + exit 1 + } + default { + break + } + } +} + +set r {} +set ww [worldinfo $g] +foreach-world $g ii { + set px($ii(seed)) 1 +} +foreach a [lrange $argv $i end] { + set s [parse-planet-spec $g $a] + if {[string equal $s ""]} { + puts stderr "$argv0: unknown planet `$a'" + exit 1 + } + if {![info exists px($s)]} { + puts stderr "$argv0: planet `$a' doesn't exist in galaxy $ng" + exit 1 + } + lappend r $s +} +if {[llength $r] < 2} { + puts stderr "usage: $argv0 \[-g GALAXY\] \[-w WEIGHT\] PLANET PLANET ..." + exit 1 +} +puts -nonewline stderr "\[computing adjacency table..." +adjacency $ww adj +puts stderr " done\]" +set home [lindex $r 0] +set rt {} +foreach w [lrange $r 1 end] { + destructure {p .} [shortest-path adj $home $w $weight] + if {![llength $p]} { + puts -stderr "$argv0: no route from [worldinfo $home] to [worldinfo $w]" + exit 1 + } + eval lappend rt $p + set home $w +} +set last x +foreach s $rt { + if {![string equal $s $last]} { + puts [world-summary $s] + set last $s + } +} diff --git a/elite-prices b/elite-prices new file mode 100755 index 0000000..d24e107 --- /dev/null +++ b/elite-prices @@ -0,0 +1,58 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +# --- An optimal trading pair --- + +set lezaer "1598f98a6581" +set esmaonbe "7997d18a0d89" + +set np [expr {[llength $products]/2}] +puts -nonewline stderr "\[[string repeat { } $np]\] " +puts -nonewline stderr "\[[string repeat { } 32]\]" +puts -nonewline stderr "\r\[[string repeat { } $np]\] \[" +flush stderr +foreach {a s} [list l $lezaer e $esmaonbe] { + for {set f 0} {$f < 256} {incr f} { + elite-market m $s $f + foreach {t p} $products { destructure [list ${a}($f:$t) .] $m($t) } + if {($f & 15) == 15} { puts -nonewline stderr "."; flush stderr } + } +} +foreach {t p} $products { + set tot($t) 0 + set min($t) 100000 + set max($t) -100000 +} +set i 0 +foreach {t p} $products { + incr i + puts -nonewline stderr "\r\[[string repeat . $i]" + puts -nonewline stderr "[string repeat { } [expr {$np - $i}]]\] " + puts -nonewline stderr "\[[string repeat { } 32]\]" + puts -nonewline stderr "\r\[[string repeat . $i]" + puts -nonewline stderr "[string repeat { } [expr {$np - $i}]]\] \[" + set ll {} + set ee {} + for {set f 0} {$f < 256} {incr f} { + lappend ll $l($f:$t) + lappend ee $e($f:$t) + } + set j 0 + foreach pl $ll { + foreach pe $ee { + set pr [expr {$pl - $pe}] + if {$pr < $min($t)} { set min($t) $pr } + if {$pr > $max($t)} { set max($t) $pr } + incr tot($t) $pr + } + incr j + if {($j & 7) == 0} { puts -nonewline stderr "."; flush stderr } + } +} +puts stderr "" + +foreach {t p} $products { + puts [format "%-15s %5d %4d %4d" $t \ + $min($t) [expr {$tot($t)/65536}] $max($t)] +} diff --git a/elite-reach b/elite-reach new file mode 100755 index 0000000..7925ef2 --- /dev/null +++ b/elite-reach @@ -0,0 +1,84 @@ +#! /usr/bin/tclsh + +package require "elite" "1.0.0" + +proc reach {dist seed} { + set ww [worldinfo $seed] + puts -nonewline stderr "\[computing adjacency table..." + adjacency $ww a $dist + puts stderr " done\]" + puts -nonewline stderr "\[painting..." + flush stdout + foreach {s x w} $ww { set p($s) 1 } + set pp {} + while 1 { + set ps [array startsearch p] + if {![array anymore p $ps]} { array donesearch p $ps; break } + set cc [array nextelement p $ps] + array donesearch p $ps + unset p($cc) + set go 1 + while {$go} { + set go 0 + foreach c $cc { + foreach w $a($c) { + if {[info exists p($w)]} { + unset p($w) + lappend cc $w + set go 1 + } + } + } + } + lappend pp $cc + } + puts stderr " done\]\n" + foreach cc $pp { + set de 1 + set l {} + foreach c $cc { + elite-worldinfo i $c + if {$i(techlevel) >= 10} { + set de 0 + } + lappend l [world-summary $i(seed)] + } + foreach n $l { + if {$de} { append n " *" } + puts $n + } + puts "" + } +} + +if {[llength $argv] == 0} { + set argv {1 2 3 4 5 6 7 8} +} +set gg {} +set d 70 +for {set i 0} {$i < [llength $argv]} {incr i} { + set a [lindex $argv $i] + switch -glob -- $a { + "-d" { + incr i + set d [expr {[lindex $argv $i] * 10}] + } + "-*" { + puts stderr "usage: $argv0 \[-d DIST\] \[GALAXY ...\]" + exit 1 + } + default { + set g [parse-galaxy-spec $a] + if {[string equal $g ""]} { + puts stderr "$argv0: bad galaxy spec `$a'" + exit 1 + } + destructure {ng g} $g + lappend gg $d $ng $g + } + } +} +foreach {d ng g} $gg { + puts "*** GALAXY $ng ***" + reach $d $g +} diff --git a/elite.c b/elite.c new file mode 100644 index 0000000..c9a9773 --- /dev/null +++ b/elite.c @@ -0,0 +1,856 @@ +/* -*-c-*- + * + * $Id: elite.c,v 1.1 2003/02/24 01:13:12 mdw Exp $ + * + * Elite planet data + * + * (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. + */ + +/*----- Revision history --------------------------------------------------* + * + * $Log: elite.c,v $ + * Revision 1.1 2003/02/24 01:13:12 mdw + * Initial import. + * + */ + +/*----- Header files ------------------------------------------------------*/ + +#include +#include +#include +#include + +#include + +/*----- Data structures ---------------------------------------------------*/ + +typedef struct world { + unsigned char x[6]; +} world; + +typedef struct worldinfo { + unsigned x, y, gov, eco, tech, pop, prod, rad; +} worldinfo; + +/*----- The world type ----------------------------------------------------*/ + +static void world_fir(Tcl_Obj *o) +{ + Tcl_Free(o->internalRep.otherValuePtr); +} + +static int xtoi(unsigned x) +{ + if (x >= '0' && x <= '9') + return (x - '0'); + else if (x >= 'a' && x <= 'f') + return (x - 'a' + 10); + else if (x >= 'A' && x <= 'F') + return (x - 'A' + 10); + else + abort(); +} + +static Tcl_ObjType world_type; + +static int world_sfa(Tcl_Interp *ti, Tcl_Obj *o) +{ + int l; + world ww, *w; + int i; + char *p = Tcl_GetStringFromObj(o, &l); + if (l != 12) + goto bad; + for (i = 0; i < 12; i += 2) { + if (!isxdigit((unsigned char)p[i]) || + !isxdigit((unsigned char)p[i + 1])) + goto bad; + ww.x[i >> 1] = (xtoi(p[i]) << 4) | (xtoi(p[i + 1])); + } + w = (world *)Tcl_Alloc(sizeof(*w)); + *w = ww; + o->internalRep.otherValuePtr = w; + o->typePtr = &world_type; + return (TCL_OK); + +bad: + if (ti) + Tcl_SetResult(ti, "bad world seed string", TCL_STATIC); + return (TCL_ERROR); +} + +static void world_us(Tcl_Obj *o) +{ + char *p; + world *w = o->internalRep.otherValuePtr; + int i; + + p = Tcl_Alloc(13); + p[12] = 0; + o->bytes = p; + o->length = 12; + for (i = 0; i < 6; i++, p += 2) + sprintf(p, "%02x", w->x[i]); +} + +static void world_dir(Tcl_Obj *o, Tcl_Obj *oo) +{ + world *w = (world *)Tcl_Alloc(sizeof(*w)); + memcpy(w, o->internalRep.otherValuePtr, sizeof(world)); + oo->internalRep.otherValuePtr = w; + oo->typePtr = &world_type; + Tcl_InvalidateStringRep(oo); +} + +static /*const*/ Tcl_ObjType world_type = { + "elite-world", world_fir, world_dir, world_us, world_sfa +}; + +static world *world_get(Tcl_Interp *ti, Tcl_Obj *o) +{ + if (Tcl_ConvertToType(ti, o, &world_type) != TCL_OK) + return (0); + return (o->internalRep.otherValuePtr); +} + +static Tcl_Obj *world_new(const world *w) +{ + world *ww; + Tcl_Obj *o = Tcl_NewObj(); + ww = (world *)Tcl_Alloc(sizeof(*ww)); + *ww = *w; + o->internalRep.otherValuePtr = ww; + o->typePtr = &world_type; + Tcl_InvalidateStringRep(o); + return (o); +} + +/*----- Elite-specific hacking --------------------------------------------* + * + * Taken from `Elite: The New Kind' by Christian Pinder. + */ + +static void waggle(world *w, world *ww) +{ + unsigned int h, l; + + /* --- What goes on --- * + * + * 16-bit add of all three words, shift up, and insert the new value at the + * end. + */ + + l = w->x[0]; + h = w->x[1]; + l += w->x[2]; + h += w->x[3] + (l >= 0x100); + l &= 0xff; h &= 0xff; + l += w->x[4]; + h += w->x[5] + (l >= 0x100); + l &= 0xff; h &= 0xff; + ww->x[0] = w->x[2]; ww->x[1] = w->x[3]; + ww->x[2] = w->x[4]; ww->x[3] = w->x[5]; + ww->x[4] = l; ww->x[5] = h; +} + +/*----- Tcl commands ------------------------------------------------------*/ + +static int err(Tcl_Interp *ti, /*const*/ char *p) +{ + Tcl_SetResult(ti, p, TCL_STATIC); + return (TCL_ERROR); +} + +/* --- elite-nextworld SEED --- */ + +static int cmd_nextworld(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + world *w, ww; + if (objc != 2) + return (err(ti, "usage: elite-nextworld SEED")); + if ((w = world_get(ti, objv[1])) == 0) + return (TCL_ERROR); + waggle(w, &ww); + waggle(&ww, &ww); + waggle(&ww, &ww); + waggle(&ww, &ww); + Tcl_SetObjResult(ti, world_new(&ww)); + return (TCL_OK); +} + +/* --- elite-nextgalaxy SEED --- */ + +static int cmd_nextgalaxy(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + world *w, ww; + int i; + + if (objc != 2) + return (err(ti, "usage: elite-nextgalaxy SEED")); + if ((w = world_get(ti, objv[1])) == 0) + return (TCL_ERROR); + for (i = 0; i < 6; i++) + ww.x[i] = ((w->x[i] << 1) | (w->x[i] >> 7)) & 0xff; + Tcl_SetObjResult(ti, world_new(&ww)); + return (TCL_OK); +} + +/* --- elite-worldinfo ARR SEED --- */ + +static void getworldinfo(worldinfo *wi, world *w) +{ + wi->x = w->x[3]; + wi->y = w->x[1]; + wi->gov = (w->x[2] >> 3) & 0x07; + wi->eco = w->x[1] & 0x07; + if (wi->gov < 2) + wi->eco |= 0x02; + wi->tech = ((wi->eco ^ 7) + (w->x[3] & 0x03) + + (wi->gov >> 1) + (wi->gov & 0x01) + 1); + wi->pop = wi->tech * 4 + wi->gov + wi->eco - 3; + wi->prod = ((wi->eco ^ 7) + 3) * (wi->gov + 4) * wi->pop * 8; + wi->rad = (((w->x[5] & 0x0f) + 11) << 8) + w->x[3]; +} + +static const char digrams[] = + "abouseitiletstonlonuthnoallexegezacebisouses" + "armaindirea?eratenberalavetiedorquanteisrion"; + +static const char *const desc[][5] = { +/* 0 */ { "fabled", "notable", "well known", "famous", "noted" }, +/* 1 */ { "very ", "mildly ", "most ", "reasonably ", "" }, +/* 2 */ { "ancient", "<20>", "great", "vast", "pink" }, +/* 3 */ { "<29> <28> plantations", "mountains", "<27>", + "<19> forests", "oceans" }, +/* 4 */ { "shyness", "silliness", "mating traditions", + "loathing of <5>", "love for <5>" }, +/* 5 */ { "food blenders", "tourists", "poetry", "discos", "<13>" }, +/* 6 */ { "talking tree", "crab", "bat", "lobst", "%R" }, +/* 7 */ { "beset", "plagued", "ravaged", "cursed", "scourged" }, +/* 8 */ { "<21> civil war", "<26> <23> <24>s", + "a <26> disease", "<21> earthquakes", "<21> solar activity" }, +/* 9 */ { "its <2> <3>", "the %I <23> <24>", + "its inhabitants' <25> <4>", "<32>", "its <12> <13>" }, +/* 10 */ { "juice", "brandy", "water", "brew", "gargle blasters" }, +/* 11 */ { "%R", "%I <24>", "%I %R", "%I <26>", "<26> %R" }, +/* 12 */ { "fabulous", "exotic", "hoopy", "unusual", "exciting" }, +/* 13 */ { "cuisine", "night life", "casinos", "sit coms", " <32>" }, +/* 14 */ { "%H", "The planet %H", "The world %H", + "This planet", "This world" }, +/* 15 */ { "n unremarkable", " boring", " dull", " tedious", " revolting" }, +/* 16 */ { "planet", "world", "place", "little planet", "dump" }, +/* 17 */ { "wasp", "moth", "grub", "ant", "%R" }, +/* 18 */ { "poet", "arts graduate", "yak", "snail", "slug" }, +/* 19 */ { "tropical", "dense", "rain", "impenetrable", "exuberant" }, +/* 20 */ { "funny", "weird", "unusual", "strange", "peculiar" }, +/* 21 */ { "frequent", "occasional", "unpredictable", "dreadful", "deadly" }, +/* 22 */ { "<1><0> for <9>", "<1><0> for <9> and <9>", + "<7> by <8>", "<1><0> for <9> but <7> by <8>","a<15> <16>" }, +/* 23 */ { "<26>", "mountain", "edible", "tree", "spotted" }, +/* 24 */ { "<30>", "<31>", "<6>oid", "<18>", "<17>" }, +/* 25 */ { "ancient", "exceptional", "eccentric", "ingrained", "<20>" }, +/* 26 */ { "killer", "deadly", "evil", "lethal", "vicious" }, +/* 27 */ { "parking meters", "dust clouds", "ice bergs", + "rock formations", "volcanoes" }, +/* 28 */ { "plant", "tulip", "banana", "corn", "%Rweed" }, +/* 29 */ { "%R", "%I %R", "%I <26>", "inhabitant", "%I %R" }, +/* 30 */ { "shrew", "beast", "bison", "snake", "wolf" }, +/* 31 */ { "leopard", "cat", "monkey", "goat", "fish" }, +/* 32 */ { "<11> <10>", "%I <30> <33>", "its <12> <31> <33>", + "<34> <35>", "<11> <10>" }, +/* 33 */ { "meat", "cutlet", "steak", "burgers", "soup" }, +/* 34 */ { "ice", "mud", "Zero-G", "vacuum", "%I ultra" }, +/* 35 */ { "hockey", "cricket", "karate", "polo", "tennis" } +}; + +static int mangle(world *w) +{ + unsigned a, x; + + x = (w->x[2] << 1) & 0xff; + a = x + w->x[4]; + if (w->x[2] & 0x80) + a++; + w->x[2] = a & 0xff; + w->x[4] = x; + a >>= 8; + x = w->x[3]; + a = (a + x + w->x[5]) & 0xff; + w->x[3] = a; + w->x[5] = x; + return (a); +} + +static void goatsoup(Tcl_Obj *d, const char *pn, world *w, const char *p) +{ + for (;;) { + size_t sz = strcspn(p, "<%"); + unsigned n; + char buf[12]; + char *q; + + Tcl_AppendToObj(d, (char *)p, sz); + p += sz; + switch (*p) { + unsigned i, j; + case 0: + return; + case '<': + i = strtoul(p + 1, (char **)&p, 10); + p++; + j = mangle(w); + goatsoup(d, pn, w, desc[i][(j >= 0x33) + (j >= 0x66) + + (j >= 0x99) + (j >= 0xcc)]); + break; + case '%': + p++; + switch (*p++) { + case 'H': + Tcl_AppendToObj(d, (char *)pn, -1); + break; + case 'I': + sz = strlen(pn) - 1; + Tcl_AppendToObj(d, (char *)pn, + (pn[sz] == 'i' || pn[sz] == 'e') ? sz : sz + 1); + Tcl_AppendToObj(d, "ian", 3); + break; + case 'R': + n = (mangle(w) & 0x03) + 1; + q = buf; + while (n--) { + unsigned i = mangle(w) & 0x3e; + *q++ = digrams[i++]; + if (digrams[i] != '?') + *q++ = digrams[i++]; + } + *buf = toupper(*buf); + Tcl_AppendToObj(d, buf, q - buf); + break; + default: + abort(); + } + break; + default: + abort(); + } + } +} + +static int cmd_worldinfo(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + world *w; + worldinfo wi; + char *arr; + char buf[9]; + char *p; + unsigned j, n; + Tcl_Obj *o; + world ww; + + /* --- Check arguments --- */ + + if (objc != 3) + return (err(ti, "usage: elite-worldinfo ARR SEED")); + if ((w = world_get(ti, objv[2])) == 0) + return (TCL_ERROR); + arr = Tcl_GetString(objv[1]); + + /* --- Get the basic information --- */ + + getworldinfo(&wi, w); + if (!Tcl_SetVar2Ex(ti, arr, "x", Tcl_NewIntObj(wi.x * 4), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "y", Tcl_NewIntObj(wi.y * 2), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "government", Tcl_NewIntObj(wi.gov), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "economy", Tcl_NewIntObj(wi.eco), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "techlevel", Tcl_NewIntObj(wi.tech), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "population", Tcl_NewIntObj(wi.pop), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "productivity", Tcl_NewIntObj(wi.prod), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "radius", Tcl_NewIntObj(wi.rad), + TCL_LEAVE_ERR_MSG) || + !Tcl_SetVar2Ex(ti, arr, "seed", objv[2], + TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + + /* --- Work out the inhabitants --- */ + + if (!(w->x[4] & 0x80)) { + if (!Tcl_SetVar2(ti, arr, "inhabitants", "humans", TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + } else { + static const char *const id_a[] = { "large", "fierce", "small" }; + static const char *const id_b[] = { "green", "red", "yellow", "blue", + "black", "harmless" }; + static const char *const id_c[] = { "slimy", "bug-eyed", "horned", + "bony", "fat", "furry" }; + static const char *const id_d[] = { "rodents", "frogs", "lizards", + "lobsters", "birds", "humanoids", + "felines", "insects" }; + + o = Tcl_NewListObj(0, 0); + j = (w->x[5] >> 2) & 0x07; + if (j < 3) + Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_a[j], -1)); + j = (w->x[5] >> 5) & 0x07; + if (j < 6) + Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_b[j], -1)); + j = (w->x[1] ^ w->x[3]) & 0x07; + if (j < 6) + Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_c[j], -1)); + j += w->x[5] & 0x03; + Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_d[j & 0x07], -1)); + if (!Tcl_SetVar2Ex(ti, arr, "inhabitants", o, TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + } + + /* --- Work out the planet name --- */ + + n = (w->x[0] & 0x40) ? 4 : 3; + p = buf; + ww = *w; + while (n--) { + j = ww.x[5] & 0x1f; + if (j) { + j = (j + 12) << 1; + *p++ = digrams[j++]; + if (digrams[j] != '?') + *p++ = digrams[j]; + } + waggle(&ww, &ww); + } + *p++ = 0; + *buf = toupper(*buf); + if (!Tcl_SetVar2Ex(ti, arr, "name", Tcl_NewStringObj(buf, -1), + TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + + /* --- Finally work out the goat-soup description --- */ + + ww = *w; + o = Tcl_NewStringObj(0, 0); + goatsoup(o, buf, &ww, "<14> is <22>."); + if (!Tcl_SetVar2Ex(ti, arr, "description", o, TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + return (TCL_OK); +} + +/* --- elite-market ARR SEED [FLUC] --- */ + +static const struct item { + /*const*/ char *name; + unsigned base; + int var; + unsigned qty; + unsigned mask; +} items[] = { + { "food", 19, -2, 6, 0x01 }, + { "textiles", 20, -1, 10, 0x03 }, + { "radioactives", 65, -3, 2, 0x07 }, + { "slaves", 40, -5, 226, 0x1f }, + { "liquor-wines", 83, -5, 251, 0x0f }, + { "luxuries", 196, 8, 54, 0x03 }, + { "narcotics", 235, 29, 8, 0x78 }, + { "computers", 154, 14, 56, 0x03 }, + { "machinery", 117, 6, 40, 0x07 }, + { "alloys", 78, 1, 17, 0x1f }, + { "firearms", 124, 13, 29, 0x07 }, + { "furs", 176, -9, 220, 0x3f }, + { "minerals", 32, -1, 53, 0x03 }, + { "gold", 97, -1, 66, 0x07 }, + { "platinum", 171, -2, 55, 0x1f }, + { "gem-stones", 45, -1, 250, 0x0f }, + { "alien-items", 53, 15, 192, 0x07 }, + { 0, 0, 0, 0, 0x00 } +}; + +static int cmd_market(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + int fluc = 0; + world *w; + worldinfo wi; + const struct item *i; + char *arr; + + if (objc < 3 || objc > 5) + return (err(ti, "usage: elite-market ARR SEED [FLUC]")); + if ((w = world_get(ti, objv[2])) == 0) + return (TCL_ERROR); + arr = Tcl_GetString(objv[1]); + if (objc >= 4 && Tcl_GetIntFromObj(ti, objv[3], &fluc) != TCL_OK) + return (TCL_ERROR); + getworldinfo(&wi, w); + + for (i = items; i->name; i++) { + unsigned pr, qt; + Tcl_Obj *oo[2]; + pr = (i->base + (fluc & i->mask) + (wi.eco * i->var)) & 0xff; + qt = (i->qty + (fluc & i->mask) - (wi.eco * i->var)) & 0xff; + if (qt & 0x80) + qt = 0; + oo[0] = Tcl_NewIntObj(pr << 2); + oo[1] = Tcl_NewIntObj(qt & 0x3f); + if (!Tcl_SetVar2Ex(ti, arr, i->name, Tcl_NewListObj(2, oo), + TCL_LEAVE_ERR_MSG)) + return (TCL_ERROR); + } + return (TCL_OK); +} + +/*----- Commander file decomposition --------------------------------------*/ + +static unsigned cksum(const unsigned char *p, size_t sz) +{ + unsigned a = 0x49, c = 0; + + p += sz - 1; + while (--sz) { + a += *--p + c; + c = a >> 8; + a &= 0xff; + a ^= p[1]; + } + fflush(stdout); + return (a); +} + +/* --- The big translation table --- */ + +struct cmddata { + /*const*/ char *name; + unsigned off; + int (*get)(Tcl_Interp *, /*const*/ char *, + const unsigned char *, const struct cmddata *); + int (*put)(Tcl_Interp *, /*const*/ char *, + unsigned char *, const struct cmddata *); + int x; +}; + +static int get_byte(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + return (!Tcl_SetVar2Ex(ti, arr, cd->name, + Tcl_NewIntObj(*p - cd->x), TCL_LEAVE_ERR_MSG)); +} + +static int get_seed(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + world w; + + memcpy(w.x, p, 6); + return (!Tcl_SetVar2Ex(ti, arr, cd->name, + world_new(&w), TCL_LEAVE_ERR_MSG)); +} + +static int get_word(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + return (!Tcl_SetVar2Ex(ti, arr, cd->name, + Tcl_NewLongObj((p[0] & 0xff) << 24 | + (p[1] & 0xff) << 16 | + (p[2] & 0xff) << 8 | + (p[3] & 0xff) << 0), + TCL_LEAVE_ERR_MSG)); +} + +static int get_hword(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + return (!Tcl_SetVar2Ex(ti, arr, cd->name, + Tcl_NewLongObj((p[0] & 0xff) << 0 | + (p[1] & 0xff) << 8), + TCL_LEAVE_ERR_MSG)); +} + +static int get_bool(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + return (!Tcl_SetVar2Ex(ti, arr, cd->name, + Tcl_NewBooleanObj(*p), TCL_LEAVE_ERR_MSG)); +} + +static int get_items(Tcl_Interp *ti, /*const*/ char *arr, + const unsigned char *p, const struct cmddata *cd) +{ + char buf[32]; + const struct item *i; + + for (i = items; i->name; i++) { + sprintf(buf, "%s-%s", cd->name, i->name); + if (!Tcl_SetVar2Ex(ti, arr, buf, + Tcl_NewIntObj(*p++), TCL_LEAVE_ERR_MSG)) + return (-1); + } + return (0); +} + +static int put_byte(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + Tcl_Obj *o; + int i; + + if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 || + Tcl_GetIntFromObj(ti, o, &i) != TCL_OK) + return (-1); + *p = i + cd->x; + return (0); +} + +static int put_word(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + Tcl_Obj *o; + long l; + + if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 || + Tcl_GetLongFromObj(ti, o, &l) != TCL_OK) + return (-1); + p[0] = (l >> 24) & 0xff; + p[1] = (l >> 16) & 0xff; + p[2] = (l >> 8) & 0xff; + p[3] = (l >> 0) & 0xff; + return (0); +} + +static int put_hword(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + Tcl_Obj *o; + long l; + + if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 || + Tcl_GetLongFromObj(ti, o, &l) != TCL_OK) + return (-1); + p[0] = (l >> 0) & 0xff; + p[1] = (l >> 8) & 0xff; + return (0); +} + +static int put_const(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + *p = cd->x; + return (0); +} + +static int put_seed(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + Tcl_Obj *o; + world *w; + + if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 || + (w = world_get(ti, o)) == 0) + return (-1); + memcpy(p, w->x, 6); + return (0); +} + +static int put_bool(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + Tcl_Obj *o; + int b; + + if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 || + Tcl_GetBooleanFromObj(ti, o, &b) != TCL_OK) + return (-1); + *p = b ? cd->x : 0; + return (0); +} + +static int put_items(Tcl_Interp *ti, /*const*/ char *arr, + unsigned char *p, const struct cmddata *cd) +{ + char buf[32]; + int ii; + Tcl_Obj *o; + const struct item *i; + + for (i = items; i->name; i++) { + sprintf(buf, "%s-%s", cd->name, i->name); + if ((o = Tcl_GetVar2Ex(ti, arr, buf, TCL_LEAVE_ERR_MSG)) == 0 || + Tcl_GetIntFromObj(ti, o, &ii) != TCL_OK) + return (-1); + *p++ = ii; + } + return (0); +} + +static struct cmddata cmdtab[] = { + { "mission", 0, get_byte, put_byte, 0 }, + { "world-x", 1, get_byte, put_byte, 0 }, + { "world-y", 2, get_byte, put_byte, 0 }, + { "gal-seed", 3, get_seed, put_seed, 0 }, + { "credits", 9, get_word, put_word, 0 }, + { "fuel", 13, get_byte, put_byte, 0 }, + { "", 14, 0, put_const, 4 }, + { "gal-number", 15, get_byte, put_byte, -1 }, + { "front-laser", 16, get_byte, put_byte, 0 }, + { "rear-laser", 17, get_byte, put_byte, 0 }, + { "left-laser", 18, get_byte, put_byte, 0 }, + { "right-laser", 19, get_byte, put_byte, 0 }, + { "cargo", 22, get_byte, put_byte, 2 }, + { "hold", 23, get_items, put_items, 0 }, + { "ecm", 40, get_bool, put_bool, 255 }, + { "fuel-scoop", 41, get_bool, put_bool, 255 }, + { "energy-bomb", 42, get_bool, put_bool, 127 }, + { "energy-unit", 43, get_byte, put_byte, 0 }, + { "docking-computer", 44, get_bool, put_bool, 255 }, + { "gal-hyperdrive", 45, get_bool, put_bool, 255 }, + { "escape-pod", 46, get_bool, put_bool, 255 }, + { "missiles", 51, get_byte, put_byte, 0 }, + { "legal-status", 52, get_byte, put_byte, 0 }, + { "station", 53, get_items, put_items, 0 }, + { "market-fluc", 70, get_byte, put_byte, 0 }, + { "score", 71, get_hword, put_hword, 0 }, + { "", 74, 0, put_const, 32 }, + { 0, 0, 0, 0, 0 } +}; + +/* --- elite-unpackcmdr [-force] ARR DATA --- */ + +static int cmd_unpackcmdr(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + char *arr; + unsigned char *p, *q; + int sz; + unsigned f = 0; + unsigned ck; + const struct cmddata *c; + +#define f_force 1u + + /* --- Read the arguments --- */ + + objc--; objv++; + while (objc) { + char *opt = Tcl_GetString(*objv); + if (strcmp(opt, "-force") == 0) + f |= f_force; + else if (strcmp(opt, "--") == 0) { + objc--; + objv++; + break; + } else + break; + objc--; + objv++; + } + if (objc != 2) + return (err(ti, "usage: elite-unpackcmdr [-force] ARR DATA")); + arr = Tcl_GetString(objv[0]); + p = Tcl_GetByteArrayFromObj(objv[1], &sz); + + /* --- Check the data for correctness --- */ + + if (sz < 74) + return (err(ti, "bad commander data (bad length)")); + ck = cksum(p, 74); + if (!(f & f_force)) { + if (sz < 76 || p[74] != (ck ^ 0xa9) || p[75] != ck) + return (err(ti, "bad commander data (bad checksum)")); + for (q = p + 77; q < p + sz; q++) + if (*q) + return (err(ti, "bad commander data (bad data at end)")); + } + + /* --- Deconstruct the data --- */ + + for (c = cmdtab; c->name; c++) { + if (c->get && c->get(ti, arr, p + c->off, c)) + return (TCL_ERROR); + } + return (0); +} + +/* --- elite-packcmdr ARR --- */ + +static int cmd_packcmdr(ClientData cd, Tcl_Interp *ti, + int objc, Tcl_Obj *const *objv) +{ + char *arr; + unsigned char p[256]; + unsigned ck; + const struct cmddata *c; + + if (objc != 2) + return (err(ti, "usage: elite-packcmdr ARR")); + arr = Tcl_GetString(objv[1]); + + memset(p, 0, sizeof(p)); + for (c = cmdtab; c->name; c++) { + if (c->put && c->put(ti, arr, p + c->off, c)) + return (TCL_ERROR); + } + + ck = cksum(p, 74); + p[74] = ck ^ 0xa9; + p[75] = ck; + Tcl_SetObjResult(ti, Tcl_NewByteArrayObj(p, sizeof(p))); + return (0); +} + +/*----- Initialization ----------------------------------------------------*/ + +int Elite_SafeInit(Tcl_Interp *ti) +{ + static const struct cmd { + /*const*/ char *name; + Tcl_ObjCmdProc *proc; + } cmds[] = { + { "elite-nextworld", cmd_nextworld }, + { "elite-nextgalaxy", cmd_nextgalaxy }, + { "elite-worldinfo", cmd_worldinfo }, + { "elite-market", cmd_market }, + { "elite-unpackcmdr", cmd_unpackcmdr }, + { "elite-packcmdr", cmd_packcmdr }, + { 0, 0 } + }; + + const struct cmd *c; + for (c = cmds; c->name; c++) + Tcl_CreateObjCommand(ti, c->name, c->proc, 0, 0); + Tcl_RegisterObjType(&world_type); + if (Tcl_PkgProvide(ti, "elite-bits", "1.0.0")) + return (TCL_ERROR); + return (TCL_OK); +} + +int Elite_Init(Tcl_Interp *ti) +{ + return (Elite_SafeInit(ti)); +} + +/*----- That's all, folks -------------------------------------------------*/ diff --git a/elite.def b/elite.def new file mode 100644 index 0000000..b6bf146 --- /dev/null +++ b/elite.def @@ -0,0 +1,3 @@ +EXPORTS + Elite_Init @1 + Elite_SafeInit @2 diff --git a/elite.tcl b/elite.tcl new file mode 100644 index 0000000..f353a8b --- /dev/null +++ b/elite.tcl @@ -0,0 +1,405 @@ +#! /usr/bin/tclsh + +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 { + set a($i) $v + incr i + } +} + +# --- Various standard tables --- + +tab government \ + "anarchy" "feudal" "multi-government" "dictatorship" \ + "communist" "confederacy" "democracy" "corporate state" + +tab economy \ + "rich industrial" "average industrial" "poor industrial" \ + "mainly industrial" "mainly agricultural" "rich agricultural" \ + "average agricultural" "poor agricultural" + +tab gov \ + anarchy feudal multi-gov dictator \ + communist confed democracy corp-state + +tab eco \ + rich-ind ave-ind poor-ind mainly-ind \ + mainly-agri rich-agri ave-agri poor-agri + +set products { + food "Food" + textiles "Textiles" + radioactives "Radioactives" + slaves "Slaves" + liquor-wines "Liquor & wines" + luxuries "Luxuries" + narcotics "Narcotics" + computers "Computers" + machinery "Machinery" + alloys "Alloys" + firearms "Firearms" + furs "Furs" + minerals "Minerals" + gold "Gold" + platinum "Platinum" + gem-stones "Gem-stones" + alien-items "Alien items" +} + +foreach p $products { set unit($p) t } +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. + +proc galaxy [list n [list g $galaxy1]] { + 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} { + upvar 1 $p pp + for {set i 0} {$i < 256} {incr i; set g [elite-nextworld $g]} { + elite-worldinfo pp $g + 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} { + set l {} + foreach-world $g p { + if {[string match -nocase $pat $p(name)]} { + lappend l $p(seed) + } + } + 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} { + if {![string compare $pp "."]} { + return + } elseif {[llength $pp] == 0} { + return + } elseif {[llength $pp] == 1} { + upvar 1 $pp p + set p $xx + } else { + foreach p $pp x $xx { + uplevel 1 [list destructure $p $x] + } + } +} + +# --- 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} { + set min 10000 + foreach {ss xx yy} $ww { + set dx [expr {abs($x - $xx)/4}] + set dy [expr {abs($y - $yy)/2}] + if {$dx > $dy} { + set d [expr {($dx * 2 + $dy)/2}] + } else { + set d [expr {($dx + $dy * 2)/2}] + } + if {$d < $min} { + set p $ss + set min $d + } + } + 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} { + 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} { + upvar 1 $adjvar adj + if {[string equal $from $to]} { return [list $to 0] } + set l($from) 0 + set p($from) $from + set c $from + while 1 { + foreach {n x y} $adj($c) { + if {[info exists l($n)]} { + continue + } + set w [expr {$l($c) + [uplevel 1 $weight [list $c $n]]}] + if {![info exists ll($n)] || $w < $ll($n)} { + set ll($n) $w + set p($n) [concat $p($c) [list $n]] + } + } + set s [array startsearch ll] + if {![array anymore ll $s]} { + return {{} 0} + } + set c [array nextelement ll $s] + set w $ll($c) + while {[array anymore ll $s]} { + set n [array nextelement ll $s] + if {$ll($n) < $w} { + set c $n + set w $ll($n) + } + } + if {[string equal $c $to]} { return [list $p($to) $ll($to)] } + set l($c) $ll($c) + unset ll($c) + } +} + +# --- weight-hops A B --- +# +# shortest-path weight function giving each hop the same weight. + +proc weight-hops {from to} { + return 1 +} + +# --- weight-fuel A B --- +# +# shortest-path weight function measuring the distance between FROM and TO. + +proc weight-fuel {from to} { + elite-worldinfo f $from + elite-worldinfo t $to + return [world-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} { + 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} { + 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} { + 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} { + switch -regexp -- $g { + {^[1-8]$} { return [list $g [galaxy $g]] } + {^[0-9a-fA-F]{12}$} { return [list $g $g] } + default { + if {[regexp {^([0-9a-fA-F]{12}):([1-8])$} $g . b n]} { + return [list $g [galaxy $n $b]] + } + } + } + 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} { + if {[regexp {^[0-9a-fA-F]{12}$} $p]} { return $p } + if {[regexp {^(.+)\.(.+)$} $p . g p]} { + set g [parse-galaxy-spec $g] + if {[string equal $g ""]} { return {} } + destructure {. g} $g + return [parse-planet-spec $g $p] + } + if {[regexp {^(0x[0-9a-fA-F]+|[0-9]+)$} $p]} { + for {set s $g; set i 0} {$i < $p} {incr i; set s [elite-nextworld $s]} {} + return $s + } + 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] + } + 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} { + 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} { + global eco gov + elite-worldinfo p $s + return [format "%-12s %4d %4d %-11s %-10s %2d %s" \ + $p(name) $p(x) $p(y) \ + $eco($p(economy)) $gov($p(government)) $p(techlevel) $p(seed)] +} + +#----- That's all, folks ---------------------------------------------------- + +package provide "elite" "1.0.0" -- [mdw]