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

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