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

   1 /* -*-c-*-
   2  *
   3  * $Id$
   4  *
   5  * Elite planet data
   6  *
   7  * (c) 2003 Mark Wooding
   8  */
   9
  10 /*----- Licensing notice --------------------------------------------------*
  11  *
  12  * This program is free software; you can redistribute it and/or modify
  13  * it under the terms of the GNU General Public License as published by
  14  * the Free Software Foundation; either version 2 of the License, or
  15  * (at your option) any later version.
  16  *
  17  * This program is distributed in the hope that it will be useful,
  18  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  19  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20  * GNU General Public License for more details.
  21  *
  22  * You should have received a copy of the GNU General Public License
  23  * along with this program; if not, write to the Free Software Foundation,
  24  * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25  */
  26
  27 /*----- Header files ------------------------------------------------------*/
  28
  29 #include <ctype.h>
  30 #include <math.h>
  31 #include <stdio.h>
  32 #include <stdlib.h>
  33 #include <string.h>
  34
  35 #include <tcl.h>
  36
  37
  38 /*----- Data structures ---------------------------------------------------*/
  39
  40 typedef struct world {
  41   unsigned char x[6];
  42 } world;
  43
  44 typedef struct worldinfo {
  45   unsigned x, y, gov, eco, tech, pop, prod, rad;
  46 } worldinfo;
  47
  48 /*----- The world type ----------------------------------------------------*/
  49
  50 static void world_fir(Tcl_Obj *o)
  51 {
  52   Tcl_Free(o->internalRep.otherValuePtr);
  53 }
  54
  55 static int xtoi(unsigned x)
  56 {
  57   if (x >= '0' && x <= '9')
  58     return (x - '0');
  59   else if (x >= 'a' && x <= 'f')
  60     return (x - 'a' + 10);
  61   else if (x >= 'A' && x <= 'F')
  62     return (x - 'A' + 10);
  63   else
  64     abort();
  65 }
  66
  67 static Tcl_ObjType world_type;
  68
  69 static int world_sfa(Tcl_Interp *ti, Tcl_Obj *o)
  70 {
  71   int l;
  72   world ww, *w;
  73   int i;
  74   char *p = Tcl_GetStringFromObj(o, &l);
  75   if (l != 12)
  76     goto bad;
  77   for (i = 0; i < 12; i += 2) {
  78     if (!isxdigit((unsigned char)p[i]) ||
  79         !isxdigit((unsigned char)p[i + 1]))
  80       goto bad;
  81     ww.x[i >> 1] = (xtoi(p[i]) << 4) | (xtoi(p[i + 1]));
  82   }
  83   w = (world *)Tcl_Alloc(sizeof(*w));
  84   *w = ww;
  85   o->internalRep.otherValuePtr = w;
  86   o->typePtr = &world_type;
  87   return (TCL_OK);
  88
  89 bad:
  90   if (ti)
  91     Tcl_SetResult(ti, "bad world seed string", TCL_STATIC);
  92   return (TCL_ERROR);
  93 }
  94
  95 static void world_us(Tcl_Obj *o)
  96 {
  97   char *p;
  98   world *w = o->internalRep.otherValuePtr;
  99   int i;
 100
 101   p = Tcl_Alloc(13);
 102   p[12] = 0;
 103   o->bytes = p;
 104   o->length = 12;
 105   for (i = 0; i < 6; i++, p += 2)
 106     sprintf(p, "%02x", w->x[i]);
 107 }
 108
 109 static void world_dir(Tcl_Obj *o, Tcl_Obj *oo)
 110 {
 111   world *w = (world *)Tcl_Alloc(sizeof(*w));
 112   memcpy(w, o->internalRep.otherValuePtr, sizeof(world));
 113   oo->internalRep.otherValuePtr = w;
 114   oo->typePtr = &world_type;
 115   Tcl_InvalidateStringRep(oo);
 116 }
 117
 118 static /*const*/ Tcl_ObjType world_type = {
 119   "elite-world", world_fir, world_dir, world_us, world_sfa
 120 };
 121
 122 static world *world_get(Tcl_Interp *ti, Tcl_Obj *o)
 123 {
 124   if (Tcl_ConvertToType(ti, o, &world_type) != TCL_OK)
 125     return (0);
 126   return (o->internalRep.otherValuePtr);
 127 }
 128
 129 static Tcl_Obj *world_new(const world *w)
 130 {
 131   world *ww;
 132   Tcl_Obj *o = Tcl_NewObj();
 133   ww = (world *)Tcl_Alloc(sizeof(*ww));
 134   *ww = *w;
 135   o->internalRep.otherValuePtr = ww;
 136   o->typePtr = &world_type;
 137   Tcl_InvalidateStringRep(o);
 138   return (o);
 139 }
 140
 141 /*----- Elite-specific hacking --------------------------------------------*
 142  *
 143  * Taken from `Elite: The New Kind' by Christian Pinder.
 144  */
 145
 146 static void waggle(world *w, world *ww)
 147 {
 148   unsigned int h, l;
 149
 150   /* --- What goes on --- *
 151    *
 152    * 16-bit add of all three words, shift up, and insert the new value at the
 153    * end.
 154    */
 155
 156   l = w->x[0];
 157   h = w->x[1];
 158   l += w->x[2];
 159   h += w->x[3] + (l >= 0x100);
 160   l &= 0xff; h &= 0xff;
 161   l += w->x[4];
 162   h += w->x[5] + (l >= 0x100);
 163   l &= 0xff; h &= 0xff;
 164   ww->x[0] = w->x[2]; ww->x[1] = w->x[3];
 165   ww->x[2] = w->x[4]; ww->x[3] = w->x[5];
 166   ww->x[4] = l; ww->x[5] = h;
 167 }
 168
 169 /*----- Tcl commands ------------------------------------------------------*/
 170
 171 static int err(Tcl_Interp *ti, /*const*/ char *p)
 172 {
 173   Tcl_SetResult(ti, p, TCL_STATIC);
 174   return (TCL_ERROR);
 175 }
 176
 177 /* --- elite-nextworld SEED --- */
 178
 179 static int cmd_nextworld(ClientData cd, Tcl_Interp *ti,
 180                          int objc, Tcl_Obj *const *objv)
 181 {
 182   world *w, ww;
 183   if (objc != 2)
 184     return (err(ti, "usage: elite-nextworld SEED"));
 185   if ((w = world_get(ti, objv[1])) == 0)
 186     return (TCL_ERROR);
 187   waggle(w, &ww);
 188   waggle(&ww, &ww);
 189   waggle(&ww, &ww);
 190   waggle(&ww, &ww);
 191   Tcl_SetObjResult(ti, world_new(&ww));
 192   return (TCL_OK);
 193 }
 194
 195 /* --- elite-nextgalaxy SEED --- */
 196
 197 static int cmd_nextgalaxy(ClientData cd, Tcl_Interp *ti,
 198                           int objc, Tcl_Obj *const *objv)
 199 {
 200   world *w, ww;
 201   int i;
 202
 203   if (objc != 2)
 204     return (err(ti, "usage: elite-nextgalaxy SEED"));
 205   if ((w = world_get(ti, objv[1])) == 0)
 206     return (TCL_ERROR);
 207   for (i = 0; i < 6; i++)
 208     ww.x[i] = ((w->x[i] << 1) | (w->x[i] >> 7)) & 0xff;
 209   Tcl_SetObjResult(ti, world_new(&ww));
 210   return (TCL_OK);
 211 }
 212
 213 /* --- elite-worldinfo ARR SEED --- */
 214
 215 static void getworldinfo(worldinfo *wi, world *w)
 216 {
 217   wi->x = w->x[3];
 218   wi->y = w->x[1];
 219   wi->gov = (w->x[2] >> 3) & 0x07;
 220   wi->eco = w->x[1] & 0x07;
 221   if (wi->gov < 2)
 222     wi->eco |= 0x02;
 223   wi->tech = ((wi->eco ^ 7) + (w->x[3] & 0x03) +
 224               (wi->gov >> 1) + (wi->gov & 0x01) + 1);
 225   wi->pop = wi->tech * 4 + wi->gov + wi->eco - 3;
 226   wi->prod = ((wi->eco ^ 7) + 3) * (wi->gov + 4) * wi->pop * 8;
 227   wi->rad = (((w->x[5] & 0x0f) + 11) << 8) + w->x[3];
 228 }
 229
 230 static const char digrams[] =
 231   "abouseitiletstonlonuthnoallexegezacebisouses"
 232   "armaindirea?eratenberalavetiedorquanteisrion";
 233
 234 static const char *const desc[][5] = {
 235 /*  0 */ { "fabled", "notable", "well known", "famous", "noted" },
 236 /*  1 */ { "very ", "mildly ", "most ", "reasonably ", "" },
 237 /*  2 */ { "ancient", "<20>", "great", "vast", "pink" },
 238 /*  3 */ { "<29> <28> plantations", "mountains", "<27>",
 239            "<19> forests", "oceans" },
 240 /*  4 */ { "shyness", "silliness", "mating traditions",
 241            "loathing of <5>", "love for <5>" },
 242 /*  5 */ { "food blenders", "tourists", "poetry", "discos", "<13>" },
 243 /*  6 */ { "talking tree", "crab", "bat", "lobst", "%R" },
 244 /*  7 */ { "beset", "plagued", "ravaged", "cursed", "scourged" },
 245 /*  8 */ { "<21> civil war", "<26> <23> <24>s",
 246            "a <26> disease", "<21> earthquakes", "<21> solar activity" },
 247 /*  9 */ { "its <2> <3>", "the %I <23> <24>",
 248            "its inhabitants' <25> <4>", "<32>", "its <12> <13>" },
 249 /* 10 */ { "juice", "brandy", "water", "brew", "gargle blasters" },
 250 /* 11 */ { "%R", "%I <24>", "%I %R", "%I <26>", "<26> %R" },
 251 /* 12 */ { "fabulous", "exotic", "hoopy", "unusual", "exciting" },
 252 /* 13 */ { "cuisine", "night life", "casinos", "sit coms", " <32>" },
 253 /* 14 */ { "%H", "The planet %H", "The world %H",
 254            "This planet", "This world" },
 255 /* 15 */ { "n unremarkable", " boring", " dull", " tedious", " revolting" },
 256 /* 16 */ { "planet", "world", "place", "little planet", "dump" },
 257 /* 17 */ { "wasp", "moth", "grub", "ant", "%R" },
 258 /* 18 */ { "poet", "arts graduate", "yak", "snail", "slug" },
 259 /* 19 */ { "tropical", "dense", "rain", "impenetrable", "exuberant" },
 260 /* 20 */ { "funny", "weird", "unusual", "strange", "peculiar" },
 261 /* 21 */ { "frequent", "occasional", "unpredictable", "dreadful", "deadly" },
 262 /* 22 */ { "<1><0> for <9>", "<1><0> for <9> and <9>",
 263            "<7> by <8>", "<1><0> for <9> but <7> by <8>","a<15> <16>" },
 264 /* 23 */ { "<26>", "mountain", "edible", "tree", "spotted" },
 265 /* 24 */ { "<30>", "<31>", "<6>oid", "<18>", "<17>" },
 266 /* 25 */ { "ancient", "exceptional", "eccentric", "ingrained", "<20>" },
 267 /* 26 */ { "killer", "deadly", "evil", "lethal", "vicious" },
 268 /* 27 */ { "parking meters", "dust clouds", "ice bergs",
 269            "rock formations", "volcanoes" },
 270 /* 28 */ { "plant", "tulip", "banana", "corn", "%Rweed" },
 271 /* 29 */ { "%R", "%I %R", "%I <26>", "inhabitant", "%I %R" },
 272 /* 30 */ { "shrew", "beast", "bison", "snake", "wolf" },
 273 /* 31 */ { "leopard", "cat", "monkey", "goat", "fish" },
 274 /* 32 */ { "<11> <10>", "%I <30> <33>", "its <12> <31> <33>",
 275            "<34> <35>", "<11> <10>" },
 276 /* 33 */ { "meat", "cutlet", "steak", "burgers", "soup" },
 277 /* 34 */ { "ice", "mud", "Zero-G", "vacuum", "%I ultra" },
 278 /* 35 */ { "hockey", "cricket", "karate", "polo", "tennis" }
 279 };
 280
 281 static int mangle(world *w)
 282 {
 283   unsigned a, x;
 284
 285   x = (w->x[2] << 1) & 0xff;
 286   a = x + w->x[4];
 287   if (w->x[2] & 0x80)
 288     a++;
 289   w->x[2] = a & 0xff;
 290   w->x[4] = x;
 291   a >>= 8;
 292   x = w->x[3];
 293   a = (a + x + w->x[5]) & 0xff;
 294   w->x[3] = a;
 295   w->x[5] = x;
 296   return (a);
 297 }
 298
 299 static void goatsoup(Tcl_Obj *d, const char *pn, world *w, const char *p)
 300 {
 301   for (;;) {
 302     size_t sz = strcspn(p, "<%");
 303     unsigned n;
 304     char buf[12];
 305     char *q;
 306
 307     Tcl_AppendToObj(d, (char *)p, sz);
 308     p += sz;
 309     switch (*p) {
 310       unsigned i, j;
 311       case 0:
 312         return;
 313       case '<':
 314         i = strtoul(p + 1, (char **)&p, 10);
 315         p++;
 316         j = mangle(w);
 317         goatsoup(d, pn, w, desc[i][(j >= 0x33) + (j >= 0x66) +
 318                                    (j >= 0x99) + (j >= 0xcc)]);
 319         break;
 320       case '%':
 321         p++;
 322         switch (*p++) {
 323           case 'H':
 324             Tcl_AppendToObj(d, (char *)pn, -1);
 325             break;
 326           case 'I':
 327             sz = strlen(pn) - 1;
 328             Tcl_AppendToObj(d, (char *)pn,
 329                             (pn[sz] == 'i' || pn[sz] == 'e') ? sz : sz + 1);
 330             Tcl_AppendToObj(d, "ian", 3);
 331             break;
 332           case 'R':
 333             n = (mangle(w) & 0x03) + 1;
 334             q = buf;
 335             while (n--) {
 336               unsigned i = mangle(w) & 0x3e;
 337               *q++ = digrams[i++];
 338               if (digrams[i] != '?')
 339                 *q++ = digrams[i++];
 340             }
 341             *buf = toupper(*buf);
 342             Tcl_AppendToObj(d, buf, q - buf);
 343             break;
 344           default:
 345             abort();
 346         }
 347         break;
 348       default:
 349         abort();
 350     }
 351   }
 352 }
 353
 354 static int cmd_worldinfo(ClientData cd, Tcl_Interp *ti,
 355                          int objc, Tcl_Obj *const *objv)
 356 {
 357   world *w;
 358   worldinfo wi;
 359   char *arr;
 360   char buf[9];
 361   char *p;
 362   unsigned j, n;
 363   Tcl_Obj *o;
 364   world ww;
 365
 366   /* --- Check arguments --- */
 367
 368   if (objc != 3)
 369     return (err(ti, "usage: elite-worldinfo ARR SEED"));
 370   if ((w = world_get(ti, objv[2])) == 0)
 371     return (TCL_ERROR);
 372   arr = Tcl_GetString(objv[1]);
 373
 374   /* --- Get the basic information --- */
 375
 376   getworldinfo(&wi, w);
 377   Tcl_UnsetVar(ti, arr, 0);
 378   if (!Tcl_SetVar2Ex(ti, arr, "x", Tcl_NewIntObj(wi.x * 4),
 379                      TCL_LEAVE_ERR_MSG) ||
 380       !Tcl_SetVar2Ex(ti, arr, "y", Tcl_NewIntObj(wi.y * 2),
 381                      TCL_LEAVE_ERR_MSG) ||
 382       !Tcl_SetVar2Ex(ti, arr, "government", Tcl_NewIntObj(wi.gov),
 383                     TCL_LEAVE_ERR_MSG) ||
 384       !Tcl_SetVar2Ex(ti, arr, "economy", Tcl_NewIntObj(wi.eco),
 385                      TCL_LEAVE_ERR_MSG) ||
 386       !Tcl_SetVar2Ex(ti, arr, "techlevel", Tcl_NewIntObj(wi.tech),
 387                     TCL_LEAVE_ERR_MSG) ||
 388       !Tcl_SetVar2Ex(ti, arr, "population", Tcl_NewIntObj(wi.pop),
 389                     TCL_LEAVE_ERR_MSG) ||
 390       !Tcl_SetVar2Ex(ti, arr, "productivity", Tcl_NewIntObj(wi.prod),
 391                     TCL_LEAVE_ERR_MSG) ||
 392       !Tcl_SetVar2Ex(ti, arr, "radius", Tcl_NewIntObj(wi.rad),
 393                      TCL_LEAVE_ERR_MSG) ||
 394       !Tcl_SetVar2Ex(ti, arr, "seed", objv[2],
 395                      TCL_LEAVE_ERR_MSG))
 396     return (TCL_ERROR);
 397
 398   /* --- Work out the inhabitants --- */
 399
 400   if (!(w->x[4] & 0x80)) {
 401     if (!Tcl_SetVar2(ti, arr, "inhabitants", "humans", TCL_LEAVE_ERR_MSG))
 402       return (TCL_ERROR);
 403   } else {
 404     static const char *const id_a[] = { "large", "fierce", "small" };
 405     static const char *const id_b[] = { "green", "red", "yellow", "blue",
 406                                         "black", "harmless" };
 407     static const char *const id_c[] = { "slimy", "bug-eyed", "horned",
 408                                         "bony", "fat", "furry" };
 409     static const char *const id_d[] = { "rodents", "frogs", "lizards",
 410                                         "lobsters", "birds", "humanoids",
 411                                         "felines", "insects" };
 412
 413     o = Tcl_NewListObj(0, 0);
 414     j = (w->x[5] >> 2) & 0x07;
 415     if (j < 3)
 416       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_a[j], -1));
 417     j = (w->x[5] >> 5) & 0x07;
 418     if (j < 6)
 419       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_b[j], -1));
 420     j = (w->x[1] ^ w->x[3]) & 0x07;
 421     if (j < 6)
 422       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_c[j], -1));
 423     j += w->x[5] & 0x03;
 424       Tcl_ListObjAppendElement(ti, o, Tcl_NewStringObj(id_d[j & 0x07], -1));
 425     if (!Tcl_SetVar2Ex(ti, arr, "inhabitants", o, TCL_LEAVE_ERR_MSG))
 426       return (TCL_ERROR);
 427   }
 428
 429   /* --- Work out the planet name --- */
 430
 431   n = (w->x[0] & 0x40) ? 4 : 3;
 432   p = buf;
 433   ww = *w;
 434   while (n--) {
 435     j = ww.x[5] & 0x1f;
 436     if (j) {
 437       j = (j + 12) << 1;
 438       *p++ = digrams[j++];
 439       if (digrams[j] != '?')
 440         *p++ = digrams[j];
 441     }
 442     waggle(&ww, &ww);
 443   }
 444   *p++ = 0;
 445   *buf = toupper(*buf);
 446   if (!Tcl_SetVar2Ex(ti, arr, "name", Tcl_NewStringObj(buf, -1),
 447                      TCL_LEAVE_ERR_MSG))
 448     return (TCL_ERROR);
 449
 450   /* --- Finally work out the goat-soup description --- */
 451
 452   ww = *w;
 453   o = Tcl_NewStringObj(0, 0);
 454   goatsoup(o, buf, &ww, "<14> is <22>.");
 455   if (!Tcl_SetVar2Ex(ti, arr, "description", o, TCL_LEAVE_ERR_MSG))
 456     return (TCL_ERROR);
 457   return (TCL_OK);
 458 }
 459
 460 /* --- elite-market ARR SEED [FLUC] --- */
 461
 462 static const struct item {
 463   /*const*/ char *name;
 464   unsigned base;
 465   int var;
 466   unsigned qty;
 467   unsigned mask;
 468 } items[] = {
 469   { "food",              19, -2,   6, 0x01 },
 470   { "textiles",          20, -1,  10, 0x03 },
 471   { "radioactives",      65, -3,   2, 0x07 },
 472   { "slaves",            40, -5, 226, 0x1f },
 473   { "liquor-wines",      83, -5, 251, 0x0f },
 474   { "luxuries",         196,  8,  54, 0x03 },
 475   { "narcotics",        235, 29,   8, 0x78 },
 476   { "computers",        154, 14,  56, 0x03 },
 477   { "machinery",        117,  6,  40, 0x07 },
 478   { "alloys",            78,  1,  17, 0x1f },
 479   { "firearms",         124, 13,  29, 0x07 },
 480   { "furs",             176, -9, 220, 0x3f },
 481   { "minerals",          32, -1,  53, 0x03 },
 482   { "gold",              97, -1,  66, 0x07 },
 483   { "platinum",         171, -2,  55, 0x1f },
 484   { "gem-stones",        45, -1, 250, 0x0f },
 485   { "alien-items",       53, 15, 192, 0x07 },
 486   { 0,                    0,  0,   0, 0x00 }
 487 };
 488
 489 static int cmd_market(ClientData cd, Tcl_Interp *ti,
 490                       int objc, Tcl_Obj *const *objv)
 491 {
 492   int fluc = 0;
 493   world *w;
 494   worldinfo wi;
 495   const struct item *i;
 496   char *arr;
 497
 498   if (objc < 3 || objc > 5)
 499     return (err(ti, "usage: elite-market ARR SEED [FLUC]"));
 500   if ((w = world_get(ti, objv[2])) == 0)
 501     return (TCL_ERROR);
 502   arr = Tcl_GetString(objv[1]);
 503   if (objc >= 4 && Tcl_GetIntFromObj(ti, objv[3], &fluc) != TCL_OK)
 504     return (TCL_ERROR);
 505   getworldinfo(&wi, w);
 506
 507   Tcl_UnsetVar(ti, arr, 0);
 508   for (i = items; i->name; i++) {
 509     unsigned pr, qt;
 510     Tcl_Obj *oo[2];
 511     pr = (i->base + (fluc & i->mask) + (wi.eco * i->var)) & 0xff;
 512     qt = (i->qty + (fluc & i->mask) - (wi.eco * i->var)) & 0xff;
 513     if (qt & 0x80)
 514       qt = 0;
 515     oo[0] = Tcl_NewIntObj(pr << 2);
 516     oo[1] = Tcl_NewIntObj(qt & 0x3f);
 517     if (!Tcl_SetVar2Ex(ti, arr, i->name, Tcl_NewListObj(2, oo),
 518                       TCL_LEAVE_ERR_MSG))
 519       return (TCL_ERROR);
 520   }
 521   return (TCL_OK);
 522 }
 523
 524 /*----- Commander file decomposition --------------------------------------*/
 525
 526 static unsigned cksum(const unsigned char *p, size_t sz)
 527 {
 528   unsigned a = 0x49, c = 0;
 529
 530   p += sz - 1;
 531   while (--sz) {
 532     a += *--p + c;
 533     c = a >> 8;
 534     a &= 0xff;
 535     a ^= p[1];
 536   }
 537   fflush(stdout);
 538   return (a);
 539 }
 540
 541 /* --- The big translation table --- */
 542
 543 struct cmddata {
 544   /*const*/ char *name;
 545   unsigned off;
 546   int (*get)(Tcl_Interp *, /*const*/ char *,
 547              const unsigned char *, const struct cmddata *);
 548   int (*put)(Tcl_Interp *, /*const*/ char *,
 549              unsigned char *, const struct cmddata *);
 550   int x;
 551 };
 552
 553 static int get_byte(Tcl_Interp *ti, /*const*/ char *arr,
 554                     const unsigned char *p, const struct cmddata *cd)
 555 {
 556   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
 557                          Tcl_NewIntObj(*p - cd->x), TCL_LEAVE_ERR_MSG));
 558 }
 559
 560 static int get_seed(Tcl_Interp *ti, /*const*/ char *arr,
 561                     const unsigned char *p, const struct cmddata *cd)
 562 {
 563   world w;
 564
 565   memcpy(w.x, p, 6);
 566   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
 567                          world_new(&w), TCL_LEAVE_ERR_MSG));
 568 }
 569
 570 static int get_word(Tcl_Interp *ti, /*const*/ char *arr,
 571                     const unsigned char *p, const struct cmddata *cd)
 572 {
 573   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
 574                          Tcl_NewLongObj((p[0] & 0xff) << 24 |
 575                                         (p[1] & 0xff) << 16 |
 576                                         (p[2] & 0xff) <<  8 |
 577                                         (p[3] & 0xff) <<  0),
 578                          TCL_LEAVE_ERR_MSG));
 579 }
 580
 581 static int get_hword(Tcl_Interp *ti, /*const*/ char *arr,
 582                      const unsigned char *p, const struct cmddata *cd)
 583 {
 584   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
 585                          Tcl_NewLongObj((p[0] & 0xff) << 0 |
 586                                         (p[1] & 0xff) << 8),
 587                          TCL_LEAVE_ERR_MSG));
 588 }
 589
 590 static int get_bool(Tcl_Interp *ti, /*const*/ char *arr,
 591                     const unsigned char *p, const struct cmddata *cd)
 592 {
 593   return (!Tcl_SetVar2Ex(ti, arr, cd->name,
 594                          Tcl_NewBooleanObj(*p), TCL_LEAVE_ERR_MSG));
 595 }
 596
 597 static int get_items(Tcl_Interp *ti, /*const*/ char *arr,
 598                      const unsigned char *p, const struct cmddata *cd)
 599 {
 600   char buf[32];
 601   const struct item *i;
 602
 603   for (i = items; i->name; i++) {
 604     sprintf(buf, "%s-%s", cd->name, i->name);
 605     if (!Tcl_SetVar2Ex(ti, arr, buf,
 606                        Tcl_NewIntObj(*p++), TCL_LEAVE_ERR_MSG))
 607       return (-1);
 608   }
 609   return (0);
 610 }
 611
 612 static int put_byte(Tcl_Interp *ti, /*const*/ char *arr,
 613                     unsigned char *p, const struct cmddata *cd)
 614 {
 615   Tcl_Obj *o;
 616   int i;
 617
 618   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
 619       Tcl_GetIntFromObj(ti, o, &i) != TCL_OK)
 620     return (-1);
 621   *p = i + cd->x;
 622   return (0);
 623 }
 624
 625 static int put_word(Tcl_Interp *ti, /*const*/ char *arr,
 626                     unsigned char *p, const struct cmddata *cd)
 627 {
 628   Tcl_Obj *o;
 629   long l;
 630
 631   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
 632       Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
 633     return (-1);
 634   p[0] = (l >> 24) & 0xff;
 635   p[1] = (l >> 16) & 0xff;
 636   p[2] = (l >>  8) & 0xff;
 637   p[3] = (l >>  0) & 0xff;
 638   return (0);
 639 }
 640
 641 static int put_hword(Tcl_Interp *ti, /*const*/ char *arr,
 642                      unsigned char *p, const struct cmddata *cd)
 643 {
 644   Tcl_Obj *o;
 645   long l;
 646
 647   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
 648       Tcl_GetLongFromObj(ti, o, &l) != TCL_OK)
 649     return (-1);
 650   p[0] = (l >> 0) & 0xff;
 651   p[1] = (l >> 8) & 0xff;
 652   return (0);
 653 }
 654
 655 static int put_const(Tcl_Interp *ti, /*const*/ char *arr,
 656                      unsigned char *p, const struct cmddata *cd)
 657 {
 658   *p = cd->x;
 659   return (0);
 660 }
 661
 662 static int put_seed(Tcl_Interp *ti, /*const*/ char *arr,
 663                     unsigned char *p, const struct cmddata *cd)
 664 {
 665   Tcl_Obj *o;
 666   world *w;
 667
 668   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
 669       (w = world_get(ti, o)) == 0)
 670     return (-1);
 671   memcpy(p, w->x, 6);
 672   return (0);
 673 }
 674
 675 static int put_bool(Tcl_Interp *ti, /*const*/ char *arr,
 676                     unsigned char *p, const struct cmddata *cd)
 677 {
 678   Tcl_Obj *o;
 679   int b;
 680
 681   if ((o = Tcl_GetVar2Ex(ti, arr, cd->name, TCL_LEAVE_ERR_MSG)) == 0 ||
 682       Tcl_GetBooleanFromObj(ti, o, &b) != TCL_OK)
 683     return (-1);
 684   *p = b ? cd->x : 0;
 685   return (0);
 686 }
 687
 688 static int put_items(Tcl_Interp *ti, /*const*/ char *arr,
 689                      unsigned char *p, const struct cmddata *cd)
 690 {
 691   char buf[32];
 692   int ii;
 693   Tcl_Obj *o;
 694   const struct item *i;
 695
 696   for (i = items; i->name; i++) {
 697     sprintf(buf, "%s-%s", cd->name, i->name);
 698     if ((o = Tcl_GetVar2Ex(ti, arr, buf, TCL_LEAVE_ERR_MSG)) == 0 ||
 699         Tcl_GetIntFromObj(ti, o, &ii) != TCL_OK)
 700       return (-1);
 701     *p++ = ii;
 702   }
 703   return (0);
 704 }
 705
 706 static struct cmddata cmdtab[] = {
 707   { "mission",           0,     get_byte,       put_byte,         0 },
 708   { "world-x",           1,     get_byte,       put_byte,         0 },
 709   { "world-y",           2,     get_byte,       put_byte,         0 },
 710   { "gal-seed",          3,     get_seed,       put_seed,         0 },
 711   { "credits",           9,     get_word,       put_word,         0 },
 712   { "fuel",             13,     get_byte,       put_byte,         0 },
 713   { "",                 14,     0,              put_const,        4 },
 714   { "gal-number",       15,     get_byte,       put_byte,        -1 },
 715   { "front-laser",      16,     get_byte,       put_byte,         0 },
 716   { "rear-laser",       17,     get_byte,       put_byte,         0 },
 717   { "left-laser",       18,     get_byte,       put_byte,         0 },
 718   { "right-laser",      19,     get_byte,       put_byte,         0 },
 719   { "cargo",            22,     get_byte,       put_byte,         2 },
 720   { "hold",             23,     get_items,      put_items,        0 },
 721   { "ecm",              40,     get_bool,       put_bool,       255 },
 722   { "fuel-scoop",       41,     get_bool,       put_bool,       255 },
 723   { "energy-bomb",      42,     get_bool,       put_bool,       127 },
 724   { "energy-unit",      43,     get_byte,       put_byte,         0 },
 725   { "docking-computer", 44,     get_bool,       put_bool,       255 },
 726   { "gal-hyperdrive",   45,     get_bool,       put_bool,       255 },
 727   { "escape-pod",       46,     get_bool,       put_bool,       255 },
 728   { "missiles",         51,     get_byte,       put_byte,         0 },
 729   { "legal-status",     52,     get_byte,       put_byte,         0 },
 730   { "station",          53,     get_items,      put_items,        0 },
 731   { "market-fluc",      70,     get_byte,       put_byte,         0 },
 732   { "score",            71,     get_hword,      put_hword,        0 },
 733   { "",                 74,     0,              put_const,       32 },
 734   { 0,                   0,     0,              0,                0 }
 735 };
 736
 737 /* --- elite-unpackcmdr [-force] ARR DATA --- */
 738
 739 static int cmd_unpackcmdr(ClientData cd, Tcl_Interp *ti,
 740                           int objc, Tcl_Obj *const *objv)
 741 {
 742   char *arr;
 743   unsigned char *p, *q;
 744   int sz;
 745   unsigned f = 0;
 746   unsigned ck;
 747   const struct cmddata *c;
 748
 749 #define f_force 1u
 750
 751   /* --- Read the arguments --- */
 752
 753   objc--; objv++;
 754   while (objc) {
 755     char *opt = Tcl_GetString(*objv);
 756     if (strcmp(opt, "-force") == 0)
 757       f |= f_force;
 758     else if (strcmp(opt, "--") == 0) {
 759       objc--;
 760       objv++;
 761       break;
 762     } else
 763       break;
 764     objc--;
 765     objv++;
 766   }
 767   if (objc != 2)
 768     return (err(ti, "usage: elite-unpackcmdr [-force] ARR DATA"));
 769   arr = Tcl_GetString(objv[0]);
 770   p = Tcl_GetByteArrayFromObj(objv[1], &sz);
 771
 772   /* --- Check the data for correctness --- */
 773
 774   if (sz < 74)
 775     return (err(ti, "bad commander data (bad length)"));
 776   ck = cksum(p, 74);
 777   if (!(f & f_force)) {
 778     if (sz < 76 || p[74] != (ck ^ 0xa9) || p[75] != ck)
 779       return (err(ti, "bad commander data (bad checksum)"));
 780     for (q = p + 77; q < p + sz; q++)
 781       if (*q)
 782         return (err(ti, "bad commander data (bad data at end)"));
 783   }
 784
 785   /* --- Deconstruct the data --- */
 786
 787   Tcl_UnsetVar(ti, arr, 0);
 788   for (c = cmdtab; c->name; c++) {
 789     if (c->get && c->get(ti, arr, p + c->off, c))
 790       return (TCL_ERROR);
 791   }
 792   return (0);
 793 }
 794
 795 /* --- elite-packcmdr ARR --- */
 796
 797 static int cmd_packcmdr(ClientData cd, Tcl_Interp *ti,
 798                        int objc, Tcl_Obj *const *objv)
 799 {
 800   char *arr;
 801   unsigned char p[256];
 802   unsigned ck;
 803   const struct cmddata *c;
 804
 805   if (objc != 2)
 806     return (err(ti, "usage: elite-packcmdr ARR"));
 807   arr = Tcl_GetString(objv[1]);
 808
 809   memset(p, 0, sizeof(p));
 810   for (c = cmdtab; c->name; c++) {
 811     if (c->put && c->put(ti, arr, p + c->off, c))
 812       return (TCL_ERROR);
 813   }
 814
 815   ck = cksum(p, 74);
 816   p[74] = ck ^ 0xa9;
 817   p[75] = ck;
 818   Tcl_SetObjResult(ti, Tcl_NewByteArrayObj(p, sizeof(p)));
 819   return (0);
 820 }
 821
 822 /*----- Optimizations -----------------------------------------------------*/
 823
 824 /* --- @elite-galaxylist SEED@ --- *
 825  *
 826  * Returns a SEED/X/Y list for the worlds in galaxy SEED.
 827  */
 828
 829 static int cmd_galaxylist(ClientData cd, Tcl_Interp *ti,
 830                           int objc, Tcl_Obj *const *objv)
 831 {
 832   world *w, ww;
 833   worldinfo wi;
 834   int i;
 835   Tcl_Obj *o;
 836
 837   if (objc != 2)
 838     return (err(ti, "usage: elite-galaxylist SEED"));
 839   if ((w = world_get(ti, objv[1])) == 0)
 840     return (TCL_ERROR);
 841   ww = *w;
 842   o = Tcl_NewListObj(0, 0);
 843   for (i = 0; i < 256; i++) {
 844     getworldinfo(&wi, &ww);
 845     Tcl_ListObjAppendElement(ti, o, world_new(&ww));
 846     Tcl_ListObjAppendElement(ti, o, Tcl_NewIntObj(wi.x * 4));
 847     Tcl_ListObjAppendElement(ti, o, Tcl_NewIntObj(wi.y * 2));
 848     waggle(&ww, &ww); waggle(&ww, &ww); waggle(&ww, &ww); waggle(&ww, &ww);
 849   }
 850   Tcl_SetObjResult(ti, o);
 851   return (TCL_OK);
 852 }
 853
 854 /* --- @elite-distance X Y XX YY@ --- *
 855  *
 856  * Returns the distance between two points.
 857  */
 858
 859 static int cmd_distance(ClientData cd, Tcl_Interp *ti,
 860                         int objc, Tcl_Obj *const *objv)
 861 {
 862   long x, y, xx, yy;
 863   long d;
 864
 865   if (objc != 5)
 866     return (err(ti, "usage: elite-distance X Y XX YY"));
 867   if (Tcl_GetLongFromObj(ti, objv[1], &x) != TCL_OK ||
 868       Tcl_GetLongFromObj(ti, objv[2], &y) != TCL_OK ||
 869       Tcl_GetLongFromObj(ti, objv[3], &xx) != TCL_OK ||
 870       Tcl_GetLongFromObj(ti, objv[4], &yy) != TCL_OK)
 871     return (TCL_ERROR);
 872   xx = xx >= x ? xx - x : x - xx; xx >>= 2; xx *= xx;
 873   yy = yy >= y ? yy - y : y - yy; yy >>= 2; yy *= yy;
 874   d = sqrt(xx + yy); d <<= 2;
 875   Tcl_SetObjResult(ti, Tcl_NewLongObj(d));
 876   return (TCL_OK);
 877 }
 878
 879 /* --- @elite-adjacency ADJ LIST [DIST]@ --- *
 880  *
 881  * Construct an adjacency table from a world list.
 882  */
 883
 884 static int cmd_adjacency(ClientData cd, Tcl_Interp *ti,
 885                          int objc, Tcl_Obj *const *objv)
 886 {
 887   int oc;
 888   Tcl_Obj **ov;
 889   size_t i, j;
 890   long x, y, xx, yy, d;
 891   Tcl_Obj *a;
 892   char *s, *ss;
 893   Tcl_HashTable done;
 894   long dd = 70;
 895   int rc = TCL_ERROR;
 896   int dummy;
 897   Tcl_Obj *o;
 898
 899   if (objc < 3 || objc > 4)
 900     return (err(ti, "usage: elite-adjacency ADJ LIST [DIST]"));
 901   a = objv[1];
 902   if (Tcl_ListObjGetElements(ti, objv[2], &oc, &ov) != TCL_OK)
 903     return (TCL_ERROR);
 904   if (oc % 3 != 0)
 905     return (err(ti, "world array not a multiple of three in size"));
 906   if (objc >= 4 && Tcl_GetLongFromObj(ti, objv[3], &dd) != TCL_OK)
 907     return (TCL_ERROR);
 908
 909   Tcl_InitHashTable(&done, TCL_ONE_WORD_KEYS);
 910   Tcl_UnsetVar(ti, Tcl_GetString(a), 0);
 911   o = Tcl_NewObj();
 912   Tcl_IncrRefCount(o);
 913   for (i = 0; i < oc; i += 3) {
 914     s = Tcl_GetString(ov[i]);
 915     if (Tcl_ObjSetVar2(ti, a, ov[i], o, TCL_LEAVE_ERR_MSG) == 0)
 916       goto done;
 917   }
 918   for (i = 0; i < oc; i += 3) {
 919     s = Tcl_GetString(ov[i]);
 920     Tcl_CreateHashEntry(&done, s, &dummy);
 921     if (Tcl_GetLongFromObj(ti, ov[i + 1], &x) != TCL_OK ||
 922         Tcl_GetLongFromObj(ti, ov[i + 2], &y) != TCL_OK)
 923       goto done;
 924     for (j = 0; j < oc; j += 3) {
 925       ss = Tcl_GetString(ov[j]);
 926       if (Tcl_FindHashEntry(&done, ss))
 927         continue;
 928       if (Tcl_GetLongFromObj(ti, ov[j + 1], &xx) != TCL_OK ||
 929           Tcl_GetLongFromObj(ti, ov[j + 2], &yy) != TCL_OK)
 930         goto done;
 931       xx = xx >= x ? xx - x : x - xx; xx >>= 2; xx *= xx;
 932       yy = yy >= y ? yy - y : y - yy; yy >>= 2; yy *= yy;
 933       d = sqrt(xx + yy); d <<= 2;
 934       if (d <= dd) {
 935         if (Tcl_ObjSetVar2(ti, a, ov[i], ov[j],
 936                            (TCL_APPEND_VALUE |
 937                             TCL_LIST_ELEMENT |
 938                             TCL_LEAVE_ERR_MSG)) == 0 ||
 939             Tcl_ObjSetVar2(ti, a, ov[i], ov[j + 1],
 940                            (TCL_APPEND_VALUE |
 941                             TCL_LIST_ELEMENT |
 942                             TCL_LEAVE_ERR_MSG)) == 0 ||
 943             Tcl_ObjSetVar2(ti, a, ov[i], ov[j + 2],
 944                            (TCL_APPEND_VALUE |
 945                             TCL_LIST_ELEMENT |
 946                             TCL_LEAVE_ERR_MSG)) == 0 ||
 947             Tcl_ObjSetVar2(ti, a, ov[j], ov[i],
 948                            (TCL_APPEND_VALUE |
 949                             TCL_LIST_ELEMENT |
 950                             TCL_LEAVE_ERR_MSG)) == 0 ||
 951             Tcl_ObjSetVar2(ti, a, ov[j], ov[i + 1],
 952                            (TCL_APPEND_VALUE |
 953                             TCL_LIST_ELEMENT |
 954                             TCL_LEAVE_ERR_MSG)) == 0 ||
 955             Tcl_ObjSetVar2(ti, a, ov[j], ov[i + 2],
 956                            (TCL_APPEND_VALUE |
 957                             TCL_LIST_ELEMENT |
 958                             TCL_LEAVE_ERR_MSG)) == 0)
 959           goto done;
 960       }
 961     }
 962   }
 963   rc = TCL_OK;
 964
 965 done:
 966   Tcl_DeleteHashTable(&done);
 967   return (rc);
 968 }
 969
 970 /*----- Initialization ----------------------------------------------------*/
 971
 972 int Elite_SafeInit(Tcl_Interp *ti)
 973 {
 974   static const struct cmd {
 975     /*const*/ char *name;
 976     Tcl_ObjCmdProc *proc;
 977   } cmds[] = {
 978     { "elite-nextworld",        cmd_nextworld },
 979     { "elite-nextgalaxy",       cmd_nextgalaxy },
 980     { "elite-worldinfo",        cmd_worldinfo },
 981     { "elite-market",           cmd_market },
 982     { "elite-unpackcmdr",       cmd_unpackcmdr },
 983     { "elite-packcmdr",         cmd_packcmdr },
 984     { "elite-distance",         cmd_distance },
 985     { "elite-galaxylist",       cmd_galaxylist },
 986     { "elite-adjacency",        cmd_adjacency },
 987     { 0,                        0 }
 988   };
 989
 990   const struct cmd *c;
 991   for (c = cmds; c->name; c++)
 992     Tcl_CreateObjCommand(ti, c->name, c->proc, 0, 0);
 993   Tcl_RegisterObjType(&world_type);
 994   if (Tcl_PkgProvide(ti, "elite-bits", "1.0.1"))
 995     return (TCL_ERROR);
 996   return (TCL_OK);
 997 }
 998
 999 int Elite_Init(Tcl_Interp *ti)
1000 {
1001   return (Elite_SafeInit(ti));
1002 }
1003
1004 /*----- That's all, folks -------------------------------------------------*/