summaryrefslogtreecommitdiff
path: root/appl/spree/clients/cards.b
diff options
context:
space:
mode:
Diffstat (limited to 'appl/spree/clients/cards.b')
-rw-r--r--appl/spree/clients/cards.b2220
1 files changed, 2220 insertions, 0 deletions
diff --git a/appl/spree/clients/cards.b b/appl/spree/clients/cards.b
new file mode 100644
index 00000000..17601bd7
--- /dev/null
+++ b/appl/spree/clients/cards.b
@@ -0,0 +1,2220 @@
+implement Cards;
+include "sys.m";
+ sys: Sys;
+include "draw.m";
+ draw: Draw;
+ Point, Rect, Display, Image, Font: import draw;
+include "tk.m";
+ tk: Tk;
+include "tkclient.m";
+ tkclient: Tkclient;
+include "math.m";
+ math: Math;
+
+Cards: module {
+ init: fn(ctxt: ref Draw->Context, argv: list of string);
+};
+
+# fairly general card clique client.
+# inherent restrictions:
+# no dragging of cards visible over the net; it's unclear how
+# to handle the coordinate spaces involved
+
+Object: adt {
+ id: int;
+ pick {
+ Card =>
+ parentid: int;
+ face: int; # 1 is face up
+ number: int;
+ rear: int;
+ Member =>
+ cid: int;
+ name: string;
+ Stack =>
+ o: ref Layobject.Stack;
+ Widget =>
+ o: ref Layobject.Widget;
+ Menuentry =>
+ parentid: int;
+ text: string;
+ Layoutframe =>
+ lay: ref Layout.Frame;
+ Layoutobj =>
+ lay: ref Layout.Obj;
+ Scoretable =>
+ scores: array of ref Object.Score;
+ Score =>
+ row: array of (int, string);
+ height: int;
+ Button =>
+ Other =>
+ }
+};
+
+# specify how an object is laid out.
+Layout: adt {
+ id: int;
+ parentid: int;
+ opts: string; # pack options
+ orientation: int;
+ pick {
+ Frame =>
+ lays: cyclic array of ref Layout;
+ Obj =>
+ layid: int; # reference to layid of laid-out object
+ }
+};
+
+# an object which can be laid out on the canvas
+Layobject: adt {
+ id: int;
+ parentid: int;
+ w: string;
+ size: Point;
+ needrepack: int;
+ orientation: int;
+ layid: int;
+ pick {
+ Stack =>
+ style: int;
+ cards: array of ref Object.Card; # fake objects when invisible
+ pos: Point; # top-left origin of first card in stack
+ delta: Point; # card offset delta.
+ animq: ref Queue; # queue of pending animations.
+ actions: int;
+ maxcards: int;
+ title: string;
+ visible: int;
+ n: int; # for concealed stacks, n cards in stack.
+ ownerid: int; # owner of selection
+ sel: ref Selection;
+ showsize,
+ hassize: int;
+ Widget =>
+ wtype: string;
+ entries: array of ref Object.Menuentry;
+ cmd: string; # only used for entry widgets
+ width: int;
+ }
+};
+
+Animation: adt {
+ tag: string; # canvas tag common to cards being moved.
+ srcpt: Point; # where cards are coming from.
+ cards: array of ref Object.Card; # objects being transferred.
+ dstid: int;
+ index: int;
+ waitch: chan of ref Animation; # notification comes on this chan when finished.
+};
+
+Selection: adt {
+ pick {
+ XRange =>
+ r: Range;
+ Indexes =>
+ idxl: list of int;
+ Empty =>
+ }
+};
+
+MAXPLAYERS: con 4;
+
+# layout actions
+lFRAME, lOBJECT: con iota;
+
+# possible actions on a card on a stack.
+aCLICK: con 1<<iota;
+
+# styles of stack display
+styDISPLAY, styPILE: con iota;
+
+# orientations
+oLEFT, oRIGHT, oUP, oDOWN: con iota;
+
+Range: adt {
+ start, end: int;
+};
+
+T: type ref Animation;
+Queue: adt {
+ h, t: list of T;
+ put: fn(q: self ref Queue, s: T);
+ get: fn(q: self ref Queue): T;
+ isempty: fn(q: self ref Queue): int;
+ peek: fn(q: self ref Queue): T;
+};
+
+configcmds := array[] of {
+"frame .buts",
+"frame .cf",
+"canvas .c -width 400 -height 450 -bg green",
+"label .status -text 0",
+"checkbutton .buts.scores -text {Show scores} -command {send cmd scores}",
+"button .buts.sizetofit -text {Fit} -command {send cmd sizetofit}",
+"checkbutton .buts.debug -text {Debug} -variable debug -command {send cmd debug}",
+"pack .buts.sizetofit .buts.debug .status -in .buts -side left",
+"pack .buts -side top -fill x",
+"pack .c -in .cf -side top -fill both -expand 1",
+"pack .cf -side top -fill both -expand 1",
+"bind .c <Button-1> {send cmd b1 %X %Y}",
+"bind .c <ButtonRelease-1} {send cmd b1r %X %Y}",
+"bind .c <Button-2> {send cmd b2 %X %Y}",
+"bind .c <ButtonRelease-2> {send cmd b2r %X %Y}",
+"bind .c <ButtonPress-3> {send cmd b3 %X %Y}",
+"bind .c <ButtonRelease-3> {send cmd b3r %X %Y}",
+"bind . <Configure> {send cmd config}",
+"pack propagate .buts 0",
+".status configure -text {}",
+"pack propagate . 0",
+};
+
+objects: array of ref Object;
+layobjects := array[20] of list of ref Layobject;
+members := array[8] of list of ref Object.Member;
+win: ref Tk->Toplevel;
+drawctxt: ref Draw->Context;
+me: ref Object.Member;
+layout: ref Layout;
+scoretable: ref Object.Scoretable;
+showingscores := 0;
+debugging := 0;
+
+stderr: ref Sys->FD;
+animfinishedch: chan of (ref Animation, chan of chan of ref Animation);
+yieldch: chan of int;
+cardlockch: chan of int;
+notifych: chan of string;
+tickregisterch, tickunregisterch: chan of chan of int;
+starttime := 0;
+cvsfont: ref Font;
+
+packwin: ref Tk->Toplevel; # invisible; used to steal tk's packing algorithms...
+packobjs: list of ref Layobject;
+repackobjs: list of ref Layobject;
+needresize := 0;
+needrepack := 0;
+
+animid := 0;
+fakeid := -2; # ids allocated to "fake" cards in private hands; descending
+nimages := 0;
+Hiddenpos := Point(5000, 5000);
+
+cliquefd: ref Sys->FD;
+
+init(ctxt: ref Draw->Context, nil: list of string)
+{
+ sys = load Sys Sys->PATH;
+ stderr = sys->fildes(2);
+ draw = load Draw Draw->PATH;
+ tk = load Tk Tk->PATH;
+ math = load Math Math->PATH;
+ tkclient = load Tkclient Tkclient->PATH;
+ if (tkclient == nil) {
+ sys->fprint(stderr, "cards: cannot load %s: %r\n", Tkclient->PATH);
+ raise "fail:bad module";
+ }
+ tkclient->init();
+ drawctxt = ctxt;
+ client1();
+}
+
+# maximum number of rears (overridden by actual rear images)
+rearcolours := array[] of {
+ int 16r0000ccff,
+ int 16rff0000ff,
+ int 16rffff00ff,
+ int 16r008000ff,
+ int 16rffffffff,
+ int 16rffaa00ff,
+ int 16r00ffffff,
+ int 16r808080ff,
+ int 16r00ff00ff,
+ int 16r800000ff,
+ int 16r800080ff,
+};
+Rearborder := 3;
+Border := 6;
+Selectborder := 3;
+cardsize: Point;
+carddelta := Point(12, 15); # offset in order to see card number/suit
+Selectcolour := "red";
+Textfont := "/fonts/pelm/unicode.8.font";
+
+client1()
+{
+ cliquefd = sys->fildes(0);
+ if (readconfig() == -1)
+ raise "fail:error";
+
+ winctl: chan of string;
+ (win, winctl) = tkclient->toplevel(drawctxt, "-font " + Textfont,
+ "Cards", Tkclient->Appl);
+ cmd(win, ". unmap");
+ bcmd := chan of string;
+ tk->namechan(win, bcmd, "cmd");
+ srvcmd := chan of string;
+ tk->namechan(win, srvcmd, "srv");
+
+ if (readcardimages() == -1)
+ raise "fail:error";
+ for (i := 0; i < len configcmds; i++)
+ cmd(win, configcmds[i]);
+ tkclient->onscreen(win, nil);
+ tkclient->startinput(win, "kbd"::"ptr"::nil);
+
+ fontname := cmd(win, ".c cget -font");
+ cvsfont = Font.open(drawctxt.display, fontname);
+ if (cvsfont == nil) {
+ sys->fprint(stderr, "cards: cannot open font %s: %r\n", fontname);
+ raise "fail:error";
+ }
+ fontname = nil;
+
+ cardlockch = chan of int;
+ spawn lockproc();
+
+ yieldch = chan of int;
+ spawn yieldproc();
+
+ notifych = chan of string;
+ spawn notifierproc();
+
+ updatech := chan of array of byte;
+ spawn readproc(cliquefd, updatech);
+
+ spawn updateproc(updatech);
+ b1down := 0;
+
+ tickregisterch = chan of chan of int;
+ tickunregisterch = chan of chan of int;
+ spawn timeproc();
+ spawn eventproc(win);
+
+ for (;;) alt {
+ c := <-bcmd =>
+ (n, toks) := sys->tokenize(c, " ");
+ case hd toks {
+ "b3" =>
+ curp := Point(int cmd(win, ".c canvasx " + hd tl toks),
+ int cmd(win, ".c canvasy " + hd tl tl toks));
+ b3raise(bcmd, curp);
+ "b2" =>
+ curp := Point(int cmd(win, ".c canvasx " + hd tl toks),
+ int cmd(win, ".c canvasy " + hd tl tl toks));
+ dopan(bcmd, "b2", curp);
+ "b1" =>
+ if (!b1down) {
+ # b1 x y
+ # x and y in screen coords
+ curp := Point(int cmd(win, ".c canvasx " + hd tl toks),
+ int cmd(win, ".c canvasy " + hd tl tl toks));
+ b1down = b1action(bcmd, curp);
+ }
+ "b1r" =>
+ b1down = 0;
+ "entry" =>
+ id := int hd tl toks;
+ lock();
+ cc := "";
+ pick o := objects[id] {
+ Widget =>
+ cc = o.o.cmd;
+ * =>
+ sys->print("entry message from unknown obj: id %d\n", id);
+ }
+ unlock();
+ if (cc != nil) {
+ w := ".buts." + string id + ".b";
+ s := cmd(win, w + " get");
+ cardscmd(cc + " " + s);
+ cmd(win, w + " selection range 0 end");
+ cmd(win, "update");
+ }
+ "config" =>
+ lock();
+ needresize = 1;
+ updatearena();
+ unlock();
+ cmd(win, "update");
+ "scores" =>
+ if (scoretable == nil)
+ break;
+ if (!showingscores) {
+ cmd(win, ".c move score " + string -Hiddenpos.x + " " + string -Hiddenpos.y);
+ cmd(win, ".c raise score");
+ } else
+ cmd(win, ".c move score " + p2s(Hiddenpos));
+ cmd(win, "update");
+ showingscores = !showingscores;
+ "sizetofit" =>
+ lock();
+ sizetofit();
+ unlock();
+ cmd(win, "update");
+ "debug" =>
+ debugging = int cmd(win, "variable debug");
+ }
+ c := <-srvcmd => # from button or menu entry
+ cardscmd(c);
+ s := <-win.ctxt.ctl or
+ s = <-win.wreq or
+ s = <-winctl =>
+ if (s == "exit")
+ sys->write(cliquefd, array[0] of byte, 0);
+ tkclient->wmctl(win, s);
+ }
+}
+
+eventproc(win: ref Tk->Toplevel)
+{
+ for(;;)alt{
+ s := <-win.ctxt.kbd =>
+ tk->keyboard(win, s);
+ s := <-win.ctxt.ptr =>
+ tk->pointer(win, *s);
+ }
+}
+
+readproc(fd: ref Sys->FD, updatech: chan of array of byte)
+{
+ buf := rest := array[Sys->ATOMICIO * 2] of byte;
+ while ((n := sys->read(fd, rest, Sys->ATOMICIO)) > 0) {
+ updatech <-= rest[0:n];
+ rest = rest[n:];
+ if (len rest < Sys->ATOMICIO)
+ buf = rest = array[Sys->ATOMICIO * 2] of byte;
+ }
+ updatech <-= nil;
+}
+
+
+b1action(bcmd: chan of string, p: Point): int
+{
+ (hitsomething, id) := hitcard(p);
+ if (!hitsomething) {
+ dopan(bcmd, "b1", p);
+ return 0;
+ }
+ if (id < 0) { # either error, or someone else's private card
+ sys->print("no card hit (%d)\n", id);
+ return 1;
+ }
+ lock();
+ if (objects[id] == nil) {
+ notify("it's gone");
+ unlock();
+ return 1;
+ }
+ stack: ref Layobject.Stack;
+ index := -1;
+ pick o := objects[id] {
+ Card =>
+ card := o;
+ parentid := card.parentid;
+ stack = stackobj(parentid);
+ for (index = 0; index < len stack.cards; index++)
+ if (stack.cards[index] == card)
+ break;
+ if (index == len stack.cards)
+ index = -1;
+ Stack =>
+ stack = o.o;
+ * =>
+ unlock();
+ return 1;
+ }
+ actions := stack.actions;
+ stackid := stack.id;
+ unlock();
+ # XXX potential problems when object ids get reused.
+ # the object id that we saw before the unlock()
+ # might now refer to a different object, so the user
+ # might be performing a different action to the one intended.
+ # this should be changed throughout... hmm.
+ if (actions == 0) {
+ notify("no way josé");
+ sys->print("no way: stack %d, actions %d\n", stackid, actions);
+ return 1;
+ }
+ cardscmd("click " + string stackid + " " + string index);
+ return 1;
+}
+
+dopan(bcmd: chan of string, b: string, p: Point)
+{
+ r := b + "r";
+ for (;;) {
+ (n, toks) := sys->tokenize(<-bcmd, " ");
+ if (hd toks == b) {
+ pan(p, (int hd tl toks, int hd tl tl toks));
+ p = Point(int cmd(win, ".c canvasx " + hd tl toks),
+ int cmd(win, ".c canvasy " + hd tl tl toks));
+ cmd(win, "update");
+ } else if (hd toks == r)
+ return;
+ }
+}
+
+b3raise(bcmd: chan of string, p: Point)
+{
+ currcard := -1;
+ above := "";
+loop: for (;;) {
+ (nil, id) := hitcard(p);
+ if (id != currcard) {
+ if (currcard != -1 && above != nil)
+ cmd(win, ".c lower i" + string currcard + " " + above);
+ if (id == -1 || tagof(objects[id]) != tagof(Object.Card)) {
+ above = nil;
+ currcard = -1;
+ } else {
+ above = cmd(win, ".c find above i" + string id);
+ cmd(win, ".c raise i" + string id);
+ cmd(win, "update");
+ currcard = id;
+ }
+ }
+ (nil, toks) := sys->tokenize(<-bcmd, " ");
+ case hd toks {
+ "b3" =>
+ p = Point(int cmd(win, ".c canvasx " + hd tl toks),
+ int cmd(win, ".c canvasy " + hd tl tl toks));
+ "b3r" =>
+ break loop;
+ }
+ }
+ if (currcard != -1 && above != nil) {
+ cmd(win, ".c lower i" + string currcard + " " + above);
+ cmd(win, "update");
+ }
+}
+
+hitcard(p: Point): (int, int)
+{
+ (nil, hitids) := sys->tokenize(cmd(win, ".c find overlapping " + r2s((p, p))), " ");
+ if (hitids == nil)
+ return (0, -1);
+ ids: list of string;
+ for (; hitids != nil; hitids = tl hitids)
+ ids = hd hitids :: ids;
+ for (; ids != nil; ids = tl ids) {
+ (nil, tags) := sys->tokenize(cmd(win, ".c gettags " + hd ids), " ");
+ for (; tags != nil; tags = tl tags) {
+ tag := hd tags;
+ if (tag[0] == 'i' || tag[0] == 'r' || tag[0] == 'n' || tag[0] == 'N')
+ return (1, int (hd tags)[1:]);
+ if (tag[0] == 's') # ignore selection
+ break;
+ }
+ if (tags == nil)
+ break;
+ }
+ return (1, -1);
+}
+
+cardscmd(s: string): int
+{
+ if (debugging)
+ sys->print("cmd: %s\n", s);
+ if (sys->fprint(cliquefd, "%s", s) == -1) {
+ err := sys->sprint("%r");
+ notify(err);
+ sys->print("cmd error on '%s': %s\n", s, err);
+ return 0;
+ }
+ return 1;
+}
+
+updateproc(updatech: chan of array of byte)
+{
+ wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD);
+ spawn updateproc1(updatech);
+ buf := array[Sys->ATOMICIO] of byte;
+ n := sys->read(wfd, buf, len buf);
+ sys->print("updateproc process exited: %s\n", string buf[0:n]);
+}
+
+updateproc1(updatech: chan of array of byte)
+{
+ animfinishedch = chan of (ref Animation, chan of chan of ref Animation);
+ first := 1;
+ for (;;) {
+ alt {
+ v := <-animfinishedch =>
+ lock();
+ animterminated(v);
+ updatearena();
+ cmd(win, "update");
+ unlock();
+ u := <-updatech =>
+ if (u == nil) {
+ # XXX notify user that clique has been hung up somehow
+ exit;
+ }
+ moretocome := 0;
+ if (len u > 2 && u[len u-1] == byte '*' && u[len u-2] == byte '\n') {
+ u = u[0:len u - 2];
+ moretocome = 1;
+ }
+ (nil, lines) := sys->tokenize(string u, "\n");
+ lock();
+ starttime = sys->millisec();
+ for (; lines != nil; lines = tl lines)
+ applyupdate(hd lines);
+ updatearena();
+ if (!moretocome) {
+ if (first) {
+ sizetofit();
+ first = 0;
+ }
+ cmd(win, "update");
+ }
+ unlock();
+ }
+ }
+}
+
+updatearena()
+{
+ if (needrepack)
+ repackall();
+ if (needresize)
+ resizeall();
+ for (pstk := repackobjs; pstk != nil; pstk = tl pstk)
+ repackobj(hd pstk);
+ repackobjs = nil;
+}
+
+applyupdate(s: string)
+{
+ if (debugging) {
+ sys->print("update: %s\n", s);
+# showtk = 1;
+ }
+ (nt, toks) := sys->tokenize(s, " ");
+ case hd toks {
+ "create" =>
+ # create id parentid vis type
+ id := int hd tl toks;
+ if (id >= len objects)
+ objects = (array[len objects + 10] of ref Object)[0:] = objects;
+ if (objects[id] != nil)
+ panic(sys->sprint("object %d already exists!", id));
+ parentid := int hd tl tl toks;
+ vis := int hd tl tl tl toks;
+ objtype := tl tl tl tl toks;
+ case hd objtype {
+ "stack" =>
+ objects[id] = makestack(id, parentid, vis);
+ needrepack = 1;
+ "card" =>
+ stk := stackobj(parentid);
+ completeanim(stk);
+ if (!stk.visible) {
+ # if creating in a private stack, we assume
+ # that the cards were there already, and
+ # just make them real again.
+
+ # first find a fake card.
+ for (i := 0; i < len stk.cards; i++)
+ if (stk.cards[i].id < 0)
+ break;
+ c: ref Object.Card;
+ if (i == len stk.cards) {
+ # no fake cards - we'll create one instead.
+ # this can happen if we've entered halfway through
+ # a clique, so don't know how many cards people
+ # are holding.
+ c = makecard(id, stk);
+ insertcards(stk, array[] of {c}, len stk.cards);
+ } else {
+ c = stk.cards[i];
+ changecardid(c, id);
+ }
+ objects[id] = c;
+ } else {
+ objects[id] = c := makecard(id, stk);
+ insertcards(stk, array[] of {c}, len stk.cards);
+ }
+ "widget" =>
+ objects[id] = makewidget(id, parentid, hd tl objtype);
+ "menuentry" =>
+ objects[id] = makemenuentry(id, parentid, tl objtype);
+ "member" =>
+ objects[id] = ref Object.Member(id, -1, "");
+ "layframe" =>
+ lay := ref Layout.Frame(id, parentid, "", -1, nil);
+ objects[id] = ref Object.Layoutframe(id, lay);
+ addlayout(lay);
+ "layobj" =>
+ lay := ref Layout.Obj(id, parentid, "", -1, -1);
+ objects[id] = ref Object.Layoutobj(id, lay);
+ addlayout(lay);
+ "scoretable" =>
+ if (scoretable != nil)
+ panic("cannot make two scoretables");
+ scoretable = objects[id] = ref Object.Scoretable(id, nil);
+ "score" =>
+ pick l := objects[parentid] {
+ Scoretable =>
+ nl := array[len l.scores + 1] of ref Object.Score;
+ nl[0:] = l.scores;
+ nl[len nl - 1] = objects[id] = ref Object.Score(id, nil, 0);
+ l.scores = nl;
+ cmd(win, "pack .buts.scores -side left");
+ * =>
+ panic("score created outside scoretable object");
+ }
+ "button" =>
+ objects[id] = ref Object.Button(id);
+ cmd(win, "button .buts." + string id);
+ cmd(win, "pack .buts." + string id + " -side left");
+ * =>
+ if (parentid != -1)
+ sys->print("cards: unknown objtype: '%s'\n", hd objtype);
+ objects[id] = ref Object.Other(id);
+ }
+
+ "tx" =>
+ # tx src dst start end dstindex
+ src, dst: ref Layobject.Stack;
+ index: int;
+ r: Range;
+ (src, toks) = (stackobj(int hd tl toks), tl tl toks);
+ (dst, toks) = (stackobj(int hd toks), tl toks);
+ (r.start, toks) = (int hd toks, tl toks);
+ (r.end, toks) = (int hd toks, tl toks);
+ (index, toks) = (int hd toks, tl toks);
+ transfer(src, r, dst, index);
+
+ "del" =>
+ # del parent start end objs...
+ oo := objects[int hd tl toks]; # parent
+ r := Range(int hd tl tl toks, int hd tl tl tl toks);
+ pick o := oo {
+ Stack => # deleting cards from a stack.
+ stk := o.o;
+ completeanim(stk);
+ if (!stk.visible) {
+ # if deleting from a private area, we assume the cards aren't
+ # actually being deleted at all, but merely becoming
+ # invisible, so turn them into fakes.
+ for (i := r.start; i < r.end; i++) {
+ card := stk.cards[i];
+ objects[card.id] = nil;
+ changecardid(card, --fakeid);
+ cardsetattr(card, "face", "0" :: nil);
+ }
+ } else {
+ cards := extractcards(stk, r);
+ for (i := 0; i < len cards; i++)
+ destroy(cards[i]);
+ }
+ Layoutframe => # deleting the layout specification.
+ lay := o.lay;
+ if (r.start != 0 || r.end != len lay.lays)
+ panic("cannot partially delete layouts");
+ for (i := r.start; i < r.end; i++)
+ destroy(objects[lay.lays[i].id]);
+ lay.lays = nil;
+ needrepack = 1;
+ Widget =>
+ # must be a menu widget
+ cmd(win, ".buts." + string o.id + ".m delete " +
+ string r.start + " " + string r.end);
+ * =>
+ for (objs := tl tl tl tl toks; objs != nil; objs = tl objs)
+ destroy(objects[int hd objs]);
+ }
+
+ "set" =>
+ # set obj attr val
+ id := int hd tl toks;
+ (attr, val) := (hd tl tl toks, tl tl tl toks);
+ pick o := objects[id] {
+ Card =>
+ cardsetattr(o, attr, val);
+ Widget =>
+ widgetsetattr(o.o, attr, val);
+ Stack =>
+ stacksetattr(o.o, attr, val);
+ Member =>
+ membersetattr(o, attr, val);
+ Layoutframe =>
+ laysetattr(o.lay, attr, val);
+ Layoutobj =>
+ laysetattr(o.lay, attr, val);
+ Score =>
+ scoresetattr(o, attr, val);
+ Button =>
+ buttonsetattr(o, attr, val);
+ Menuentry =>
+ menuentrysetattr(o, attr, val);
+ * =>
+ sys->fprint(stderr, "unknown attr set on object(tag %d), %s\n", tagof(objects[id]), s);
+ }
+
+ "say" or
+ "remark" =>
+ notify(join(tl toks));
+ * =>
+ sys->fprint(stderr, "cards: unknown update message '%s'\n", s);
+ }
+}
+
+addlayout(lay: ref Layout)
+{
+ pick lo := objects[lay.parentid] {
+ Layoutframe =>
+ l := lo.lay;
+ nl := array[len l.lays + 1] of ref Layout;
+ nl[0:] = l.lays;
+ nl[len nl - 1] = lay;
+ l.lays = nl;
+ * =>
+ if (layout == nil)
+ layout = lay;
+ else
+ panic("cannot make two layout objects");
+ }
+}
+
+makestack(id, parentid: int, vis: int): ref Object.Stack
+{
+ o := ref Object.Stack(
+ id,
+ ref Layobject.Stack(
+ id,
+ parentid,
+ "", # pack widget name
+ (0, 0), # size
+ 0, # needrepack
+ -1, # orientation
+ -1, # layid
+ -1, # style
+ nil, # cards
+ Hiddenpos, # pos
+ (0, 0), # delta
+ ref Queue,
+ 0, # actions
+ 0, # maxcards
+ "", # title
+ vis, # visible
+ 0, # n
+ -1, # ownerid
+ ref Selection.Empty, # sel
+ 1, # showsize
+ 0 # hassize
+ )
+ );
+ cmd(win, ".c create rectangle -10 -10 -10 -10 -width 3 -tags r" + string id);
+ return o;
+}
+
+makewidget(id, parentid: int, wtype: string): ref Object.Widget
+{
+ wctype := wtype;
+ if (wtype == "menu")
+ wctype = "menubutton";
+ # XXX the widget is put in a frame 'cos of bugs in the canvas
+ # to do with size propagation.
+ w := cmd(win, "frame .buts." + string id + " -bg transparent");
+ cmd(win, wctype + " " + w + ".b");
+ cmd(win, "pack " + w + ".b -fill both -expand 1");
+ case wtype {
+ "menu" =>
+ cmd(win, "menu " + w + ".m");
+ cmd(win, w + ".b configure -menu " + w + ".m" +
+ " -relief raised");
+ "entry" =>
+ cmd(win, "bind " + w + ".b <Key-\n> {send cmd entry " + string id + "}");
+ }
+ cmd(win, ".c create window -1000 -1000 -tags r" + string id +
+ " -window " + w + " -anchor nw");
+ o := ref Object.Widget(
+ id,
+ ref Layobject.Widget(
+ id,
+ parentid,
+ nil, # w
+ (0, 0), # size
+ 0, # needrepack
+ -1, # orientation
+ -1, # style
+
+ wtype,
+ nil, # entries
+ "", # cmd
+ 0 # width
+ )
+ );
+ return o;
+}
+
+menutitleid := 0; # hack to identify menu entries
+makemenuentry(id, parentid: int, nil: list of string): ref Object.Menuentry
+{
+ m := ".buts." + string parentid + ".m";
+ t := "@" + string menutitleid++;
+ cmd(win, m + " add command -text " + t);
+ return ref Object.Menuentry(id, parentid, t);
+}
+
+makecard(id: int, stack: ref Layobject.Stack): ref Object.Card
+{
+ cmd(win, ".c create image 5000 5000 -anchor nw -tags i" + string id);
+ return ref Object.Card(id, stack.id, -1, -1, 0);
+}
+
+buttonsetattr(b: ref Object.Button, attr: string, val: list of string)
+{
+ w := ".buts." + string b.id;
+ case attr {
+ "text" =>
+ cmd(win, w + " configure -text '" + join(val));
+ "command" =>
+ cmd(win, w + " configure -command 'send srv " + join(val));
+ * =>
+ sys->print("unknown attribute on button: %s\n", attr);
+ }
+}
+
+widgetsetattr(b: ref Layobject.Widget, attr: string, val: list of string)
+{
+ w := ".buts." + string b.id + ".b";
+ case attr {
+ "text" =>
+ t := join(val);
+ if (b.wtype == "entry") {
+ cmd(win, w + " delete 0 end");
+ cmd(win, w + " insert 0 '" + t);
+ cmd(win, w + " select 0 end"); # XXX ??
+ } else {
+ cmd(win, w + " configure -text '" + t);
+ needresize = 1;
+ }
+ "command" =>
+ case b.wtype {
+ "button" =>
+ cmd(win, w + " configure -command 'send srv " + join(val));
+ "entry" =>
+ b.cmd = join(val);
+ }
+ "width" => # width in characters
+ b.width = int hd val;
+ sys->print("configuring %s for width %s\n", w, hd val);
+ cmd(win, w + " configure -width " + hd val + "w");
+ needresize = 1;
+ "layid" =>
+ setlayid(b, int hd val);
+ * =>
+ sys->print("unknown attribute on button: %s\n", attr);
+ }
+}
+
+findmenuentry(m: string, title: string): int
+{
+ end := int cmd(win, m + " index end");
+ for (i := 0; i <= end; i++) {
+ t := cmd(win, m + " entrycget " + string i + " -text");
+ if (t == title)
+ return i;
+ }
+ return -1;
+}
+
+menuentrysetattr(e: ref Object.Menuentry, attr: string, val: list of string)
+{
+ m := ".buts." + string e.parentid + ".m";
+ idx := findmenuentry(m, e.text);
+ if (idx == -1) {
+ sys->print("couldn't find menu entry '%s'\n", e.text);
+ return;
+ }
+ case attr {
+ "text" =>
+ t := join(val);
+ cmd(win, m + " entryconfigure " + string idx +" -text '" + t);
+ e.text = t;
+ "command" =>
+ cmd(win, m + " entryconfigure " + string idx +
+ " -command 'send srv " + join(val));
+ * =>
+ sys->print("unknown attribute on menu entry: %s\n", attr);
+ }
+}
+
+stacksetattr(stack: ref Layobject.Stack, attr: string, val: list of string)
+{
+ id := string stack.id;
+ case attr {
+ "maxcards" =>
+ stack.maxcards = int hd val;
+ needresize = 1;
+ "layid" =>
+ setlayid(stack, int hd val);
+ "showsize" =>
+ stack.showsize = int hd val;
+ showsize(stack);
+ "title" =>
+ title := join(val);
+ if (title != stack.title) {
+ if (stack.title == nil) {
+ cmd(win, ".c create text 5000 6000 -anchor n -tags t" + string id +
+ " -fill #ffffaa");
+ needresize = 1;
+ } else if (title == nil) {
+ cmd(win, ".c delete t" + string id);
+ needresize = 1;
+ }
+ if (title != nil)
+ cmd(win, ".c itemconfigure t" + string id + " -text '" + title);
+ stack.title = title;
+ }
+ "n" =>
+ # there are "n" cards in this stack, honest guv.
+ n := int hd val;
+ if (!stack.visible) {
+ if (n > len stack.cards) {
+ a := array[n - len stack.cards] of ref Object.Card;
+ for (i := 0; i < len a; i++) {
+ a[i] = makecard(--fakeid, stack);
+ cardsetattr(a[i], "face", "0" :: nil);
+ }
+ insertcards(stack, a, len stack.cards);
+ } else if (n < len stack.cards) {
+ for (i := len stack.cards - 1; i >= n; i--)
+ if (stack.cards[i].id >= 0)
+ break;
+ cards := extractcards(stack, (i + 1, len stack.cards));
+ for (i = 0; i < len cards; i++)
+ destroy(cards[i]);
+ }
+ }
+ stack.n = n;
+ "style" =>
+ case hd val {
+ "pile" =>
+ stack.style = styPILE;
+ "display" =>
+ stack.style = styDISPLAY;
+ * =>
+ sys->print("unknown stack style '%s'\n", hd val);
+ }
+ needresize = 1;
+ "owner" =>
+ if (val != nil)
+ stack.ownerid = int hd val;
+ else
+ stack.ownerid = -1;
+ changesel(stack, stack.sel);
+ "sel" =>
+ sel: ref Selection;
+ if (val == nil)
+ sel = ref Selection.Empty;
+ else if (tl val != nil && hd tl val == "-")
+ sel = ref Selection.XRange((int hd val, int hd tl tl val));
+ else {
+ idxl: list of int;
+ for (; val != nil; val = tl val)
+ idxl = int hd val :: idxl;
+ sel = ref Selection.Indexes(idxl);
+ }
+ changesel(stack, sel);
+ * =>
+ if (len attr >= len "actions" && attr[0:len "actions"] == "actions") {
+ oldactions := stack.actions;
+ act := 0;
+ for (; val != nil; val = tl val) {
+ case hd val {
+ "click" =>
+ act |= aCLICK;
+ * =>
+ sys->print("unknown action '%s'\n", hd val);
+ }
+ }
+ stack.actions = act;
+ } else
+ sys->fprint(stderr, "bad stack attr '%s'\n", attr);
+ }
+}
+
+showsize(stack: ref Layobject.Stack)
+{
+ id := string stack.id;
+ needsize := stack.showsize && len stack.cards > 0 && stack.style == styPILE;
+ if (needsize != stack.hassize) {
+ if (stack.hassize)
+ cmd(win, ".c delete n" + id + " N" + id);
+ else {
+ cmd(win, ".c create rectangle -5000 0 0 0 -fill #ffffaa -tags n" + id);
+ cmd(win, ".c create text -5000 0 -anchor sw -fill red -tags N" + id);
+ }
+ stack.hassize = needsize;
+ }
+ if (needsize) {
+ cmd(win, ".c itemconfigure N" + id + " -text " + string len stack.cards);
+ sr := cardrect(stack, (len stack.cards - 1, len stack.cards));
+ cmd(win, ".c coords N" + id + " " + p2s((sr.min.x, sr.max.y)));
+ bbox := cmd(win, ".c bbox N" + id);
+ cmd(win, ".c coords n" + id + " " + bbox);
+ cmd(win, ".c raise n" + id + "; .c raise N" + id);
+ }
+}
+
+changesel(stack: ref Layobject.Stack, newsel: ref Selection)
+{
+ sid := "s" + string stack.id;
+ cmd(win, ".c delete " + sid);
+
+ if (me != nil && stack.ownerid == me.cid) {
+ pick sel := newsel {
+ Indexes =>
+ for (l := sel.idxl; l != nil; l = tl l) {
+ s := cmd(win, ".c create rectangle " +
+ r2s(cardrect(stack, (hd l, hd l + 1)).inset(-1)) +
+ " -width " + string Selectborder +
+ " -outline " + Selectcolour +
+ " -tags {" + sid + " " + sid + "." + string hd l + "}");
+ cmd(win, ".c lower " + s + " i" + string stack.cards[hd l].id);
+ }
+ XRange =>
+ cmd(win, ".c create rectangle " +
+ r2s(cardrect(stack, sel.r).inset(-1)) +
+ " -outline " + Selectcolour +
+ " -width " + string Selectborder +
+ " -tags " + sid);
+ }
+ }
+ stack.sel = newsel;
+}
+
+cardsetattr(card: ref Object.Card, attr: string, val: list of string)
+{
+ id := string card.id;
+ case attr {
+ "face" =>
+ card.face = int hd val;
+ if (card.face) {
+ if (card.number != -1)
+ cmd(win, ".c itemconfigure i" + id + " -image c" + string card.number );
+ } else
+ cmd(win, ".c itemconfigure i" + id + " -image rear" + string card.rear);
+ "number" =>
+ card.number = int hd val;
+ if (card.face)
+ cmd(win, ".c itemconfigure i" + id + " -image c" + string card.number );
+ "rear" =>
+ card.rear = int hd val;
+ if (card.face == 0)
+ cmd(win, ".c itemconfigure i" + id + " -image rear" + string card.rear);
+ * =>
+ sys->print("unknown attribute on card: %s\n", attr);
+ }
+}
+
+setlayid(layobj: ref Layobject, layid: int)
+{
+ if (layobj.layid != -1)
+ panic("obj already has a layout id (" + string layobj.layid + ")");
+ layobj.layid = layid;
+ x := layobj.layid % len layobjects;
+ layobjects[x] = layobj :: layobjects[x];
+ needrepack = 1;
+}
+
+membersetattr(p: ref Object.Member, attr: string, val: list of string)
+{
+ case attr {
+ "you" =>
+ me = p;
+ p.cid = int hd val;
+ for (i := 0; i < len objects; i++) {
+ if (objects[i] != nil) {
+ pick o := objects[i] {
+ Stack =>
+ if (o.o.ownerid == p.cid)
+ objneedsrepack(o.o);
+ }
+ }
+ }
+ "name" =>
+ p.name = hd val;
+ "id" =>
+ p.cid = int hd val;
+ "status" =>
+ if (p == me)
+ cmd(win, ".status configure -text '" + join(val));
+ "cliquetitle" =>
+ if (p == me)
+ tkclient->settitle(win, join(val));
+ * =>
+ sys->print("unknown attribute on member: %s\n", attr);
+ }
+}
+
+laysetattr(lay: ref Layout, attr: string, val: list of string)
+{
+ case attr {
+ "opts" =>
+ # orientation opts
+ case hd val {
+ "up" =>
+ lay.orientation = oUP;
+ "down" =>
+ lay.orientation = oDOWN;
+ "left" =>
+ lay.orientation = oLEFT;
+ "right" =>
+ lay.orientation = oRIGHT;
+ * =>
+ sys->print("unknown orientation '%s'\n", hd val);
+ }
+ lay.opts = join(tl val);
+ "layid" =>
+# sys->print("layout obj %d => layid %s\n", lay.id, hd val);
+ pick l := lay {
+ Obj =>
+ l.layid = int hd val;
+ needrepack = 1;
+ * =>
+ sys->print("cannot set layid on Layout.Frame!\n");
+ }
+ * =>
+ sys->print("unknown attribute on lay: %s\n", attr);
+ }
+ needrepack = 1;
+}
+
+scoresetattr(score: ref Object.Score, attr: string, val: list of string)
+{
+ if (attr != "score")
+ return;
+ cmd(win, ".c delete score");
+
+ Padx: con 10; # padding to the right of each item
+ Pady: con 6; # padding below each item.
+
+ n := len val;
+ row := score.row = array[n] of (int, string);
+ height := 0;
+
+ # calculate values for this row
+ for ((col, vl) := (0, val); vl != nil; (col, vl) = (col + 1, tl vl)) {
+ v := hd vl;
+ size := textsize(v);
+ size.y += Pady;
+ if (size.y > height)
+ height = size.y;
+ row[col] = (size.x + Padx, v);
+ }
+ score.height = height;
+ totheight := 0;
+ scores := scoretable.scores;
+
+ # calculate number of columns
+ ncols := 0;
+ for (i := 0; i < len scores; i++)
+ if (len scores[i].row > ncols)
+ ncols = len scores[i].row;
+
+ # calculate column widths
+ colwidths := array[ncols] of {* => 0};
+ for (i = 0; i < len scores; i++) {
+ r := scores[i].row;
+ for (j := 0; j < len r; j++) {
+ (w, nil) := r[j];
+ if (w > colwidths[j])
+ colwidths[j] = w;
+ }
+ totheight += scores[i].height;
+ }
+ # create all table items
+ p := Hiddenpos;
+ for (i = 0; i < len scores; i++) {
+ p.x = Hiddenpos.x;
+ r := scores[i].row;
+ for (j := 0; j < len r; j++) {
+ (w, text) := r[j];
+ cmd(win, ".c create text " + p2s(p) + " -anchor nw -tags {score scoreent}-text '" + text);
+ p.x += colwidths[j];
+ }
+ p.y += scores[i].height;
+ }
+ r := Rect(Hiddenpos, p);
+ r.min.x -= Padx;
+ r.max.y -= Pady / 2;
+
+ cmd(win, ".c create rectangle " + r2s(r) + " -fill #ffffaa -tags score");
+
+ # horizontal lines
+ y := 0;
+ for (i = 0; i < len scores - 1; i++) {
+ ly := y + scores[i].height - Pady / 2;
+ cmd(win, ".c create line " + r2s(((r.min.x, ly), (r.max.x, ly))) + " -fill gray -tags score");
+ y += scores[i].height;
+ }
+
+ cmd(win, ".c raise scoreent");
+ cmd(win, ".c move score " + p2s(Hiddenpos.sub(r.min)));
+}
+
+textsize(s: string): Point
+{
+ return (cvsfont.width(s), cvsfont.height);
+}
+
+changecardid(c: ref Object.Card, newid: int)
+{
+ (nil, tags) := sys->tokenize(cmd(win, ".c gettags i" + string c.id), " ");
+ for (; tags != nil; tags = tl tags) {
+ tag := hd tags;
+ if (tag[0] >= '0' && tag[0] <= '9')
+ break;
+ }
+ cvsid := hd tags;
+ cmd(win, ".c dtag " + cvsid + " i" + string c.id);
+ c.id = newid;
+ cmd(win, ".c addtag i" + string c.id + " withtag " + cvsid);
+}
+
+stackobj(id: int): ref Layobject.Stack
+{
+ obj := objects[id];
+ if (obj == nil)
+ panic("nil stack object");
+ pick o := obj {
+ Stack =>
+ return o.o;
+ * =>
+ panic("expected obj " + string id + " to be a stack");
+ }
+ return nil;
+}
+
+# if there are updates pending on the stack,
+# then wait for them all to finish before we can do
+# any operations on the stack (e.g. insert, delete, create, etc)
+completeanim(stk: ref Layobject.Stack)
+{
+ while (!stk.animq.isempty())
+ animterminated(<-animfinishedch);
+}
+
+transfer(src: ref Layobject.Stack, r: Range, dst: ref Layobject.Stack, index: int)
+{
+ # we don't bother animating movement within a stack; maybe later?
+ if (src == dst) {
+ transfercards(src, r, dst, index);
+ return;
+ }
+ completeanim(src);
+
+ if (!src.visible) {
+ # cards being transferred out of private area should
+ # have already been created, but check anyway.
+ if (r.start != 0)
+ panic("bad transfer out of private");
+ for (i := 0; i < r.end; i++)
+ if (src.cards[i].id < 0)
+ panic("cannot transfer fake card");
+ }
+
+ startanimating(newanimation(src, r), dst, index);
+}
+
+objneedsrepack(obj: ref Layobject)
+{
+ if (!obj.needrepack) {
+ obj.needrepack = 1;
+ repackobjs = obj :: repackobjs;
+ }
+}
+
+repackobj(obj: ref Layobject)
+{
+ pick o := obj {
+ Stack =>
+ cards := o.cards;
+ pos := o.pos;
+ delta := o.delta;
+ for (i := 0; i < len cards; i++) {
+ p := pos.add(delta.mul(i));
+ id := string cards[i].id;
+ cmd(win, ".c coords i" + id + " " + p2s(p));
+ cmd(win, ".c raise i" + id); # XXX could be more efficient.
+ cmd(win, ".c lower s" + string o.id + "." + string i + " i" + id);
+ }
+ changesel(o, o.sel);
+ showsize(o);
+ }
+ obj.needrepack = 0;
+}
+
+cardrect(stack: ref Layobject.Stack, r: Range): Rect
+{
+ if (r.start == r.end)
+ return ((-10, -10), (-10, -10));
+ cr := Rect((0, 0), cardsize).addpt(stack.pos);
+ delta := stack.delta;
+ return union(cr.addpt(delta.mul(r.start)), cr.addpt(delta.mul(r.end - 1)));
+}
+
+repackall()
+{
+ sys->print("repackall()\n");
+ needrepack = 0;
+ if (layout == nil) {
+ sys->print("no layout\n");
+ return;
+ }
+ if (packwin == nil) {
+ # use an unmapped tk window to do our packing arrangements
+ packwin = tk->toplevel(drawctxt.display, "-bd 0");
+ packwin.wreq = nil; # stop window requests piling up.
+ }
+ cmd(packwin, "destroy " + cmd(packwin, "pack slaves ."));
+ packobjs = nil;
+ packit(layout, ".0");
+ sys->print("%d packobjs\n", len packobjs);
+ needresize = 1;
+}
+
+# make the frames for the objects to be laid out, in the
+# offscreen window.
+packit(lay: ref Layout, f: string)
+{
+ cmd(packwin, "frame " + f);
+ cmd(packwin, "pack " + f + " " + lay.opts);
+ pick l := lay {
+ Frame =>
+ for (i := 0; i < len l.lays; i++)
+ packit(l.lays[i], f + "." + string i);
+ Obj =>
+ if ((obj := findlayobject(l.layid)) != nil) {
+ obj.w = f;
+ obj.orientation = l.orientation;
+ packobjs = obj :: packobjs;
+ } else
+ sys->print("cannot find layobject %d\n", l.layid);
+ }
+}
+
+sizetofit()
+{
+ if (packobjs == nil)
+ return;
+ cmd(packwin, "pack propagate . 1");
+ cmd(packwin, ". configure -width 0 -height 0"); # make sure propagation works.
+ csz := actsize(packwin, ".");
+ cmd(win, "bind . <Configure> {}");
+ cmd(win, "pack propagate . 1");
+ cmd(win, ". configure -width 0 -height 0");
+
+ cmd(win, ".c configure -width " + string csz.x + " -height " + string csz.y
+ + " -scrollregion {0 0 " + p2s(csz) + "}");
+ winr := actrect(win, ".");
+ screenr := win.image.screen.image.r;
+ if (!winr.inrect(screenr)) {
+ if (winr.dx() > screenr.dx())
+ (winr.min.x, winr.max.x) = (screenr.min.x, screenr.max.x);
+ if (winr.dy() > screenr.dy())
+ (winr.min.y, winr.max.y) = (screenr.min.y, screenr.max.y);
+ if (winr.max.x > screenr.max.x)
+ (winr.min.x, winr.max.x) = (screenr.max.x - winr.dx(), screenr.max.x);
+ if (winr.max.y > screenr.max.y)
+ (winr.min.y, winr.max.y) = (screenr.max.y - winr.dy(), screenr.max.y);
+ }
+ cmd(win, "pack propagate . 0");
+ cmd(win, ". configure " +
+ " -x " + string winr.min.x +
+ " -y " + string winr.min.y +
+ " -width " + string winr.dx() +
+ " -height " + string winr.dy());
+ needresize = 1;
+ updatearena();
+ cmd(win, "bind . <Configure> {send cmd config}");
+}
+
+setorigin(r: Rect, p: Point): Rect
+{
+ sz := Point(r.max.x - r.min.x, r.max.y - r.min.y);
+ return (p, p.add(sz));
+}
+
+resizeall()
+{
+ needresize = 0;
+ if (packobjs == nil)
+ return;
+ cmd(packwin, "pack propagate . 1");
+ cmd(packwin, ". configure -width 0 -height 0"); # make sure propagation works.
+ for (sl := packobjs; sl != nil; sl = tl sl) {
+ obj := hd sl;
+ sizeobj(obj);
+ cmd(packwin, obj.w + " configure -width " + string obj.size.x +
+ " -height " + string obj.size.y);
+ }
+ csz := actsize(packwin, ".");
+ sz := actsize(win, ".cf");
+ if (sz.x > csz.x || sz.y > csz.y) {
+ cmd(packwin, "pack propagate . 0");
+ if (sz.x > csz.x) {
+ cmd(packwin, ". configure -width " + string sz.x);
+ cmd(win, ".c xview moveto 0");
+ csz.x = sz.x;
+ }
+ if (sz.y > csz.y) {
+ cmd(packwin, ". configure -height " + string sz.y);
+ cmd(win, ".c yview moveto 0");
+ csz.y = sz.y;
+ }
+ }
+ cmd(win, ".c configure -width " + string csz.x + " -height " + string csz.y
+ + " -scrollregion {0 0 " + p2s(csz) + "}");
+ onscreen();
+ for (sl = packobjs; sl != nil; sl = tl sl) {
+ obj := hd sl;
+ r := actrect(packwin, obj.w);
+ positionobj(obj, r);
+ }
+}
+
+# make sure that there aren't any unnecessary blank
+# bits in the scroll area.
+onscreen()
+{
+ (n, toks) := sys->tokenize(cmd(win, ".c xview"), " ");
+ cmd(win, ".c xview moveto " + hd toks);
+ (n, toks) = sys->tokenize(cmd(win, ".c yview"), " ");
+ cmd(win, ".c yview moveto " + hd toks);
+}
+
+# work out the size of an object to be laid out.
+sizeobj(obj: ref Layobject)
+{
+ pick o := obj {
+ Stack =>
+ delta := Point(0, 0);
+ case o.style {
+ styDISPLAY =>
+ case o.orientation {
+ oRIGHT => delta.x = carddelta.x;
+ oLEFT => delta.x = -carddelta.x;
+ oDOWN => delta.y = carddelta.y;
+ oUP => delta.y = -carddelta.y;
+ }
+ styPILE =>
+ ; # no offset
+ }
+ o.delta = delta;
+ r := Rect((0, 0), size(cardrect(o, (0, max(len o.cards, o.maxcards)))));
+ if (o.title != nil) {
+ p := Point(r.min.x + r.dx() / 2, r.min.y);
+ tr := s2r(cmd(win, ".c bbox t" + string o.id));
+ tbox := Rect((p.x - tr.dx() / 2, p.y - tr.dy()), (p.x + tr.dx() / 2, p.y));
+ r = union(r, tbox);
+ }
+ o.size = r.max.sub(r.min).add((Border * 2, Border * 2));
+# sys->print("sized stack %d => %s\n", o.id, p2s(o.size));
+ Widget =>
+ w := ".buts." + string o.id;
+ o.size.x = int cmd(win, w + " cget -width");
+ o.size.y = int cmd(win, w + " cget -height");
+# sys->print("sized widget %d (%s) => %s\n", o.id,
+# cmd(win, "winfo class " + w + ".b"), p2s(o.size));
+ }
+}
+
+# set a laid-out object's position on the canvas, given
+# its allocated rectangle, r.
+positionobj(obj: ref Layobject, r: Rect)
+{
+ pick o := obj {
+ Stack =>
+# sys->print("positioning stack %d, r %s\n", o.id, r2s(r));
+ delta := o.delta;
+ sz := o.size.sub((Border * 2, Border * 2));
+ r.min.x += (r.dx() - sz.x) / 2;
+ r.min.y += (r.dy() - sz.y) / 2;
+ r.max = r.min.add(sz);
+ if (o.title != nil) {
+ cmd(win, ".c coords t" +string o.id + " " +
+ string (r.min.x + r.dx() / 2) + " " + string r.min.y);
+ tr := s2r(cmd(win, ".c bbox t" + string o.id));
+ r.min.y = tr.max.y;
+ sz = size(cardrect(o, (0, max(len o.cards, o.maxcards))));
+ r.min.x += (r.dx() - sz.x) / 2;
+ r.min.y += (r.dy() - sz.y) / 2;
+ r.max = r.min.add(sz);
+ }
+ o.pos = r.min;
+ if (delta.x < 0)
+ o.pos.x = r.max.x - cardsize.x;
+ if (delta.y < 0)
+ o.pos.y = r.max.y - cardsize.y;
+ cmd(win, ".c coords r" + string o.id + " " + r2s(r.inset(-(Border / 2))));
+ objneedsrepack(o);
+ Widget =>
+# sys->print("positioning widget %d, r %s\n", o.id, r2s(r));
+ cmd(win, ".c coords r" + string o.id + " " + p2s(r.min));
+ bd := int cmd(win, ".buts." + string o.id + " cget -bd");
+ cmd(win, ".c itemconfigure r" + string o.id +
+ " -width " + string (r.dx() - bd * 2) +
+ " -height " + string (r.dy() - bd * 2));
+ }
+}
+
+size(r: Rect): Point
+{
+ return r.max.sub(r.min);
+}
+
+transfercards(src: ref Layobject.Stack, r: Range, dst: ref Layobject.Stack, index: int)
+{
+ cards := extractcards(src, r);
+ n := r.end - r.start;
+ # if we've just removed some cards from the destination,
+ # then adjust the destination index accordingly.
+ if (src == dst && index > r.start) {
+ if (index < r.end)
+ index = r.start;
+ else
+ index -= n;
+ }
+ insertcards(dst, cards, index);
+}
+
+extractcards(src: ref Layobject.Stack, r: Range): array of ref Object.Card
+{
+ if (len src.cards > src.maxcards)
+ needresize = 1;
+ deltag(src.cards[r.start:r.end], "c" + string src.id);
+ n := r.end - r.start;
+ cards := src.cards[r.start:r.end];
+ newcards := array[len src.cards - n] of ref Object.Card;
+ newcards[0:] = src.cards[0:r.start];
+ newcards[r.start:] = src.cards[r.end:];
+ src.cards = newcards;
+ objneedsrepack(src); # XXX not necessary if moving from top?
+ return cards;
+}
+
+insertcards(dst: ref Layobject.Stack, cards: array of ref Object.Card, index: int)
+{
+ n := len cards;
+ newcards := array[len dst.cards + n] of ref Object.Card;
+ newcards[0:] = dst.cards[0:index];
+ newcards[index + n:] = dst.cards[index:];
+ newcards[index:] = cards;
+ dst.cards = newcards;
+
+ for (i := 0; i < len cards; i++)
+ cards[i].parentid = dst.id;
+ addtag(dst.cards[index:index + n], "c" + string dst.id);
+ objneedsrepack(dst); # XXX not necessary if adding to top?
+ if (len dst.cards > dst.maxcards)
+ needresize = 1;
+}
+
+destroy(obj: ref Object)
+{
+ if (obj.id >= 0)
+ objects[obj.id] = nil;
+ id := string obj.id;
+ pick o := obj {
+ Card =>
+ cmd(win, ".c delete i" + id); # XXX crashed here once...
+ Widget =>
+ cmd(win, ".c delete r" + id);
+ w := ".buts." + id;
+ cmd(win, "destroy " + w);
+ dellayobject(o.o);
+ Stack =>
+ completeanim(o.o);
+ cmd(win, ".c delete r" + id + " s" + id + " n" + id + " N" + id);
+ if (o.o.title != nil)
+ cmd(win, ".c delete t" + id);
+ cmd(win, ".c delete c" + id); # any remaining "fake" cards
+ needrepack = 1;
+ dellayobject(o.o);
+ Button =>
+ cmd(win, "destroy .buts." + string o.id);
+ Member =>
+ if (o.cid != -1) {
+ # XXX remove member from members hash.
+ }
+ Layoutobj =>
+ if ((l := findlayobject(o.lay.layid)) != nil) {
+ # XXX are we sure they're not off-screen anyway?
+ cmd(win, ".c move r" + string l.id + " 5000 5000");
+ cmd(win, ".c move c" + string l.id + " 5000 5000");
+ cmd(win, ".c move N" + string l.id + " 5000 5000");
+ cmd(win, ".c move n" + string l.id + " 5000 5000");
+ cmd(win, ".c move s" + string l.id + " 5000 5000");
+ }
+ if (layout == o.lay)
+ layout = nil;
+ Layoutframe =>
+ if (layout == o.lay)
+ layout = nil;
+ }
+}
+
+dellayobject(lay: ref Layobject)
+{
+ if (lay.layid == -1)
+ return;
+ x := lay.layid % len layobjects;
+ nl: list of ref Layobject;
+ for (ll := layobjects[x]; ll != nil; ll = tl ll)
+ if ((hd ll).layid != lay.layid)
+ nl = hd ll :: nl;
+ layobjects[x] = nl;
+}
+
+findlayobject(layid: int): ref Layobject
+{
+ if (layid == -1)
+ return nil;
+ for (ll := layobjects[layid % len layobjects]; ll != nil; ll = tl ll)
+ if ((hd ll).layid == layid)
+ return hd ll;
+ return nil;
+}
+
+deltag(cards: array of ref Object.Card, tag: string)
+{
+ for (i := 0; i < len cards; i++)
+ cmd(win, ".c dtag i" + string cards[i].id + " " + tag);
+}
+
+addtag(cards: array of ref Object.Card, tag: string)
+{
+ for (i := 0; i < len cards; i++)
+ cmd(win, ".c addtag " + tag + " withtag i" + string cards[i].id);
+}
+
+join(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;
+}
+
+notify(s: string)
+{
+ notifych <-= s;
+}
+
+notifierproc()
+{
+ notifypid := -1;
+ sync := chan of int;
+ for (;;) {
+ s := <-notifych;
+ kill(notifypid);
+ spawn notifyproc(s, sync);
+ notifypid = <-sync;
+ }
+}
+
+notifyproc(s: string, sync: chan of int)
+{
+ sync <-= sys->pctl(0, nil);
+ cmd(win, ".c delete notify");
+ id := cmd(win, ".c create text " + p2s(visibleorigin()) + " -anchor nw -fill red -tags notify -text '" + s);
+ bbox := cmd(win, ".c bbox " + id);
+ cmd(win, ".c create rectangle " + bbox + " -fill #ffffaa -tags notify");
+ cmd(win, ".c raise " + id);
+ cmd(win, "update");
+ sys->sleep(1500);
+ cmd(win, ".c delete notify");
+ cmd(win, "update");
+}
+
+# move canvas so that canvas point canvp lies under
+# screen point scrp.
+pan(canvp, scrp: Point)
+{
+ o := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty"));
+ co := canvp.sub(scrp.sub(o));
+ sz := Point(int cmd(win, ".c cget -width"), int cmd(win, ".c cget -height"));
+
+ cmd(win, ".c xview moveto " + string (real co.x / real sz.x));
+ cmd(win, ".c yview moveto " + string (real co.y / real sz.y));
+}
+
+# return the top left point that's currently visible
+# in the canvas, taking into account scrolling.
+visibleorigin(): Point
+{
+ (scrx, scry) := (cmd(win, ".c cget -actx"), cmd(win, ".c cget -acty"));
+ return Point (int cmd(win, ".c canvasx " + scrx),
+ int cmd(win, ".c canvasy " + scry));
+}
+
+s2r(s: string): Rect
+{
+ r: Rect;
+ (n, toks) := sys->tokenize(s, " ");
+ if (n < 4)
+ panic("malformed rectangle " + s);
+ (r.min.x, toks) = (int hd toks, tl toks);
+ (r.min.y, toks) = (int hd toks, tl toks);
+ (r.max.x, toks) = (int hd toks, tl toks);
+ (r.max.y, toks) = (int hd toks, tl toks);
+ return r;
+}
+
+r2s(r: Rect): string
+{
+ return sys->sprint("%d %d %d %d", r.min.x, r.min.y, r.max.x, r.max.y);
+}
+
+p2s(p: Point): string
+{
+ return string p.x + " " + string p.y;
+}
+
+union(r1, r2: Rect): Rect
+{
+ if (r1.min.x > r2.min.x)
+ r1.min.x = r2.min.x;
+ if (r1.min.y > r2.min.y)
+ r1.min.y = r2.min.y;
+
+ if (r1.max.x < r2.max.x)
+ r1.max.x = r2.max.x;
+ if (r1.max.y < r2.max.y)
+ r1.max.y = r2.max.y;
+ return r1;
+}
+
+kill(pid: int)
+{
+ if ((fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE)) != nil)
+ sys->write(fd, array of byte "kill", 4);
+}
+
+lockproc()
+{
+ for (;;) {
+ <-cardlockch;
+ cardlockch <-=1;
+ }
+}
+
+lock()
+{
+ cardlockch <-= 1;
+}
+
+unlock()
+{
+ <-cardlockch;
+}
+
+openimage(file: string, id: string): Point
+{
+ if (tk->cmd(win, "image create bitmap " + id + " -file " + file)[0] == '!')
+ return (0, 0);
+ return (int tk->cmd(win, "image width " + id),
+ int tk->cmd(win, "image height " + id));
+}
+
+# read images into tk.
+readimages(dir: string, prefix: string): (int, Point)
+{
+ displ := drawctxt.display;
+ if (cardsize.x > 0 && cardsize.y > 0 &&
+ (img := displ.open(dir + "/" + prefix + ".all.bit")) != nil) {
+ if (img.r.dx() % cardsize.x != 0 || img.r.dy() != cardsize.y)
+ sys->fprint(stderr, "cards: inconsistent complete image, ignoring\n");
+ else {
+ n := img.r.dx() / cardsize.x;
+ x := img.r.min.x;
+ sys->print("found %d cards in complete image\n", n);
+ for (i := 0; i < n; i++) {
+ c := displ.newimage(((0, 0), cardsize), img.chans, 0, 0);
+ c.draw(c.r, img, nil, (x, 0));
+ id := prefix + string i;
+ cmd(win, "image create bitmap " + id);
+ tk->putimage(win, id, c, nil);
+ x += cardsize.x;
+ }
+ return (n, cardsize);
+ }
+ }
+
+ size := openimage("@" + dir + "/" + prefix + "0.bit", prefix + "0");
+ if (size.x == 0) {
+ sys->print("no first image (filename: '%s')\n", dir + "/" + prefix + "0.bit");
+ return (0, (0, 0));
+ }
+ i := 1;
+ for (;;) {
+ nsize := openimage("@" + dir + "/" + prefix + string i + ".bit", prefix + string i);
+ if (nsize.x == 0)
+ break;
+ if (!nsize.eq(size))
+ sys->fprint(stderr, "warning: inconsistent image size in %s/%s%d.bit, " +
+ "[%d %d] vs [%d %d]\n", dir, prefix, i, size.x, size.y, nsize.x, nsize.y);
+ i++;
+ }
+ return (i, size);
+}
+
+newanimation(src: ref Layobject.Stack, r: Range): ref Animation
+{
+ a := ref Animation;
+ a.srcpt = src.pos.add(src.delta.mul(r.start));
+ cards := extractcards(src, r);
+ a.cards = cards;
+ a.waitch = chan of ref Animation;
+ return a;
+}
+
+startanimating(a: ref Animation, dst: ref Layobject.Stack, index: int)
+{
+ q := dst.animq;
+ if (q.isempty())
+ spawn animqueueproc(a.waitch);
+
+ a.tag = "a" + string animid++;
+ addtag(a.cards, a.tag);
+ q.put(a);
+ a.dstid = dst.id;
+ a.index = index;
+ spawn animproc(a);
+}
+
+SPEED: con 1.5; # animation speed in pixels/millisec
+
+animproc(a: ref Animation)
+{
+ tick := chan of int;
+ dst := stackobj(a.dstid);
+ if (dst == nil)
+ panic("animation destination has gone!");
+ dstpt := dst.pos.add(dst.delta.mul(a.index));
+ srcpt := a.srcpt;
+ d := dstpt.sub(srcpt);
+ # don't bother animating if moving to or from a hidden stack.
+ if (!srcpt.eq(Hiddenpos) && !dst.pos.eq(Hiddenpos) && !d.eq((0, 0))) {
+ mag := math->sqrt(real(d.x * d.x + d.y * d.y));
+ (vx, vy) := (real d.x / mag, real d.y / mag);
+ currpt := a.srcpt; # current position of cards
+ t0 := starttime;
+ dt := int (mag / SPEED);
+ t := 0;
+ tickregister(tick);
+ cmd(win, ".c raise " + a.tag);
+ while (t < dt) {
+ s := real t * SPEED;
+ p := Point(srcpt.x + int (s * vx), srcpt.y + int (s * vy));
+ dp := p.sub(currpt);
+ cmd(win, ".c move " + a.tag + " " + string dp.x + " " + string dp.y);
+ currpt = p;
+ t = <-tick - t0;
+ }
+ tickunregister(tick);
+ cmd(win, "update");
+ }
+ a.waitch <-= a;
+}
+
+tickregister(tick: chan of int)
+{
+ tickregisterch <-= tick;
+}
+
+tickunregister(tick: chan of int)
+{
+ tickunregisterch <-= tick;
+}
+
+tickproc(tick: chan of int)
+{
+ for (;;)
+ tick <-= 1;
+}
+
+timeproc()
+{
+ reg: list of chan of int;
+ dummytick := chan of int;
+ realtick := chan of int;
+ tick := dummytick;
+ spawn tickproc(realtick);
+ for (;;) {
+ alt {
+ c := <-tickregisterch =>
+ if (reg == nil)
+ tick = realtick;
+ reg = c :: reg;
+ c := <-tickunregisterch =>
+ r: list of chan of int;
+ for (; reg != nil; reg = tl reg)
+ if (hd reg != c)
+ r = hd reg :: r;
+ reg = r;
+ if (reg == nil)
+ tick = dummytick;
+ <-tick =>
+ t := sys->millisec();
+ for (r := reg; r != nil; r = tl r) {
+ alt {
+ hd r <-= t =>
+ ;
+ * =>
+ ;
+ }
+ }
+ cmd(win, "update");
+ }
+ }
+}
+
+yield()
+{
+ yieldch <-= 1;
+}
+
+yieldproc()
+{
+ for (;;)
+ <-yieldch;
+}
+
+
+# send completed animations down animfinishedch;
+# wait for a reply, which is either a new animation to wait
+# for (the next in the queue) or nil, telling us to exit
+animqueueproc(waitch: chan of ref Animation)
+{
+ rc := chan of chan of ref Animation;
+ while (waitch != nil) {
+ animfinishedch <-= (<-waitch, rc);
+ waitch = <-rc;
+ }
+}
+
+# an animation has finished.
+# move the cards into their final place in the stack,
+# remove the animation from the queue it's on,
+# and inform the mediating process of the next animation process in the queue.
+animterminated(v: (ref Animation, chan of chan of ref Animation))
+{
+ (a, rc) := v;
+ deltag(a.cards, a.tag);
+ dst := stackobj(a.dstid);
+ insertcards(dst, a.cards, a.index);
+ repackobj(dst);
+ cmd(win, "update");
+ q := dst.animq;
+ q.get();
+ if (q.isempty())
+ rc <-= nil;
+ else {
+ a = q.peek();
+ rc <-= a.waitch;
+ }
+}
+
+actrect(win: ref Tk->Toplevel, w: string): Rect
+{
+ r: Rect;
+ r.min.x = int cmd(win, w + " cget -actx") + int cmd(win, w + " cget -bd");
+ r.min.y = int cmd(win, w + " cget -acty") + int cmd(win, w + " cget -bd");
+ r.max.x = r.min.x + int cmd(win, w + " cget -actwidth");
+ r.max.y = r.min.y + int cmd(win, w + " cget -actheight");
+ return r;
+}
+
+actsize(win: ref Tk->Toplevel, w: string): Point
+{
+ return (int cmd(win, w + " cget -actwidth"), int cmd(win, w + " cget -actheight"));
+}
+
+Queue.put(q: self ref Queue, s: T)
+{
+ q.t = s :: q.t;
+}
+
+Queue.get(q: self ref Queue): T
+{
+ s: T;
+ if(q.h == nil){
+ q.h = revlist(q.t);
+ q.t = nil;
+ }
+ if(q.h != nil){
+ s = hd q.h;
+ q.h = tl q.h;
+ }
+ return s;
+}
+
+Queue.peek(q: self ref Queue): T
+{
+ s: T;
+ if (q.isempty())
+ return s;
+ s = q.get();
+ q.h = s :: q.h;
+ return s;
+}
+
+Queue.isempty(q: self ref Queue): int
+{
+ return q.h == nil && q.t == nil;
+}
+
+revlist(ls: list of T) : list of T
+{
+ rs: list of T;
+ for (; ls != nil; ls = tl ls)
+ rs = hd ls :: rs;
+ return rs;
+}
+
+readconfig(): int
+{
+ for (lines := readconfigfile("/icons/cards/config"); lines != nil; lines = tl lines) {
+ t := hd lines;
+ case hd t {
+ "rearborder" =>
+ Rearborder = int hd tl t;
+ "border" =>
+ Border = int hd tl t;
+ "selectborder" =>
+ Selectborder = int hd tl t;
+ "xdelta" =>
+ carddelta.x = int hd tl t;
+ "ydelta" =>
+ carddelta.y = int hd tl t;
+ "font" =>
+ Textfont = hd tl t;
+ "selectcolour" =>
+ Selectcolour = hd tl t;
+ "cardsize" =>
+ if (len t != 3)
+ sys->fprint(stderr, "cards: invalid value for cardsize attribute\n");
+ else
+ cardsize = (int hd tl t, int hd tl tl t);
+ * =>
+ sys->fprint(stderr, "cards: unknown config attribute: %s\n", hd t);
+ }
+ }
+ return 0;
+}
+
+readcardimages(): int
+{
+ (nimages, cardsize) = readimages("/icons/cards", "c");
+ if (nimages == 0) {
+ sys->fprint(stderr, "cards: no card images found\n");
+ return -1;
+ }
+ sys->print("%d card images found\n", nimages);
+
+ (nrears, rearsize) := readimages("/icons/cardrears", "rear");
+ if (nrears > 0 && !rearsize.eq(cardsize)) {
+ sys->fprint(stderr, "cards: card rear sizes don't match card sizes (%s vs %s)\n", p2s(rearsize), p2s(cardsize));
+ return -1;
+ }
+ sys->print("%d card rear images found\n", nrears);
+ cr := Rect((0, 0), cardsize);
+ for (i := nrears; i < len rearcolours; i++) {
+ cmd(win, "image create bitmap rear" + string i);
+ img := drawctxt.display.newimage(cr, Draw->XRGB32, 0, Draw->Black);
+ img.draw(cr.inset(Rearborder),
+ drawctxt.display.color(rearcolours[i] - nrears), nil, (0, 0));
+ tk->putimage(win, "rear" + string i, img, nil);
+ }
+ return 0;
+}
+
+readconfigfile(f: string): list of list of string
+{
+ sys->print("opening config file '%s'\n", f);
+ fd := sys->open(f, Sys->OREAD);
+ if (fd == nil)
+ return nil;
+ buf := array[Sys->ATOMICIO] of byte;
+ nb := sys->read(fd, buf, len buf);
+ if (nb <= 0)
+ return nil;
+ (nil, lines) := sys->tokenize(string buf[0:nb], "\r\n");
+ r: list of list of string;
+ for (; lines != nil; lines = tl lines) {
+ (n, toks) := sys->tokenize(hd lines, " \t");
+ if (n == 0)
+ continue;
+ if (n < 2)
+ sys->fprint(stderr, "cards: invalid config line: %s\n", hd lines);
+ else
+ r = toks :: r;
+ }
+ return r;
+}
+
+fittoscreen(win: ref Tk->Toplevel)
+{
+ Point: import draw;
+ if (win.image == nil || win.image.screen == nil)
+ return;
+ r := win.image.screen.image.r;
+ scrsize := Point((r.max.x - r.min.x), (r.max.y - r.min.y));
+ bd := int cmd(win, ". cget -bd");
+ winsize := Point(int cmd(win, ". cget -actwidth") + bd * 2, int cmd(win, ". cget -actheight") + bd * 2);
+ if (winsize.x > scrsize.x)
+ cmd(win, ". configure -width " + string (scrsize.x - bd * 2));
+ if (winsize.y > scrsize.y)
+ cmd(win, ". configure -height " + string (scrsize.y - bd * 2));
+ actr: Rect;
+ actr.min = Point(int cmd(win, ". cget -actx"), int cmd(win, ". cget -acty"));
+ actr.max = actr.min.add((int cmd(win, ". cget -actwidth") + bd*2,
+ int cmd(win, ". cget -actheight") + bd*2));
+ (dx, dy) := (actr.dx(), actr.dy());
+ if (actr.max.x > r.max.x)
+ (actr.min.x, actr.max.x) = (r.min.x - dx, r.max.x - dx);
+ if (actr.max.y > r.max.y)
+ (actr.min.y, actr.max.y) = (r.min.y - dy, r.max.y - dy);
+ if (actr.min.x < r.min.x)
+ (actr.min.x, actr.max.x) = (r.min.x, r.min.x + dx);
+ if (actr.min.y < r.min.y)
+ (actr.min.y, actr.max.y) = (r.min.y, r.min.y + dy);
+ cmd(win, ". configure -x " + string actr.min.x + " -y " + string actr.min.y);
+}
+
+panic(s: string)
+{
+ sys->fprint(stderr, "cards: panic: %s\n", s);
+ raise "panic";
+}
+
+showtk := 0;
+cmd(top: ref Tk->Toplevel, s: string): string
+{
+ if (showtk)
+ sys->print("tk: %s\n", s);
+ e := tk->cmd(top, s);
+ if (e != nil && e[0] == '!') {
+ sys->fprint(stderr, "tk error %s on '%s'\n", e, s);
+ raise "panic";
+ }
+ return e;
+}
+
+max(a, b: int): int
+{
+ if (a > b)
+ return a;
+ return b;
+}
generated by cgit v1.2.3 (git 2.46.0) at 2025-12-11 09:19:22 +0000