summaryrefslogtreecommitdiff
path: root/appl/spree/lib
diff options
context:
space:
mode:
Diffstat (limited to 'appl/spree/lib')
-rw-r--r--appl/spree/lib/allow.b194
-rw-r--r--appl/spree/lib/allow.m9
-rw-r--r--appl/spree/lib/base64.b72
-rw-r--r--appl/spree/lib/base64.m5
-rw-r--r--appl/spree/lib/cardlib.b917
-rw-r--r--appl/spree/lib/cardlib.m114
-rw-r--r--appl/spree/lib/commandline.b191
-rw-r--r--appl/spree/lib/commandline.m16
-rw-r--r--appl/spree/lib/objstore.b65
-rw-r--r--appl/spree/lib/objstore.m8
-rw-r--r--appl/spree/lib/testsets.b152
-rw-r--r--appl/spree/lib/tricks.b140
-rw-r--r--appl/spree/lib/tricks.m21
13 files changed, 1904 insertions, 0 deletions
diff --git a/appl/spree/lib/allow.b b/appl/spree/lib/allow.b
new file mode 100644
index 00000000..ef088b08
--- /dev/null
+++ b/appl/spree/lib/allow.b
@@ -0,0 +1,194 @@
+implement Allow;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "sets.m";
+ sets: Sets;
+ Set, set, None: import sets;
+include "../spree.m";
+ spree: Spree;
+ Attributes, Range, Object, Clique, Member, rand: import spree;
+include "allow.m";
+
+Action: adt {
+ tag: int;
+ member: ref Member;
+ action: string;
+};
+
+actions: list of Action;
+clique: ref Clique;
+
+init(srvmod: Spree, g: ref Clique)
+{
+ sys = load Sys Sys->PATH;
+ sets = load Sets Sets->PATH;
+ (clique, spree) = (g, srvmod);
+}
+
+ILLEGALNAME: con "/"; # illegal char in member names, ahem.
+archive(archiveobj: ref Object)
+{
+ i := 0;
+ for (al := actions; al != nil; al = tl al) {
+ a := hd al;
+ pname: string;
+ if (a.member != nil)
+ pname = a.member.name;
+ else
+ pname = ILLEGALNAME;
+ archiveobj.setattr(
+ "allow" + string i++,
+ sys->sprint("%d %s %s", a.tag, pname, a.action),
+ None
+ );
+ }
+}
+
+unarchive(archiveobj: ref Object)
+{
+ for (i := 0; (s := archiveobj.getattr("allow" + string i)) != nil; i++) {
+ (n, toks) := sys->tokenize(s, " ");
+ p: ref Member = nil;
+ if (hd tl toks != ILLEGALNAME) {
+ # if the member is no longer around, ignore the action. XXX do we still need to do this?
+ if ((p = clique.membernamed(hd tl toks)) == nil)
+ continue;
+ }
+ sys->print("allow: adding action %d, %ux, %s\n", int hd toks, p, concat(tl tl toks));
+ actions = Action(int hd toks, p, concat(tl tl toks)) :: actions;
+ }
+}
+
+add(tag: int, member: ref Member, action: string)
+{
+# sys->print("allow: add %d, member %ux, action: %s\n", tag, member, action);
+ actions = (tag, member, action) :: actions;
+}
+
+del(tag: int, member: ref Member)
+{
+# sys->print("allow: del %d\n", tag);
+ na: list of Action;
+ for (a := actions; a != nil; a = tl a) {
+ action := hd a;
+ if (action.tag == tag && (member == nil || action.member == member))
+ continue;
+ na = action :: na;
+ }
+ actions = na;
+}
+
+action(member: ref Member, cmd: string): (string, int, list of string)
+{
+ for (al := actions; al != nil; al = tl al) {
+ a := hd al;
+ if (a.member == nil || a.member == member) {
+ (e, v) := match(member, a.action, cmd);
+ if (e != nil || v != nil)
+ return (e, a.tag, v);
+ }
+ }
+ return ("you can't do that", -1, nil);
+}
+
+match(member: ref Member, pat, action: string): (string, list of string)
+{
+# sys->print("allow: matching pat: '%s' against action '%s'\n", pat, action);
+ toks: list of string;
+ na := len action;
+ if (na > 0 && action[na - 1] == '\n')
+ na--;
+
+ (i, j) := (0, 0);
+ for (;;) {
+ for (; i < len pat; i++)
+ if (pat[i] != ' ')
+ break;
+ for (; j < na; j++)
+ if (action[j] != ' ')
+ break;
+ for (i1 := i; i1 < len pat; i1++)
+ if (pat[i1] == ' ')
+ break;
+ for (j1 := j; j1 < na; j1++)
+ if (action[j1] == ' ')
+ break;
+ if (i == i1) {
+ if (j == j1)
+ break;
+ return (nil, nil);
+ }
+ if (j == j1) {
+ if (pat == "&")
+ break;
+ return (nil, nil);
+ }
+ pw := pat[i : i1];
+ w := action[j : j1];
+ case pw[0] {
+ '*' =>
+ toks = w :: toks;
+ '&' =>
+ toks = w :: toks;
+ pat = "&";
+ i1 = 0;
+ '%' =>
+ (ok, nw) := checkformat(member, pw[1], w);
+ if (!ok)
+ return ("invalid field value", nil);
+ toks = nw :: toks;
+ * =>
+ if (w != pw)
+ return (nil, nil);
+ toks = w :: toks;
+ }
+ (i, j) = (i1, j1);
+ }
+ return (nil, revs(toks));
+}
+
+revs(l: list of string): list of string
+{
+ m: list of string;
+ for (; l != nil; l = tl l)
+ m = hd l :: m;
+ return m;
+}
+
+checkformat(p: ref Member, fmt: int, w: string): (int, string)
+{
+ case fmt {
+ 'o' =>
+ # object id
+ if (isnum(w) && (o := p.obj(int w)) != nil)
+ return (1, string o.id);
+ 'd' =>
+ # integer
+ if (isnum(w))
+ return (1, w);
+ 'p' =>
+ # member id
+ if (isnum(w) && (member := clique.member(int w)) != nil)
+ return (1, w);
+ }
+ return (0, nil);
+}
+
+isnum(w: string): int
+{
+ # XXX lazy for the time being...
+ if (w != nil && ((w[0] >= '0' && w[0] <= '9') || w[0] == '-'))
+ return 1;
+ return 0;
+}
+
+concat(v: list of string): string
+{
+ if (v == nil)
+ return nil;
+ s := hd v;
+ for (v = tl v; v != nil; v = tl v)
+ s += " " + hd v;
+ return s;
+}
diff --git a/appl/spree/lib/allow.m b/appl/spree/lib/allow.m
new file mode 100644
index 00000000..98882091
--- /dev/null
+++ b/appl/spree/lib/allow.m
@@ -0,0 +1,9 @@
+Allow: module {
+ PATH: con "/dis/spree/lib/allow.dis";
+ init: fn(srvmod: Spree, g: ref Spree->Clique);
+ add: fn(tag: int, member: ref Spree->Member, action: string);
+ del: fn(tag: int, member: ref Spree->Member);
+ action: fn(member: ref Spree->Member, cmd: string): (string, int, list of string);
+ archive: fn(archiveobj: ref Object);
+ unarchive: fn(archiveobj: ref Object);
+};
diff --git a/appl/spree/lib/base64.b b/appl/spree/lib/base64.b
new file mode 100644
index 00000000..c8381467
--- /dev/null
+++ b/appl/spree/lib/base64.b
@@ -0,0 +1,72 @@
+implement Base64;
+include "base64.m";
+
+PADCH: con '=';
+encode(b: array of byte): string
+{
+ chmap := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" +
+ "abcdefghijklmnopqrstuvwxyz0123456789+/";
+ r := "";
+ blen := len b;
+ full := (blen + 2)/ 3;
+ rplen := (4*blen + 2) / 3;
+ ip := 0;
+ rp := 0;
+ for (i:=0; i<full; i++) {
+ word := 0;
+ for (j:=2; j>=0; j--)
+ if (ip < blen)
+ word = word | int b[ip++] << 8*j;
+ for (l:=3; l>=0; l--)
+ if (rp < rplen)
+ r[rp++] = chmap[(word >> (6*l)) & 16r3f];
+ else
+ r[rp++] = PADCH;
+ }
+ return r;
+}
+
+# Decode a base 64 string to a byte stream
+# Must be a multiple of 4 characters in length
+decode(s: string): array of byte
+{
+
+ tch: int;
+ slen := len s;
+ rlen := (3*slen+3)/4;
+ if (slen >= 4 && s[slen-1] == PADCH)
+ rlen--;
+ if (slen >= 4 && s[slen-2] == PADCH)
+ rlen--;
+ r := array[rlen] of byte;
+ full := slen / 4;
+ sp := 0;
+ rp := 0;
+ for (i:=0; i<full; i++) {
+ word := 0;
+ for (j:=0; j<4; j++) {
+ ch := s[sp++];
+ case ch {
+ 'A' to 'Z' =>
+ tch = ch - 'A';
+ 'a' to 'z' =>
+ tch = ch - 'a' + 26;
+ '0' to '9' =>
+ tch = ch - '0' + 52;
+ '+' =>
+ tch = 62;
+ '/' =>
+ tch = 63;
+ * =>
+ tch = 0;
+ }
+ word = (word << 6) | tch;
+ }
+ for (l:=2; l>=0; l--)
+ if (rp < rlen)
+ r[rp++] = byte( (word >> 8*l) & 16rff);
+
+ }
+ return r;
+}
+
diff --git a/appl/spree/lib/base64.m b/appl/spree/lib/base64.m
new file mode 100644
index 00000000..1325cae2
--- /dev/null
+++ b/appl/spree/lib/base64.m
@@ -0,0 +1,5 @@
+Base64: module {
+ PATH : con "/dis/spree/lib/base64.dis";
+ encode : fn(b : array of byte) : string;
+ decode : fn(s : string) : array of byte;
+};
diff --git a/appl/spree/lib/cardlib.b b/appl/spree/lib/cardlib.b
new file mode 100644
index 00000000..67c4918b
--- /dev/null
+++ b/appl/spree/lib/cardlib.b
@@ -0,0 +1,917 @@
+implement Cardlib;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "sets.m";
+ sets: Sets;
+ Set, set, A, B, All, None: import sets;
+include "../spree.m";
+ spree: Spree;
+ Attributes, Range, Object, Clique, Member, rand: import spree;
+include "objstore.m";
+ objstore: Objstore;
+include "cardlib.m";
+
+MAXPLAYERS: con 4;
+
+Layobject: adt {
+ lay: ref Object;
+ name: string;
+ packopts: int;
+ pick {
+ Obj =>
+ obj: ref Object; # nil if it's a frame
+ Frame =>
+ facing: int; # only valid if for frames
+ }
+};
+
+clique: ref Clique;
+cmembers: array of ref Cmember;
+cpids := array[8] of list of ref Cmember;
+
+# XXX first string is unnecessary as it's held in the Layobject anyway?
+layouts := array[17] of list of (string, ref Layout, ref Layobject);
+maxlayid := 1;
+cmemberid := 1;
+
+archiveobjs: array of list of (string, ref Object);
+
+defaultrank := array[13] of {12, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11};
+defaultsuitrank := array[] of {CLUBS => 0, DIAMONDS => 1, HEARTS => 2, SPADES => 3};
+
+table := array[] of {
+ 0 => array[] of {
+ (-1, dTOP|EXPAND, dBOTTOM, dTOP),
+ },
+ 1 => array [] of {
+ (0, dBOTTOM|FILLX, dBOTTOM, dTOP),
+ (-1, dTOP|EXPAND, dBOTTOM, dTOP),
+ },
+ 2 => array[] of {
+ (0, dBOTTOM|FILLX, dBOTTOM, dTOP),
+ (1, dTOP|FILLX, dTOP, dBOTTOM),
+ (-1, dTOP|EXPAND, dBOTTOM, dTOP)
+ },
+ 3 => array[] of {
+ (2, dRIGHT|FILLY, dRIGHT, dLEFT),
+ (0, dBOTTOM|FILLX, dBOTTOM, dTOP),
+ (1, dTOP|FILLX, dTOP, dBOTTOM),
+ (-1, dRIGHT|EXPAND, dBOTTOM, dTOP)
+ },
+ 4 => array[] of {
+ (1, dLEFT|FILLY, dLEFT, dRIGHT),
+ (3, dRIGHT|FILLY, dRIGHT, dLEFT),
+ (0, dBOTTOM|FILLX, dBOTTOM, dTOP),
+ (2, dTOP|FILLX, dTOP, dBOTTOM),
+ (-1, dRIGHT|EXPAND, dBOTTOM, dTOP)
+ },
+};
+
+
+init(mod: Spree, g: ref Clique)
+{
+ sys = load Sys Sys->PATH;
+ sets = load Sets Sets->PATH;
+ if (sets == nil)
+ panic(sys->sprint("cannot load %s: %r", Sets->PATH));
+ objstore = load Objstore Objstore->PATH;
+ if (objstore == nil)
+ panic(sys->sprint("cannot load %s: %r", Objstore->PATH));
+ objstore->init(mod, g);
+ clique = g;
+ spree = mod;
+}
+
+archive(): ref Object
+{
+ for (i := 0; i < len cmembers; i++) {
+ cp := cmembers[i];
+ setarchivename(cp.obj, "member" + string i);
+ setarchivename(cp.layout.lay, "layout" + string i);
+ sel := cp.sel;
+ if (sel.stack != nil)
+ setarchivename(sel.stack, "sel" + string i);
+ }
+ for (i = 0; i < len layouts; i++) {
+ for (ll := layouts[i]; ll != nil; ll = tl ll) {
+ (name, lay, layobj) := hd ll;
+ if (name != nil)
+ layobj.lay.setattr("layname", name, None);
+ pick l := layobj {
+ Frame =>
+ l.lay.setattr("facing", sides[l.facing], None);
+ Obj =>
+ setarchivename(l.obj, "layid" + l.obj.getattr("layid"));
+ }
+ }
+ }
+ # XXX should archive layouts that aren't particular to a member.
+ archiveobj := clique.newobject(nil, None, "archive");
+ setarchivename(archiveobj, "archive");
+ archiveobj.setattr("maxlayid", string maxlayid, None);
+ archiveobj.setattr("cmemberid", string cmemberid, None);
+ return archiveobj;
+}
+
+setarchivename(o: ref Object, name: string)
+{
+ objstore->setname(o, name);
+}
+
+getarchiveobj(name: string): ref Object
+{
+ return objstore->get(name);
+}
+
+archivearray(a: array of ref Object, name: string)
+{
+ for (i := 0; i < len a; i++)
+ objstore->setname(a[i], name + string i);
+}
+
+getarchivearray(name: string): array of ref Object
+{
+ l: list of ref Object;
+ for (i := 0; ; i++) {
+ o := objstore->get(name + string i);
+ if (o == nil)
+ break;
+ l = o :: l;
+ }
+ a := array[i] of ref Object;
+ for (; l != nil; l = tl l)
+ a[--i] = hd l;
+ return a;
+}
+
+unarchive(): ref Object
+{
+ objstore->unarchive();
+ archiveobj := getarchiveobj("archive");
+ cpl: list of ref Cmember;
+ for (i := 0; (o := getarchiveobj("member" + string i)) != nil; i++) {
+ cp := ref Cmember(
+ i,
+ int o.getattr("id"),
+ clique.membernamed(o.getattr("name")),
+ o,
+ ref Layout(getarchiveobj("layout" + string i)),
+ ref Selection(getarchiveobj("sel" + string i), -1, 1, (0, 0), nil)
+ );
+ cp.sel.ownerid = cp.id;
+ sel := cp.sel;
+ if (sel.stack != nil && (selstr := sel.stack.getattr("sel")) != nil) {
+ (n, val) := sys->tokenize(selstr, " ");
+ if (tl val != nil && hd tl val == "-")
+ (sel.r.start, sel.r.end) = (int hd val, int hd tl tl val);
+ else {
+ idxl: list of int;
+ sel.isrange = 0;
+ for (; val != nil; val = tl val)
+ idxl = int hd val :: idxl;
+ sel.idxl = idxl;
+ }
+ }
+ lay := cp.layout.lay;
+ # there should be exactly one child, of type "layframe"
+ if (len lay.children != 1 || lay.children[0].objtype != "layframe")
+ panic("invalid layout");
+ x := strhash(nil, len layouts);
+ layouts[x] = (nil, cp.layout, obj2layobj(lay.children[0])) :: layouts[x];
+ unarchivelayoutobj(cp.layout, lay.children[0]);
+ cpl = cp :: cpl;
+ }
+ cmembers = array[len cpl] of ref Cmember;
+ for (; cpl != nil; cpl = tl cpl) {
+ cp := hd cpl;
+ cmembers[cp.ord] = cp;
+ idx := cp.id % len cpids;
+ cpids[idx] = cp :: cpids[idx];
+ }
+
+ maxlayid = int archiveobj.getattr("maxlayid");
+ cmemberid = int archiveobj.getattr("cmemberid");
+ return archiveobj;
+}
+
+unarchivelayoutobj(layout: ref Layout, o: ref Object)
+{
+ for (i := 0; i < len o.children; i++) {
+ child := o.children[i];
+ layobj := obj2layobj(child);
+ if (layobj.name != nil) {
+ x := strhash(layobj.name, len layouts);
+ layouts[x] = (layobj.name, layout, layobj) :: layouts[x];
+ }
+ if (tagof(layobj) == tagof(Layobject.Frame))
+ unarchivelayoutobj(layout, child);
+ }
+}
+
+obj2layobj(o: ref Object): ref Layobject
+{
+ case o.objtype {
+ "layframe" =>
+ return ref Layobject.Frame(
+ o,
+ o.getattr("layname"),
+ s2packopts(o.getattr("opts")),
+ searchopt(sides, o.getattr("facing"))
+ );
+ "layobj" =>
+ return ref Layobject.Obj(
+ o,
+ o.getattr("layname"),
+ s2packopts(o.getattr("opts")),
+ getarchiveobj("layid" + o.getattr("layid"))
+ );
+ * =>
+ panic("invalid layobject found, of type '" + o.objtype + "'");
+ return nil;
+ }
+}
+
+Cmember.join(member: ref Member, ord: int): ref Cmember
+{
+ cmembers = (array[len cmembers + 1] of ref Cmember)[0:] = cmembers;
+ if (ord == -1)
+ ord = len cmembers - 1;
+ else {
+ cmembers[ord + 1:] = cmembers[ord:len cmembers - 1];
+ for (i := ord + 1; i < len cmembers; i++)
+ cmembers[i].ord = i;
+ }
+ cp := cmembers[ord] = ref Cmember(ord, cmemberid++, member, nil, nil, nil);
+ cp.obj = clique.newobject(nil, All, "member");
+ cp.obj.setattr("id", string cp.id, All);
+ cp.obj.setattr("name", member.name, All);
+ cp.obj.setattr("you", string cp.id, None.add(member.id));
+ cp.obj.setattr("cliquetitle", clique.fname, All);
+ cp.layout = newlayout(cp.obj, None.add(member.id));
+ cp.sel = ref Selection(nil, cp.id, 1, (0, 0), nil);
+
+ idx := cp.id % len cpids;
+ cpids[idx] = cp :: cpids[idx];
+ return cp;
+}
+
+Cmember.find(p: ref Member): ref Cmember
+{
+ id := p.id;
+ for (i := 0; i < len cmembers; i++)
+ if (cmembers[i].p.id == id)
+ return cmembers[i];
+ return nil;
+}
+
+Cmember.index(ord: int): ref Cmember
+{
+ if (ord < 0 || ord >= len cmembers)
+ return nil;
+ return cmembers[ord];
+}
+
+Cmember.next(cp: self ref Cmember, fwd: int): ref Cmember
+{
+ if (!fwd)
+ return cp.prev(1);
+ x := cp.ord + 1;
+ if (x >= len cmembers)
+ x = 0;
+ return cmembers[x];
+}
+
+Cmember.prev(cp: self ref Cmember, fwd: int): ref Cmember
+{
+ if (!fwd)
+ return cp.next(1);
+ x := cp.ord - 1;
+ if (x < 0)
+ x = len cmembers - 1;
+ return cmembers[x];
+}
+
+Cmember.leave(cp: self ref Cmember)
+{
+ ord := cp.ord;
+ cmembers[ord] = nil;
+ cmembers[ord:] = cmembers[ord + 1:];
+ cmembers[len cmembers - 1] = nil;
+ cmembers = cmembers[0:len cmembers - 1];
+ for (i := ord; i < len cmembers; i++)
+ cmembers[i].ord = i;
+ cp.obj.delete();
+ dellayout(cp.layout);
+ cp.layout = nil;
+ idx := cp.id % len cpids;
+ l: list of ref Cmember;
+ ll := cpids[idx];
+ for (; ll != nil; ll = tl ll)
+ if (hd ll != cp)
+ l = hd ll :: l;
+ cpids[idx] = l;
+ cp.ord = -1;
+}
+
+Cmember.findid(id: int): ref Cmember
+{
+ for (l := cpids[id % len cpids]; l != nil; l = tl l)
+ if ((hd l).id == id)
+ return hd l;
+ return nil;
+}
+
+newstack(parent: ref Object, owner: ref Member, spec: Stackspec): ref Object
+{
+ vis := All;
+ if (spec.conceal) {
+ vis = None;
+ if (owner != nil)
+ vis = vis.add(owner.id);
+ }
+ o := clique.newobject(parent, vis, "stack");
+ o.setattr("maxcards", string spec.maxcards, All);
+ o.setattr("style", spec.style, All);
+
+ # XXX provide some means for this to contain the member's name?
+ o.setattr("title", spec.title, All);
+ return o;
+}
+
+makecard(deck: ref Object, c: Card, rear: string): ref Object
+{
+ card := clique.newobject(deck, None, "card");
+ card.setattr("face", string c.face, All);
+ vis := None;
+ if(c.face)
+ vis = All;
+ card.setattr("number", string (c.number * 4 + c.suit), vis);
+ if (rear != nil)
+ card.setattr("rear", rear, All);
+ return card;
+}
+
+makecards(deck: ref Object, r: Range, rear: string)
+{
+ for (i := r.start; i < r.end; i++)
+ for(suit := 0; suit < 4; suit++)
+ makecard(deck, (suit, i, 0), rear);
+}
+
+# deal n cards to each member, if possible.
+# deal in chunks for efficiency.
+# if accuracy is required (e.g. dealing from an unshuffled
+# deck containing known cards) then this'll have to change.
+deal(deck: ref Object, n: int, stacks: array of ref Object, first: int)
+{
+ ncards := len deck.children;
+ ord := 0;
+ permember := n;
+ leftover := 0;
+ if (n * len stacks > ncards) {
+ # if trying to deal more cards than we've got,
+ # deal all that we've got, distributing the remainder fairly.
+ permember = ncards / len stacks;
+ leftover = ncards % len stacks;
+ }
+ for (i := 0; i < len stacks; i++) {
+ n = permember;
+ if (leftover > 0) {
+ n++;
+ leftover--;
+ }
+ priv := stacks[(first + i) % len stacks];
+ deck.transfer((ncards - n, ncards), priv, len priv.children);
+ priv.setattr("n", string (int priv.getattr("n") + n), All);
+ # make cards visible to member
+ for (j := len priv.children - n; j < len priv.children; j++)
+ setface(priv.children[j], 1);
+
+ ncards -= n;
+ }
+}
+
+setface(card: ref Object, face: int)
+{
+ # XXX check parent stack style and if it's a pile,
+ # only expose a face up card at the top.
+
+ card.setattr("face", string face, All);
+ if (face)
+ card.setattrvisibility("number", All);
+ else
+ card.setattrvisibility("number", None);
+}
+
+nmembers(): int
+{
+ return len cmembers;
+}
+
+getcard(card: ref Object): Card
+{
+ n := int card.getattr("number");
+ (suit, num) := (n % 4, n / 4);
+ return Card(suit, num, int card.getattr("face"));
+}
+
+getcards(stack: ref Object): array of Card
+{
+ a := array[len stack.children] of Card;
+ for (i := 0; i < len a; i++)
+ a[i] = getcard(stack.children[i]);
+ return a;
+}
+
+discard(stk, pile: ref Object, facedown: int)
+{
+ n := len stk.children;
+ if (facedown)
+ for (i := 0; i < n; i++)
+ setface(stk.children[i], 0);
+ stk.transfer((0, n), pile, len pile.children);
+}
+
+# shuffle children into a random order. first we make all the children
+# invisible (which will cause them to be deleted in the clients) then
+# shuffle to our heart's content, and make visible again...
+shuffle(o: ref Object)
+{
+ ovis := o.visibility;
+ o.setvisibility(None);
+ a := o.children;
+ n := len a;
+ for (i := 0; i < n; i++) {
+ j := i + rand(n - i);
+ (a[i], a[j]) = (a[j], a[i]);
+ }
+ o.setvisibility(ovis);
+}
+
+sort(o: ref Object, rank, suitrank: array of int)
+{
+ if (rank == nil)
+ rank = defaultrank;
+ if (suitrank == nil)
+ suitrank = defaultsuitrank;
+ ovis := o.visibility;
+ o.setvisibility(None);
+ cardmergesort(o.children, array[len o.children] of ref Object, rank, suitrank);
+ o.setvisibility(ovis);
+}
+
+cardcmp(a, b: ref Object, rank, suitrank: array of int): int
+{
+ c1 := getcard(a);
+ c2 := getcard(b);
+ if (suitrank[c1.suit] != suitrank[c2.suit])
+ return suitrank[c1.suit] - suitrank[c2.suit];
+ return rank[c1.number] - rank[c2.number];
+}
+
+cardmergesort(a, b: array of ref Object, rank, suitrank: array of int)
+{
+ r := len a;
+ if (r > 1) {
+ m := (r-1)/2 + 1;
+ cardmergesort(a[0:m], b[0:m], rank, suitrank);
+ cardmergesort(a[m:], b[m:], rank, suitrank);
+ b[0:] = a;
+ for ((i, j, k) := (0, m, 0); i < m && j < r; k++) {
+ if (cardcmp(b[i], b[j], rank, suitrank) > 0)
+ a[k] = b[j++];
+ else
+ a[k] = b[i++];
+ }
+ if (i < m)
+ a[k:] = b[i:m];
+ else if (j < r)
+ a[k:] = b[j:r];
+ }
+}
+
+# reverse and flip all cards in stack.
+flip(stack: ref Object)
+{
+ ovis := stack.visibility;
+ stack.setvisibility(None);
+ a := stack.children;
+ (n, m) := (len a, len a / 2);
+ for (i := 0; i < m; i++) {
+ j := n - i - 1;
+ (a[i], a[j]) = (a[j], a[i]);
+ }
+ for (i = 0; i < n; i++)
+ setface(a[i], !int a[i].getattr("face"));
+ stack.setvisibility(ovis);
+}
+
+selection(stack: ref Object): ref Selection
+{
+ if ((owner := stack.getattr("owner")) != nil &&
+ (cp := Cmember.findid(int owner)) != nil)
+ return cp.sel;
+ return nil;
+}
+
+Selection.set(sel: self ref Selection, stack: ref Object)
+{
+ if (stack == sel.stack)
+ return;
+ if (stack != nil) {
+ oldowner := stack.getattr("owner");
+ if (oldowner != nil) {
+ oldcp := Cmember.findid(int oldowner);
+ if (oldcp != nil)
+ oldcp.sel.set(nil);
+ }
+ }
+ if (sel.stack != nil)
+ sel.stack.setattr("owner", nil, All);
+ sel.stack = stack;
+ sel.isrange = 1;
+ sel.r = (0, 0);
+ sel.idxl = nil;
+ setsel(sel);
+}
+
+Selection.setexcl(sel: self ref Selection, stack: ref Object): int
+{
+ if (stack != nil && (oldowner := stack.getattr("owner")) != nil)
+ if ((cp := Cmember.findid(int oldowner)) != nil && !cp.sel.isempty())
+ return 0;
+ sel.set(stack);
+ return 1;
+}
+
+Selection.owner(sel: self ref Selection): ref Cmember
+{
+ return Cmember.findid(sel.ownerid);
+}
+
+Selection.setrange(sel: self ref Selection, r: Range)
+{
+ if (!sel.isrange) {
+ sel.idxl = nil;
+ sel.isrange = 1;
+ }
+ sel.r = r;
+ setsel(sel);
+}
+
+Selection.addindex(sel: self ref Selection, i: int)
+{
+ if (sel.isrange) {
+ sel.r = (0, 0);
+ sel.isrange = 0;
+ }
+ ll: list of int;
+ for (l := sel.idxl; l != nil; l = tl l) {
+ if (hd l >= i)
+ break;
+ ll = hd l :: ll;
+ }
+ if (l != nil && hd l == i)
+ return;
+ l = i :: l;
+ for (; ll != nil; ll = tl ll)
+ l = hd ll :: l;
+ sel.idxl = l;
+ setsel(sel);
+}
+
+Selection.delindex(sel: self ref Selection, i: int)
+{
+ if (sel.isrange) {
+ sys->print("cardlib: delindex from range-type selection\n");
+ return;
+ }
+ ll: list of int;
+ for (l := sel.idxl; l != nil; l = tl l) {
+ if (hd l == i) {
+ l = tl l;
+ break;
+ }
+ ll = hd l :: ll;
+ }
+ for (; ll != nil; ll = tl ll)
+ l = hd ll :: l;
+ sel.idxl = l;
+ setsel(sel);
+}
+
+Selection.isempty(sel: self ref Selection): int
+{
+ if (sel.stack == nil)
+ return 1;
+ if (sel.isrange)
+ return sel.r.start == sel.r.end;
+ return sel.idxl == nil;
+}
+
+Selection.isset(sel: self ref Selection, index: int): int
+{
+ if (sel.isrange)
+ return index >= sel.r.start && index < sel.r.end;
+ for (l := sel.idxl; l != nil; l = tl l)
+ if (hd l == index)
+ return 1;
+ return 0;
+}
+
+Selection.transfer(sel: self ref Selection, dst: ref Object, index: int)
+{
+ if (sel.isempty())
+ return;
+ src := sel.stack;
+ if (sel.isrange) {
+ r := sel.r;
+ sel.set(nil);
+ src.transfer(r, dst, index);
+ } else {
+ if (sel.stack == dst) {
+ sys->print("cardlib: cannot move multisel to same stack\n");
+ return;
+ }
+ xl := l := sel.idxl;
+ sel.set(nil);
+ rl: list of Range;
+ for (; l != nil; l = tl l) {
+ r := Range(hd l, hd l);
+ last := l;
+ # concatenate adjacent items, for efficiency.
+ for (l = tl l; l != nil; (last, l) = (l, tl l)) {
+ if (hd l != r.end + 1)
+ break;
+ r.end = hd l;
+ }
+ rl = (r.start, r.end + 1) :: rl;
+ l = last;
+ }
+ # do ranges in reverse, so that later ranges
+ # aren't affected by earlier ones.
+ if (index == -1)
+ index = len dst.children;
+ for (; rl != nil; rl = tl rl)
+ src.transfer(hd rl, dst, index);
+ }
+}
+
+setsel(sel: ref Selection)
+{
+ if (sel.stack == nil)
+ return;
+ s := "";
+ if (sel.isrange) {
+ if (sel.r.end > sel.r.start)
+ s = string sel.r.start + " - " + string sel.r.end;
+ } else {
+ if (sel.idxl != nil) {
+ s = string hd sel.idxl;
+ for (l := tl sel.idxl; l != nil; l = tl l)
+ s += " " + string hd l;
+ }
+ }
+ if (s != nil)
+ sel.stack.setattr("owner", string sel.owner().id, All);
+ else
+ sel.stack.setattr("owner", nil, All);
+ vis := None.add(sel.owner().p.id);
+ sel.stack.setattr("sel", s, vis);
+ sel.stack.setattrvisibility("sel", vis);
+}
+
+newlayout(parent: ref Object, vis: Set): ref Layout
+{
+ l := ref Layout(clique.newobject(parent, vis, "layout"));
+ x := strhash(nil, len layouts);
+ layobj := ref Layobject.Frame(nil, "", dTOP|EXPAND|FILLX|FILLY, dTOP);
+ layobj.lay = clique.newobject(l.lay, All, "layframe");
+ layobj.lay.setattr("opts", packopts2s(layobj.packopts), All);
+ layouts[x] = (nil, l, layobj) :: layouts[x];
+# sys->print("[%d] => ('%s', %ux, %ux) (new layout)\n", x, "", l, layobj);
+ return l;
+}
+
+addlayframe(name, parent: string, layout: ref Layout, packopts: int, facing: int)
+{
+# sys->print("addlayframe('%s', %ux, name: %s\n", parent, layout, name);
+ addlay(parent, layout, ref Layobject.Frame(nil, name, packopts, facing));
+}
+
+addlayobj(name, parent: string, layout: ref Layout, packopts: int, obj: ref Object)
+{
+# sys->print("addlayobj('%s', %ux, name: %s, obj %d\n", parent, layout, name, obj.id);
+ addlay(parent, layout, ref Layobject.Obj(nil, name, packopts, obj));
+}
+
+addlay(parent: string, layout: ref Layout, layobj: ref Layobject)
+{
+ a := layouts;
+ name := layobj.name;
+ x := strhash(name, len a);
+ added := 0;
+ for (nl := a[strhash(parent, len a)]; nl != nil; nl = tl nl) {
+ (s, lay, parentlay) := hd nl;
+ if (s == parent && (layout == nil || layout == lay)) {
+ pick p := parentlay {
+ Obj =>
+ sys->fprint(sys->fildes(2),
+ "cardlib: cannot add layout to non-frame: %d\n", p.obj.id);
+ Frame =>
+ nlayobj := copylayobj(layobj);
+ nlayobj.packopts = packoptsfacing(nlayobj.packopts, p.facing);
+ o: ref Object;
+ pick lo := nlayobj {
+ Obj =>
+ o = clique.newobject(p.lay, All, "layobj");
+ id := lo.obj.getattr("layid");
+ if (id == nil) {
+ id = string maxlayid++;
+ lo.obj.setattr("layid", id, All);
+ }
+ o.setattr("layid", id, All);
+ Frame =>
+ o = clique.newobject(p.lay, All, "layframe");
+ lo.facing = (lo.facing + p.facing) % 4;
+ }
+ o.setattr("opts", packopts2s(nlayobj.packopts), All);
+ nlayobj.lay = o;
+ if (name != nil)
+ a[x] = (name, lay, nlayobj) :: a[x];
+ added++;
+ }
+ }
+ }
+ if (added == 0)
+ sys->print("no parent found, adding '%s', parent '%s', layout %ux\n",
+ layobj.name, parent, layout);
+# sys->print("%d new entries\n", added);
+}
+
+maketable(parent: string)
+{
+ # make a table for all current members.
+ plcount := len cmembers;
+ packopts := table[plcount];
+ for (i := 0; i < plcount; i++) {
+ layout := cmembers[i].layout;
+ for (j := 0; j < len packopts; j++) {
+ (ord, outer, inner, facing) := packopts[j];
+ name := "public";
+ if (ord != -1)
+ name = "p" + string ((ord + i) % plcount);
+ addlayframe("@" + name, parent, layout, outer, dTOP);
+ addlayframe(name, "@" + name, layout, inner, facing);
+ }
+ }
+}
+
+dellay(name: string, layout: ref Layout)
+{
+ a := layouts;
+ x := strhash(name, len a);
+ rl: list of (string, ref Layout, ref Layobject);
+ for (nl := a[x]; nl != nil; nl = tl nl) {
+ (s, lay, layobj) := hd nl;
+ if (s != name || (layout != nil && layout != lay))
+ rl = hd nl :: rl;
+ }
+ a[x] = rl;
+}
+
+dellayout(layout: ref Layout)
+{
+ for (i := 0; i < len layouts; i++) {
+ ll: list of (string, ref Layout, ref Layobject);
+ for (nl := layouts[i]; nl != nil; nl = tl nl) {
+ (s, lay, layobj) := hd nl;
+ if (lay != layout)
+ ll = hd nl :: ll;
+ }
+ layouts[i] = ll;
+ }
+}
+
+copylayobj(obj: ref Layobject): ref Layobject
+{
+ pick o := obj {
+ Frame =>
+ return ref *o;
+ Obj =>
+ return ref *o;
+ }
+ return nil;
+}
+
+packoptsfacing(opts, facing: int): int
+{
+ if (facing == dTOP)
+ return opts;
+ nopts := 0;
+
+ # 4 directions
+ nopts |= (facing + (opts & dMASK)) % 4;
+
+ # 2 orientations
+ nopts |= ((facing + ((opts & oMASK) >> oSHIFT)) % 4) << oSHIFT;
+
+ # 8 anchorpoints (+ centre)
+ a := (opts & aMASK);
+ if (a != aCENTRE)
+ a = ((((a >> aSHIFT) - 1 + facing * 2) % 8) + 1) << aSHIFT;
+ nopts |= a;
+
+ # two fill options
+ if (facing % 2) {
+ if (opts & FILLX)
+ nopts |= FILLY;
+ if (opts & FILLY)
+ nopts |= FILLX;
+ } else
+ nopts |= (opts & (FILLX | FILLY));
+
+ nopts |= (opts & EXPAND);
+ return nopts;
+}
+
+# these arrays are dependent on the ordering of
+# the relevant constants defined in cardlib.m
+
+sides := array[] of {"top", "left", "bottom", "right"};
+anchors := array[] of {"centre", "n", "nw", "w", "sw", "s", "se", "e", "ne"};
+orientations := array[] of {"right", "up", "left", "down"};
+fills := array[] of {"none", "x", "y", "both"};
+
+packopts2s(opts: int): string
+{
+ s := orientations[(opts & oMASK) >> oSHIFT] +
+ " -side " + sides[opts & dMASK];
+ if ((opts & aMASK) != aCENTRE)
+ s += " -anchor " + anchors[(opts & aMASK) >> aSHIFT];
+ if (opts & EXPAND)
+ s += " -expand 1";
+ if (opts & (FILLX | FILLY))
+ s += " -fill " + fills[(opts & FILLMASK) >> FILLSHIFT];
+ return s;
+}
+
+searchopt(a: array of string, s: string): int
+{
+ for (i := 0; i < len a; i++)
+ if (a[i] == s)
+ return i;
+ panic("unknown pack option '" + s + "'");
+ return 0;
+}
+
+s2packopts(s: string): int
+{
+ (nil, toks) := sys->tokenize(s, " ");
+ if (toks == nil)
+ panic("invalid packopts: " + s);
+ p := searchopt(orientations, hd toks) << oSHIFT;
+ for (toks = tl toks; toks != nil; toks = tl tl toks) {
+ if (tl toks == nil)
+ panic("invalid packopts: " + s);
+ arg := hd tl toks;
+ case hd toks {
+ "-anchor" =>
+ p |= searchopt(anchors, arg) << aSHIFT;
+ "-fill" =>
+ p |= searchopt(fills, arg) << FILLSHIFT;
+ "-side" =>
+ p |= searchopt(sides, arg) << dSHIFT;
+ "-expand" =>
+ if (int hd tl toks)
+ p |= EXPAND;
+ * =>
+ panic("unknown pack option: " + hd toks);
+ }
+ }
+ return p;
+}
+
+panic(e: string)
+{
+ sys->fprint(sys->fildes(2), "cardlib panic: %s\n", e);
+ raise "panic";
+}
+
+assert(b: int, err: string)
+{
+ if (b == 0)
+ raise "parse:" + err;
+}
+
+# from Aho Hopcroft Ullman
+strhash(s: string, n: int): int
+{
+ h := 0;
+ m := len s;
+ for(i := 0; i<m; i++){
+ h = 65599 * h + s[i];
+ }
+ return (h & 16r7fffffff) % n;
+}
diff --git a/appl/spree/lib/cardlib.m b/appl/spree/lib/cardlib.m
new file mode 100644
index 00000000..94c05002
--- /dev/null
+++ b/appl/spree/lib/cardlib.m
@@ -0,0 +1,114 @@
+Cardlib: module {
+ PATH: con "/dis/spree/lib/cardlib.dis";
+
+ Layout: adt {
+ lay: ref Spree->Object; # the actual layout object
+ };
+
+ Stackspec: adt {
+ style: string;
+ maxcards: int;
+ conceal: int;
+ title: string;
+ };
+
+ Card: adt {
+ suit: int;
+ number: int;
+ face: int;
+ };
+
+ # a member currently playing
+ Cmember: adt {
+ ord: int;
+ id: int;
+ p: ref Spree->Member;
+ obj: ref Spree->Object;
+ layout: ref Layout;
+ sel: ref Selection;
+
+ join: fn(p: ref Spree->Member, ord: int): ref Cmember;
+ index: fn(ord: int): ref Cmember;
+ find: fn(p: ref Spree->Member): ref Cmember;
+ findid: fn(id: int): ref Cmember;
+ leave: fn(cp: self ref Cmember);
+ next: fn(cp: self ref Cmember, fwd: int): ref Cmember;
+ prev: fn(cp: self ref Cmember, fwd: int): ref Cmember;
+ };
+
+ Selection: adt {
+ stack: ref Spree->Object;
+ ownerid: int;
+ isrange: int;
+ r: Range;
+ idxl: list of int;
+
+ set: fn(sel: self ref Selection, stack: ref Spree->Object);
+ setexcl: fn(sel: self ref Selection, stack: ref Spree->Object): int;
+ setrange: fn(sel: self ref Selection, r: Range);
+ addindex: fn(sel: self ref Selection, i: int);
+ delindex: fn(sel: self ref Selection, i: int);
+ isempty: fn(sel: self ref Selection): int;
+ isset: fn(sel: self ref Selection, index: int): int;
+ transfer: fn(sel: self ref Selection, dst: ref Spree->Object, index: int);
+ owner: fn(sel: self ref Selection): ref Cmember;
+ };
+
+ selection: fn(stack: ref Spree->Object): ref Selection;
+
+ # pack and facing directions (clockwise by face direction)
+ dTOP, dLEFT, dBOTTOM, dRIGHT: con iota;
+ dMASK: con 7;
+ dSHIFT: con 0;
+
+ # anchor positions
+ aSHIFT: con 4;
+ aMASK: con 16rf0;
+ aCENTRE, aUPPERCENTRE, aUPPERLEFT, aCENTRELEFT,
+ aLOWERLEFT, aLOWERCENTRE, aLOWERRIGHT,
+ aCENTRERIGHT, aUPPERRIGHT: con iota << aSHIFT;
+
+ # orientations
+ oMASK: con 16rf00;
+ oSHIFT: con 8;
+ oRIGHT, oUP, oLEFT, oDOWN: con iota << oSHIFT;
+
+ EXPAND: con 16r1000;
+
+ FILLSHIFT: con 13;
+ FILLX, FILLY: con 1 << (FILLSHIFT + iota);
+ FILLMASK: con FILLX|FILLY;
+
+ CLUBS, DIAMONDS, HEARTS, SPADES: con iota;
+
+ init: fn(spree: Spree, clique: ref Spree->Clique);
+
+ addlayframe: fn(name: string, parent: string, layout: ref Layout, packopts: int, facing: int);
+ addlayobj: fn(name: string, parent: string, layout: ref Layout, packopts: int, obj: ref Spree->Object);
+ dellay: fn(name: string, layout: ref Layout);
+
+ newstack: fn(parent: ref Spree->Object, p: ref Spree->Member, spec: Stackspec): ref Spree->Object;
+
+ archive: fn(): ref Spree->Object;
+ unarchive: fn(): ref Spree->Object;
+ setarchivename: fn(o: ref Spree->Object, name: string);
+ getarchiveobj: fn(name: string): ref Spree->Object;
+ archivearray: fn(a: array of ref Spree->Object, name: string);
+ getarchivearray: fn(name: string): array of ref Spree->Object;
+
+ newlayout: fn(parent: ref Spree->Object, vis: Sets->Set): ref Layout;
+ makecards: fn(stack: ref Spree->Object, r: Range, rear: string);
+ maketable: fn(parent: string);
+ deal: fn(stack: ref Spree->Object, n: int, stacks: array of ref Spree->Object, first: int);
+ shuffle: fn(stack: ref Spree->Object);
+ sort: fn(stack: ref Spree->Object, rank, suitrank: array of int);
+
+ getcard: fn(card: ref Spree->Object): Card;
+ getcards: fn(stack: ref Spree->Object): array of Card;
+ discard: fn(stk, pile: ref Spree->Object, facedown: int);
+ setface: fn(card: ref Spree->Object, face: int);
+
+ flip: fn(stack: ref Spree->Object);
+
+ nmembers: fn(): int;
+};
diff --git a/appl/spree/lib/commandline.b b/appl/spree/lib/commandline.b
new file mode 100644
index 00000000..8b60ab01
--- /dev/null
+++ b/appl/spree/lib/commandline.b
@@ -0,0 +1,191 @@
+implement Commandline;
+
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "tk.m";
+ tk: Tk;
+include "tkclient.m";
+ tkclient: Tkclient;
+include "commandline.m";
+
+Debug: con 0;
+
+nomodule(modpath: string)
+{
+ sys->fprint(stderr(), "fibs: couldn't load %s: %r\n", modpath);
+ raise "fail:bad module";
+}
+
+init()
+{ sys = load Sys Sys->PATH;
+
+ tk = load Tk Tk->PATH;
+ if (tk == nil) nomodule(Tk->PATH);
+
+ tkclient = load Tkclient Tkclient->PATH;
+ if (tkclient == nil) nomodule(Tkclient->PATH);
+ tkclient->init();
+}
+
+Cmdline.new(top: ref Tk->Toplevel, w, textopts: string): (ref Cmdline, chan of string)
+{
+ window_cfg := array[] of {
+ "frame " + w,
+ "scrollbar " + w + ".scroll -command {" + w + ".t yview}",
+ "text " + w + ".t -yscrollcommand {" + w + ".scroll set} " + textopts,
+ "pack " + w + ".scroll -side left -fill y",
+ "pack " + w + ".t -fill both -expand 1",
+
+ "bind " + w + ".t <Key> {send evch k {%A}}",
+ "bind " + w + ".t <Control-d> {send evch k {%A}}",
+ "bind " + w + ".t <Control-u> {send evch k {%A}}",
+ "bind " + w + ".t <Control-w> {send evch k {%A}}",
+ "bind " + w + ".t <Control-h> {send evch k {%A}}",
+ # treat button 2 and button 3 the same so we're alright with a 2-button mouse
+ "bind " + w + ".t <ButtonPress-2> {send evch b %x %y}",
+ "bind " + w + ".t <ButtonPress-3> {send evch b %x %y}",
+ w + ".t mark set outpoint end",
+ w + ".t mark gravity outpoint left",
+ w + ".t mark set inpoint end",
+ w + ".t mark gravity inpoint left",
+ };
+ evch := chan of string;
+ tk->namechan(top, evch, "evch");
+
+ for (i := 0; i < len window_cfg; i++) {
+ e := cmd(top, window_cfg[i]);
+ if (e != nil && e[0] == '!')
+ break;
+ }
+
+ err := tk->cmd(top, "variable lasterror");
+ if (err != nil) {
+ sys->fprint(stderr(), "error in commandline config: %s\n", err);
+ raise "fail:commandline config error";
+ }
+ cmd(top, w + ".t mark set insert end;" + w + ".t see insert");
+ return (ref Cmdline(w, top), evch);
+}
+
+Cmdline.focus(cmdl: self ref Cmdline)
+{
+ cmd(cmdl.top, "focus " + cmdl.w + ".t");
+}
+
+Cmdline.event(cmdl: self ref Cmdline, e: string): list of string
+{
+ case e[0] {
+ 'k' =>
+ return handle_key(cmdl, e[2:]);
+ 'b' =>
+ ;
+ }
+ return nil;
+}
+
+BS: con 8; # ^h backspace character
+BSW: con 23; # ^w bacspace word
+BSL: con 21; # ^u backspace line
+
+handle_key(cmdl: ref Cmdline, c: string): list of string
+{
+ (w, top) := (cmdl.w, cmdl.top);
+ # don't allow editing of the text before the inpoint.
+ if (int cmd(top, w + ".t compare insert < inpoint"))
+ return nil;
+ lines: list of string;
+ char := c[1];
+ if (char == '\\')
+ char = c[2];
+ case char {
+ * =>
+ cmd(top, w + ".t insert insert "+c+" {}");
+ '\n' =>
+ cmd(top, w + ".t insert insert "+c+" {}");
+ lines = sendinput(cmdl);
+ BSL or BSW or BS =>
+ delpoint: string;
+ case char {
+ BSL => delpoint = "{insert linestart}";
+ BSW => delpoint = "{insert -1char wordstart}"; # wordstart isn't ideal
+ BS => delpoint = "{insert-1char}";
+ }
+ if (int cmd(top, w + ".t compare inpoint < " + delpoint))
+ cmd(top, w + ".t delete "+delpoint+" insert");
+ else
+ cmd(top, w + ".t delete inpoint insert");
+ }
+ cmd(top, w + ".t see insert;update");
+ return lines;
+}
+
+sendinput(cmdl: ref Cmdline): list of string
+{
+ (w, top) := (cmdl.w, cmdl.top);
+ # loop through all the lines that have been entered,
+ # processing each one in turn.
+ nl, lines: list of string;
+ for (;;) {
+ input: string;
+ input = cmd(top, w + ".t get inpoint end");
+ if (len input == 0)
+ break;
+ for (i := 0; i < len input; i++)
+ if (input[i] == '\n')
+ break;
+ if (i >= len input)
+ break;
+ cmd(top, w + ".t mark set outpoint inpoint+"+string (i+1)+"chars");
+ cmd(top, w + ".t mark set inpoint outpoint");
+ lines = input[0:i+1] :: lines;
+ }
+ for (; lines != nil; lines = tl lines)
+ nl = hd lines :: nl;
+ return nl;
+}
+
+add(cmdl: ref Cmdline, t: string, n: int)
+{
+ (w, top) := (cmdl.w, cmdl.top);
+ cmd(top, w + ".t insert outpoint " + t);
+ cmd(top, w + ".t mark set outpoint outpoint+"+string n+"chars");
+ cmd(top, w + ".t mark set inpoint outpoint");
+ cmd(top, w + ".t see insert");
+}
+
+Cmdline.tagaddtext(cmdl: self ref Cmdline, t: list of (string, string))
+{
+ txt := "";
+ n := 0;
+ for (; t != nil; t = tl t) {
+ (tags, s) := hd t;
+ txt += " " + tk->quote(s) + " {" + tags + "}";
+ n += len s;
+ }
+ add(cmdl, txt, n);
+}
+
+Cmdline.addtext(cmdl: self ref Cmdline, txt: string)
+{
+ if (Debug) sys->print("%s", txt);
+ add(cmdl, tk->quote(txt) + " {}" , len txt);
+}
+
+Cmdline.maketag(cmdl: self ref Cmdline, name, options: string)
+{
+ cmd(cmdl.top, cmdl.w + ".t tag configure " + name + " " + options);
+}
+
+stderr(): ref Sys->FD
+{
+ return sys->fildes(2);
+}
+
+cmd(top: ref Tk->Toplevel, s: string): string
+{
+ e := tk->cmd(top, s);
+ if (e != nil && e[0] == '!')
+ sys->fprint(stderr(), "cmd error on '%s': %s\n", s, e);
+ return e;
+}
diff --git a/appl/spree/lib/commandline.m b/appl/spree/lib/commandline.m
new file mode 100644
index 00000000..7fcfa965
--- /dev/null
+++ b/appl/spree/lib/commandline.m
@@ -0,0 +1,16 @@
+Commandline: module {
+ init: fn();
+
+ PATH: con "/dis/spree/lib/commandline.dis";
+ Cmdline: adt {
+ new: fn(win: ref Tk->Toplevel, w, textopts: string): (ref Cmdline, chan of string);
+ event: fn(cmdl: self ref Cmdline, e: string): list of string;
+ tagaddtext: fn(cmdl: self ref Cmdline, t: list of (string, string));
+ addtext: fn(cmdl: self ref Cmdline, txt: string);
+ focus: fn(cmdl: self ref Cmdline);
+ maketag: fn(cmdl: self ref Cmdline, name, options: string);
+
+ w: string;
+ top: ref Tk->Toplevel;
+ };
+};
diff --git a/appl/spree/lib/objstore.b b/appl/spree/lib/objstore.b
new file mode 100644
index 00000000..47d0b13d
--- /dev/null
+++ b/appl/spree/lib/objstore.b
@@ -0,0 +1,65 @@
+implement Objstore;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "sets.m";
+ None: import Sets;
+include "../spree.m";
+ spree: Spree;
+ Object, Clique: import spree;
+include "objstore.m";
+
+clique: ref Clique;
+archiveobjs: array of list of (string, ref Object);
+
+init(mod: Spree, g: ref Clique)
+{
+ sys = load Sys Sys->PATH;
+ spree = mod;
+ clique = g;
+}
+
+unarchive()
+{
+ archiveobjs = array[27] of list of (string, ref Object);
+ for (i := 0; i < len clique.objects; i++) {
+ obj := clique.objects[i];
+ if (obj != nil && (nm := obj.getattr("§")) != nil) {
+ (n, toks) := sys->tokenize(nm, " ");
+ for (; toks != nil; toks = tl toks) {
+ x := strhash(hd toks, len archiveobjs);
+ archiveobjs[x] = (hd toks, obj) :: archiveobjs[x];
+ }
+ obj.setattr("§", nil, None);
+ }
+ }
+}
+
+setname(obj: ref Object, name: string)
+{
+ nm := obj.getattr("§");
+ if (nm != nil)
+ nm += " " + name;
+ else
+ nm = name;
+ obj.setattr("§", nm, None);
+}
+
+get(name: string): ref Object
+{
+ for (al := archiveobjs[strhash(name, len archiveobjs)]; al != nil; al = tl al)
+ if ((hd al).t0 == name)
+ return (hd al).t1;
+ return nil;
+}
+
+# from Aho Hopcroft Ullman
+strhash(s: string, n: int): int
+{
+ h := 0;
+ m := len s;
+ for(i := 0; i<m; i++){
+ h = 65599 * h + s[i];
+ }
+ return (h & 16r7fffffff) % n;
+}
diff --git a/appl/spree/lib/objstore.m b/appl/spree/lib/objstore.m
new file mode 100644
index 00000000..86aa33b5
--- /dev/null
+++ b/appl/spree/lib/objstore.m
@@ -0,0 +1,8 @@
+Objstore: module {
+ PATH: con "/dis/spree/lib/objstore.dis";
+
+ init: fn(mod: Spree, g: ref Clique);
+ unarchive: fn();
+ setname: fn(o: ref Object, name: string);
+ get: fn(name: string): ref Object;
+};
diff --git a/appl/spree/lib/testsets.b b/appl/spree/lib/testsets.b
new file mode 100644
index 00000000..2556838f
--- /dev/null
+++ b/appl/spree/lib/testsets.b
@@ -0,0 +1,152 @@
+implement Testsets;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "rand.m";
+include "sets.m"; # "sets.m" or "sets32.m"
+ sets: Sets;
+ Set, set, A, B: import sets;
+
+BPW: con 32;
+SHIFT: con 5;
+MASK: con 31;
+
+Testsets: module {
+ init: fn(nil: ref Draw->Context, nil: list of string);
+};
+
+∅: Set;
+
+Testbig: con 1;
+
+init(ctxt: ref Draw->Context, argv: list of string)
+{
+ sys = load Sys Sys->PATH;
+ sets = load Sets Sets->PATH;
+ if (sets == nil) {
+ sys->print("cannot load %s: %r\n", Sets->PATH);
+ exit;
+ }
+ rand := load Rand Rand->PATH;
+ sets->init();
+
+ ∅ = set();
+ s := set().addlist(1::2::3::4::nil);
+ addit(s);
+ sys->print("s %s\n", s.str());
+ r := s.invert();
+ sys->print("r %s\n", r.str());
+ r = r.del(20);
+ addit(r);
+ sys->print("r del20: %s\n", r.str());
+ z := r.X(~A&~B, s);
+ addit(z);
+ sys->print("z: %s\n", z.str());
+
+ x := set();
+ for (i := 0; i < 31; i++)
+ if (rand->rand(2))
+ x = x.add(i);
+ addit(x);
+ for(i = 0; i < 31; i++)
+ addit(set().add(i));
+ if (Testbig) {
+ r = r.del(100);
+ addit(r);
+ sys->print("rz: %s\n", r.str());
+ r = r.add(100);
+ addit(r);
+ sys->print("rz2: %s\n", r.str());
+ x = set();
+ for (i = 0; i < 200; i++)
+ x = x.add(rand->rand(300));
+ addit(x);
+ for(i = 31; i < 70; i++)
+ addit(set().add(i));
+ }
+ sys->print("empty: %s\n", set().str());
+ addit(set());
+ sys->print("full: %s\n", set().invert().str());
+ test();
+ sys->print("done tests\n");
+}
+
+ds(d: array of byte): string
+{
+ s := "";
+ for(i := len d - 1; i >= 0; i--)
+ s += sys->sprint("%.2x", int d[i]);
+ return s;
+}
+
+testsets: list of Set;
+addit(s: Set)
+{
+ testsets = s :: testsets;
+}
+
+test()
+{
+ for (t := testsets; t != nil; t = tl t)
+ testsets = (hd t).invert() :: testsets;
+
+ for (t = testsets; t != nil; t = tl t)
+ testa(hd t);
+ for (t = testsets; t != nil; t = tl t) {
+ a := hd t;
+ for (s := testsets; s != nil; s = tl s) {
+ b := hd s;
+ testab(a, b);
+ }
+ }
+}
+
+testab(a, b: Set)
+{
+ {
+ check(!a.eq(b) == !b.eq(a), "equality");
+ if (superset(a, b) && !a.eq(b))
+ check(!superset(b, a), "superset");
+ } exception {
+ "test failed" =>
+ sys->print("%s, %s [%s, %s]\n", a.str(), b.str(), a.debugstr(), b.debugstr());
+ }
+}
+
+testa(a: Set)
+{
+ {
+ check(sets->str2set(a.str()).eq(a), "string conversion");
+ check(a.eq(a), "self equality");
+ check(a.eq(a.invert().invert()), "double inversion");
+ check(a.X(A&~B, a).eq(∅), "self not intersect");
+ check(a.limit() == a.invert().limit(), "invert limit");
+ check(a.X(A&~B, set().invert()).limit() == 0, "zero limit");
+ check(sets->bytes2set(a.bytes(0)).eq(a), "bytes conversion");
+ check(sets->bytes2set(a.bytes(3)).eq(a), "bytes conversion(2)");
+
+ if (a.limit() > 0) {
+ if (a.msb())
+ check(!a.holds(a.limit() - 1), "hold limit 1");
+ else
+ check(a.holds(a.limit() - 1), "hold limit 2");
+ }
+ } exception {
+ "test failed" =>
+ sys->print("%s [%s]\n", a.str(), a.debugstr());
+ }
+}
+
+check(ok: int, s: string)
+{
+ if (!ok) {
+ sys->print("test failed: %s; ", s);
+ raise "test failed";
+ }
+}
+
+# return true if a is a superset of b
+superset(a, b: Set): int
+{
+ return a.X(~A&B, b).eq(∅);
+}
diff --git a/appl/spree/lib/tricks.b b/appl/spree/lib/tricks.b
new file mode 100644
index 00000000..3763bac5
--- /dev/null
+++ b/appl/spree/lib/tricks.b
@@ -0,0 +1,140 @@
+implement Tricks;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+include "sets.m";
+ sets: Sets;
+ Set, All, None: import sets;
+include "../spree.m";
+ spree: Spree;
+ Attributes, Range, Object, Clique, Member: import spree;
+include "cardlib.m";
+ cardlib: Cardlib;
+ Card, getcard: import cardlib;
+include "tricks.m";
+
+clique: ref Clique;
+
+init(mod: Spree, g: ref Clique, cardlibmod: Cardlib)
+{
+ sys = load Sys Sys->PATH;
+ sets = load Sets Sets->PATH;
+ if (sets == nil)
+ panic(sys->sprint("cannot load %s: %r", Sets->PATH));
+ clique = g;
+ spree = mod;
+ cardlib = cardlibmod;
+}
+
+defaultrank := array[13] of {12, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11};
+
+# XXX should take a "rank" array so that we can cope with custom
+# card ranking
+Trick.new(pile: ref Object, trumps: int, hands: array of ref Object, rank: array of int): ref Trick
+{
+ t := ref Trick;
+ t.highcard = t.startcard = Card(-1, -1, -1);
+ t.winner = -1;
+ t.trumps = trumps;
+ t.pile = pile;
+ t.hands = hands;
+ if (rank == nil)
+ rank = defaultrank;
+ t.rank = rank;
+ return t;
+}
+
+Trick.archive(t: self ref Trick, archiveobj: ref Object, name: string)
+{
+ a := clique.newobject(archiveobj, None, "trick");
+ cardlib->setarchivename(a, name);
+ a.setattr("trumps", string t.trumps, None);
+ a.setattr("winner", string t.winner, None);
+ a.setattr("startcard.n", string t.startcard.number, None);
+ a.setattr("startcard.suit", string t.startcard.suit, None);
+ a.setattr("highcard.n", string t.highcard.number, None);
+ a.setattr("highcard.suit", string t.highcard.suit, None);
+ cardlib->setarchivename(t.pile, name + ".pile");
+ cardlib->archivearray(t.hands, name);
+ for (i := 0; i < len t.rank; i++)
+ if (t.rank[i] != defaultrank[i])
+ break;
+ if (i < len t.rank) {
+ r := "";
+ for (i = 0; i < len t.rank; i++)
+ r += " " + string t.rank[i];
+ a.setattr("rank", r, None);
+ }
+}
+
+Trick.unarchive(nil: ref Object, name: string): ref Trick
+{
+ t := ref Trick;
+ a := cardlib->getarchiveobj(name);
+ t.trumps = int a.getattr("trumps");
+ t.winner = int a.getattr("winner");
+ t.startcard.number = int a.getattr("startcard.n");
+ t.startcard.suit = int a.getattr("startcard.suit");
+ t.highcard.number = int a.getattr("highcard.n");
+ t.highcard.suit = int a.getattr("highcard.suit");
+ t.pile = cardlib->getarchiveobj(name + ".pile");
+ t.hands = cardlib->getarchivearray(name);
+ r := a.getattr("rank");
+ if (r != nil) {
+ (nil, toks) := sys->tokenize(r, " ");
+ t.rank = array[len toks] of int;
+ i := 0;
+ for (; toks != nil; toks = tl toks)
+ t.rank[i++] = int hd toks;
+ } else
+ t.rank = defaultrank;
+ return t;
+}
+
+Trick.play(t: self ref Trick, ord, idx: int): string
+{
+ stack := t.hands[ord];
+ if (idx < 0 || idx >= len stack.children)
+ return "invalid card to play";
+
+ c := getcard(stack.children[idx]);
+ c.number = t.rank[c.number];
+ if (len t.pile.children == 0) {
+ t.winner = ord;
+ t.startcard = t.highcard = c;
+ } else {
+ if (c.suit != t.startcard.suit) {
+ if (containssuit(stack, t.startcard.suit))
+ return "you must play the suit that was led";
+ if (c.suit == t.trumps &&
+ (t.highcard.suit != t.trumps ||
+ c.number > t.highcard.number)) {
+ t.highcard = c;
+ t.winner = ord;
+ }
+ } else if (c.suit == t.highcard.suit && c.number > t.highcard.number) {
+ t.highcard = c;
+ t.winner = ord;
+ }
+ }
+
+ stack.transfer((idx, idx + 1), t.pile, len t.pile.children);
+ stack.setattr("n", string (int stack.getattr("n") - 1), All);
+ return nil;
+}
+
+containssuit(stack: ref Object, suit: int): int
+{
+ ch := stack.children;
+ n := len ch;
+ for (i := 0; i < n; i++)
+ if (getcard(ch[i]).suit == suit)
+ return 1;
+ return 0;
+}
+
+panic(e: string)
+{
+ sys->fprint(sys->fildes(2), "tricks panic: %s\n", e);
+ raise "panic";
+}
diff --git a/appl/spree/lib/tricks.m b/appl/spree/lib/tricks.m
new file mode 100644
index 00000000..0cdab785
--- /dev/null
+++ b/appl/spree/lib/tricks.m
@@ -0,0 +1,21 @@
+Tricks: module {
+ PATH: con "/dis/spree/lib/tricks.dis";
+ init: fn(mod: Spree, g: ref Clique, cardlibmod: Cardlib);
+
+ Trick: adt {
+ trumps: int;
+ startcard: Cardlib->Card;
+ highcard: Cardlib->Card;
+ winner: int;
+ pile: ref Object;
+ hands: array of ref Object;
+ rank: array of int;
+
+ new: fn(pile: ref Object, trumps: int,
+ hands: array of ref Object, rank: array of int): ref Trick;
+ play: fn(t: self ref Trick, ord, idx: int): string;
+ archive: fn(t: self ref Trick, archiveobj: ref Object, name: string);
+ unarchive: fn(archiveobj: ref Object, name: string): ref Trick;
+ };
+
+};
generated by cgit v1.2.3 (git 2.46.0) at 2025-12-10 20:41:58 +0000