diff options
Diffstat (limited to 'appl/spree')
53 files changed, 16498 insertions, 0 deletions
diff --git a/appl/spree/archives.b b/appl/spree/archives.b new file mode 100644 index 00000000..65249628 --- /dev/null +++ b/appl/spree/archives.b @@ -0,0 +1,515 @@ +implement Archives; +include "sys.m"; + sys: Sys; +include "draw.m"; +include "bufio.m"; + bufio: Bufio; + Iobuf: import bufio; +include "sets.m"; + sets: Sets; + Set, set, A, B, All, None: import sets; +include "string.m"; + str: String; +include "spree.m"; + spree: Spree; + Clique, Member, Attributes, Attribute, Object: import spree; + MAXPLAYERS: import Spree; + +stderr: ref Sys->FD; + +Qc: con " \t{}=\n"; +Saveinfo: adt { + clique: ref Clique; + idmap: array of int; # map clique id to archive id + memberids: Set; # set of member ids to archive +}; + +Error: exception(string); + +Cliqueparse: adt { + iob: ref Iobuf; + line: int; + filename: string; + lasttok: int; + errstr: string; + + gettok: fn(gp: self ref Cliqueparse): (int, string) raises (Error); + lgettok: fn(gp: self ref Cliqueparse, t: int): string raises (Error); + getline: fn(gp: self ref Cliqueparse): list of string raises (Error); + error: fn(gp: self ref Cliqueparse, e: string) raises (Error); +}; + +WORD: con 16rff; + +init(cliquemod: Spree) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + bufio = load Bufio Bufio->PATH; + if (bufio == nil) { + sys->fprint(stderr, "cliquearchive: cannot load %s: %r\n", Bufio->PATH); + raise "fail:bad module"; + } + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->fprint(stderr, "cliquearchive: cannot load %s: %r\n", Sets->PATH); + raise "fail:bad module"; + } + str = load String String->PATH; + if (str == nil) { + sys->fprint(stderr, "cliquearchive: cannot load %s: %r\n", String->PATH); + raise "fail:bad module"; + } + sets->init(); + spree = cliquemod; +} + +write(clique: ref Clique, info: list of (string, string), name: string, memberids: Sets->Set): string +{ + sys->print("saveclique, saving %d objects\n", objcount(clique.objects[0])); + iob := bufio->create(name, Sys->OWRITE, 8r666); + if (iob == nil) + return sys->sprint("cannot open %s: %r", name); + + # integrate suspended members with current members + # for the archive. + + si := ref Saveinfo(clique, array[memberids.limit()] of int, memberids); + members := clique.members(); + pa := array[len members] of (string, int); + for (i := 0; members != nil; members = tl members) { + p := hd members; + if (memberids.holds(p.id)) + pa[i++] = (p.name, p.id); + } + pa = pa[0:i]; + sortmembers(pa); # ensure members stay in the same order when rearchived. + pl: list of string; + for (i = len pa - 1; i >= 0; i--) { + si.idmap[pa[i].t1] = i; + pl = pa[i].t0 :: pl; + } + iob.puts(quotedc("session" :: clique.archive.argv, Qc)); + iob.putc('\n'); + iob.puts(quotedc("members" :: pl, Qc)); + iob.putc('\n'); + il: list of string; + for (; info != nil; info = tl info) + il = (hd info).t0 :: (hd info).t1 :: il; + iob.puts(quotedc("info" :: il, Qc)); + iob.putc('\n'); + writeobject(iob, 0, si, clique.objects[0]); + iob.close(); + return nil; +} + +writeobject(iob: ref Iobuf, depth: int, si: ref Saveinfo, obj: ref Object) +{ + indent(iob, depth); + iob.puts(quotedc(obj.objtype :: nil, Qc)); + iob.putc(' '); + iob.puts(mapset(si, obj.visibility).str()); + writeattrs(iob, si, obj); + if (len obj.children > 0) { + iob.puts(" {\n"); + for (i := 0; i < len obj.children; i++) + writeobject(iob, depth + 1, si, obj.children[i]); + indent(iob, depth); + iob.puts("}\n"); + } else + iob.putc('\n'); +} + +writeattrs(iob: ref Iobuf, si: ref Saveinfo, obj: ref Object) +{ + a := obj.attrs.a; + n := 0; + for (i := 0; i < len a; i++) + n += len a[i]; + attrs := array[n] of ref Attribute; + j := 0; + for (i = 0; i < len a; i++) + for (l := a[i]; l != nil; l = tl l) + attrs[j++] = hd l; + sortattrs(attrs); + for (i = 0; i < len attrs; i++) { + attr := attrs[i]; + if (attr.val == nil) + continue; + iob.putc(' '); + iob.puts(quotedc(attr.name :: nil, Qc)); + vis := mapset(si, attr.visibility); + if (!vis.eq(All)) + iob.puts("{" + vis.str() + "}"); + iob.putc('='); + iob.puts(quotedc(attr.val :: nil, Qc)); + } +} + +mapset(si: ref Saveinfo, s: Set): Set +{ + idmap := si.idmap; + m := s.msb() != 0; + limit := si.memberids.limit(); + r := None; + for (i := 0; i < limit; i++) + if (m == !s.holds(i)) + r = r.add(idmap[i]); + if (m) + r = All.X(A&~B, r); + return r; +} + +readheader(filename: string): (ref Archive, string) +{ + iob := bufio->open(filename, Sys->OREAD); + if (iob == nil) + return (nil, sys->sprint("cannot open '%s': %r", filename)); + gp := ref Cliqueparse(iob, 1, filename, Bufio->EOF, nil); + + { + line := gp.getline(); + if (len line < 2 || hd line != "session") + gp.error("expected 'session' line, got " + str->quoted(line)); + argv := tl line; + line = gp.getline(); + if (line == nil || tl line == nil || hd line != "members") + gp.error("expected 'members' line"); + members := l2a(tl line); + line = gp.getline(); + if (line == nil || hd line != "info") + gp.error("expected 'info' line"); + if (len tl line % 2 != 0) + gp.error("'info' line must have an even number of fields"); + info: list of (string, string); + for (line = tl line; line != nil; line = tl tl line) + info = (hd line, hd tl line) :: info; + arch := ref Archive(argv, members, info, nil); + iob.close(); + return (arch, nil); + } exception e { + Error => + return (nil, x := e); + } +} + +read(filename: string): (ref Archive, string) +{ + iob := bufio->open(filename, Sys->OREAD); + if (iob == nil) + return (nil, sys->sprint("cannot open '%s': %r", filename)); + gp := ref Cliqueparse(iob, 1, filename, Bufio->EOF, nil); + + { + line := gp.getline(); + if (len line < 2 || hd line != "session") + gp.error("expected 'session' line, got " + str->quoted(line)); + argv := tl line; + line = gp.getline(); + if (line == nil || tl line == nil || hd line != "members") + gp.error("expected 'members' line"); + members := l2a(tl line); + line = gp.getline(); + if (line == nil || hd line != "info") + gp.error("expected 'info' line"); + if (len tl line % 2 != 0) + gp.error("'info' line must have an even number of fields"); + info: list of (string, string); + for (line = tl line; line != nil; line = tl tl line) + info = (hd line, hd tl line) :: info; + root := readobject(gp); + if (root == nil) + return (nil, filename + ": no root object found"); + n := objcount(root); + arch := ref Archive(argv, members, info, array[n] of ref Object); + arch.objects[0] = root; + root.parentid = -1; + root.id = 0; + allocobjects(root, arch.objects, 1); + iob.close(); + return (arch, nil); + } exception e { + Error => + return (nil, x := e); + } +} + +allocobjects(parent: ref Object, objects: array of ref Object, n: int): int +{ + base := n; + children := parent.children; + objects[n:] = children; + n += len children; + for (i := 0; i < len children; i++) { + child := children[i]; + (child.id, child.parentid) = (base + i, parent.id); + n = allocobjects(child, objects, n); + } + return n; +} + +objcount(o: ref Object): int +{ + n := 1; + a := o.children; + for (i := 0; i < len a; i++) + n += objcount(a[i]); + return n; +} + +readobject(gp: ref Cliqueparse): ref Object raises (Error) +{ + { + # object format: + # objtype visibility [attr[{vis}]=val]... [{\nchildren\n}]\n + (t, s) := gp.gettok(); #{ + if (t == Bufio->EOF || t == '}') + return nil; + if (t != WORD) + gp.error("expected WORD"); + objtype := s; + vis := sets->str2set(gp.lgettok(WORD)); + attrs := Attributes.new(); + objs: array of ref Object; + loop: for (;;) { + (t, s) = gp.gettok(); + case t { + WORD => + attr := s; + attrvis := All; + (t, s) = gp.gettok(); + if (t == '{') { #} + attrvis = sets->str2set(gp.lgettok(WORD)); #{ + gp.lgettok('}'); + gp.lgettok('='); + } else if (t != '=') + gp.error("expected '='"); + val := gp.lgettok(WORD); + attrs.set(attr, val, attrvis); + '{' => #} + gp.lgettok('\n'); + objl: list of ref Object; + while ((obj := readobject(gp)) != nil) + objl = obj :: objl; + n := len objl; + objs = array[n] of ref Object; + for (n--; n >= 0; n--) + (objs[n], objl) = (hd objl, tl objl); + gp.lgettok('\n'); + break loop; + '\n' => + break loop; + * => + gp.error("expected WORD or '{'"); #} + } + } + return ref Object(-1, attrs, vis, -1, objs, -1, objtype); + } exception e {Error => raise e;} +} + +Cliqueparse.error(gp: self ref Cliqueparse, e: string) raises (Error) +{ + raise Error(sys->sprint("%s:%d: parse error after %s: %s", gp.filename, gp.line, + tok2str(gp.lasttok), e)); +} + +Cliqueparse.getline(gp: self ref Cliqueparse): list of string raises (Error) +{ + { + line, nline: list of string; + for (;;) { + (t, s) := gp.gettok(); + if (t == '\n') + break; + if (t != WORD) + gp.error("expected a WORD"); + line = s :: line; + } + for (; line != nil; line = tl line) + nline = hd line :: nline; + return nline; + } exception e {Error => raise e;} +} + +# get a token, which must be of type t. +Cliqueparse.lgettok(gp: self ref Cliqueparse, mustbe: int): string raises (Error) +{ + { + (t, s) := gp.gettok(); + if (t != mustbe) + gp.error("lgettok expected " + tok2str(mustbe)); + return s; + } exception e {Error => raise e;} + +} + +Cliqueparse.gettok(gp: self ref Cliqueparse): (int, string) raises (Error) +{ + { + iob := gp.iob; + while ((c := iob.getc()) == ' ' || c == '\t') + ; + t: int; + s: string; + case c { + Bufio->EOF or + Bufio->ERROR => + t = Bufio->EOF; + '\n' => + gp.line++; + t = '\n'; + '{' => + t = '{'; + '}' => + t = '}'; + '=' => + t = '='; + '\'' => + for(;;) { + while ((nc := iob.getc()) != '\'' && nc >= 0) { + s[len s] = nc; + if (nc == '\n') + gp.line++; + } + if (nc == Bufio->EOF || nc == Bufio->ERROR) + gp.error("unterminated quote"); + if (iob.getc() != '\'') { + iob.ungetc(); + break; + } + s[len s] = '\''; # 'xxx''yyy' becomes WORD(xxx'yyy) + } + t = WORD; + * => + do { + s[len s] = c; + c = iob.getc(); + if (in(c, Qc)) { + iob.ungetc(); + break; + } + } while (c >= 0); + t = WORD; + } + gp.lasttok = t; + return (t, s); + } exception e {Error => raise e;} +} + +tok2str(t: int): string +{ + case t { + Bufio->EOF => + return "EOF"; + WORD => + return "WORD"; + '\n' => + return "'\\n'"; + * => + return sys->sprint("'%c'", t); + } +} + +# stolen from lib/string.b - should be part of interface in string.m +quotedc(argv: list of string, cl: string): string +{ + s := ""; + while (argv != nil) { + arg := hd argv; + for (i := 0; i < len arg; i++) { + c := arg[i]; + if (c == ' ' || c == '\t' || c == '\n' || c == '\'' || in(c, cl)) + break; + } + if (i < len arg || arg == nil) { + s += "'" + arg[0:i]; + for (; i < len arg; i++) { + if (arg[i] == '\'') + s[len s] = '\''; + s[len s] = arg[i]; + } + s[len s] = '\''; + } else + s += arg; + if (tl argv != nil) + s[len s] = ' '; + argv = tl argv; + } + return s; +} + +in(c: int, cl: string): int +{ + n := len cl; + for (i := 0; i < n; i++) + if (cl[i] == c) + return 1; + return 0; +} + +indent(iob: ref Iobuf, depth: int) +{ + for (i := 0; i < depth; i++) + iob.putc('\t'); +} + +sortmembers(p: array of (string, int)) +{ + membermergesort(p, array[len p] of (string, int)); +} + +membermergesort(a, b: array of (string, int)) +{ + r := len a; + if (r > 1) { + m := (r-1)/2 + 1; + membermergesort(a[0:m], b[0:m]); + membermergesort(a[m:], b[m:]); + b[0:] = a; + for ((i, j, k) := (0, m, 0); i < m && j < r; k++) { + if (b[i].t1 > b[j].t1) + 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]; + } +} + +sortattrs(a: array of ref Attribute) +{ + attrmergesort(a, array[len a] of ref Attribute); +} + +attrmergesort(a, b: array of ref Attribute) +{ + r := len a; + if (r > 1) { + m := (r-1)/2 + 1; + attrmergesort(a[0:m], b[0:m]); + attrmergesort(a[m:], b[m:]); + b[0:] = a; + for ((i, j, k) := (0, m, 0); i < m && j < r; k++) { + if (b[i].name > b[j].name) + 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]; + } +} + +l2a(l: list of string): array of string +{ + n := len l; + a := array[n] of string; + for (i := 0; i < n; i++) + (a[i], l) = (hd l, tl l); + return a; +}
\ No newline at end of file diff --git a/appl/spree/clients/bounce.b b/appl/spree/clients/bounce.b new file mode 100644 index 00000000..f1960582 --- /dev/null +++ b/appl/spree/clients/bounce.b @@ -0,0 +1,958 @@ +implement Clientmod; + +# bouncing balls demo. it uses tk and multiple processes to animate a +# number of balls bouncing around the screen. each ball has its own +# process; CPU time is doled out fairly to each process by using +# a central monitor loop. + +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Display, Point, Rect, Image: import draw; +include "tk.m"; + tk: Tk; +include "tkclient.m"; + tkclient: Tkclient; +include "math.m"; + math: Math; +include "rand.m"; +include "../client.m"; + +BALLSIZE: con 5; +ZERO: con 1e-6; +π: con Math->Pi; +Maxδ: con π / 4.0; # max bat angle deflection + +Line: adt { + p, v: Realpoint; + s: real; + new: fn(p1, p2: Point): ref Line; + hittest: fn(l: self ref Line, p: Point): (Realpoint, real, real); + intersection: fn(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real); + point: fn(b: self ref Line, s: real): Point; +}; + +Realpoint: adt { + x, y: real; +}; + +cliquecmds := array[] of { +"canvas .c -bg black", +"bind .c <ButtonRelease-1> {send mouse 0 1 %x %y}", +"bind .c <ButtonRelease-2> {send mouse 0 2 %x %y}", +"bind .c <Button-1> {send mouse 1 1 %x %y}", +"bind .c <Button-2> {send mouse 1 2 %x %y}", +"bind . <Key-b> {send ucmd newball}", +"bind . <ButtonRelease-1> {focus .}", +"bind .Wm_t <ButtonRelease-1> +{focus .}", +"focus .", +"bind .c <Key-b> {send ucmd newball}", +"bind .c <Key-u> {grab release .c}", +"frame .f", +"button .f.b -text {Start} -command {send ucmd start}", +"button .f.n -text {New ball} -command {send ucmd newball}", +"pack .f.b .f.n -side left", +"pack .f -fill x", +"pack .c -fill both -expand 1", +"update", +}; + +Ballstate: adt { + owner: int; # index into member array + hitobs: ref Obstacle; + t0: int; + p, v: Realpoint; + speed: real; +}; + +Queue: adt { + h, t: list of T; + put: fn(q: self ref Queue, s: T); + get: fn(q: self ref Queue): T; +}; + + +Obstacle: adt { + line: ref Line; + id: int; + isbat: int; + s1, s2: real; + srvid: int; + owner: int; + new: fn(id: int): ref Obstacle; + config: fn(b: self ref Obstacle); +}; + +Object: adt { + obstacle: ref Obstacle; + ballctl: chan of ref Ballstate; +}; + + +Member: adt { + id: int; + colour: string; +}; + +win: ref Tk->Toplevel; + +lines: list of ref Obstacle; +lineversion := 0; +memberid: int; +myturn: int; +stderr: ref Sys->FD; +timeoffset := 0; + +objects: array of ref Object; +srvobjects: array of ref Obstacle; # all for lasthit... +members: array of ref Member; + +CORNER: con 60; +INSET: con 20; +WIDTH: con 500; +HEIGHT: con 500; + +bats: list of ref Obstacle; +mkball: chan of (int, chan of chan of ref Ballstate); +cliquefd: ref Sys->FD; +currentlydragging := -1; +Ballexit: ref Ballstate; +Noobs: ref Obstacle; + +nomod(s: string) +{ + sys->fprint(stderr, "bounce: cannot load %s: %r\n", s); + sys->raise("fail:bad module"); +} + +client(ctxt: ref Draw->Context, argv: list of string, nil: int) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + draw = load Draw Draw->PATH; + math = load Math Math->PATH; + tk = load Tk Tk->PATH; + tkclient = load Tkclient Tkclient->PATH; + if (tkclient == nil) + nomod(Tkclient->PATH); + tkclient->init(); + cliquefd = sys->fildes(0); + Ballexit = ref Ballstate; + Noobs = Obstacle.new(-1); + lines = tl lines; # XXX ahem. + + if (len argv >= 3) # argv: modname mnt dir ... + membername = readfile(hd tl argv + "/name"); + + sys->pctl(Sys->NEWPGRP, nil); + wmctl: chan of string; + (win, wmctl) = tkclient->toplevel(ctxt.screen, nil, "Bounce", 0); + ucmd := chan of string; + tk->namechan(win, ucmd, "ucmd"); + mouse := chan of string; + tk->namechan(win, mouse, "mouse"); + for (i := 0; i < len cliquecmds; i++) + cmd(win, cliquecmds[i]); + cmd(win, ".c configure -width 500 -height 500"); + cmd(win, ".c configure -width [.c cget -actwidth] -height [.c cget -actheight]"); + imageinit(); + + mch := chan of (int, Point); + + spawn mouseproc(mch); + mkball = chan of (int, chan of chan of ref Ballstate); + spawn monitor(mkball); + balls: list of chan of ref Ballstate; + + spawn updateproc(); + sys->sleep(500); # wait for things to calm down a little + cliquecmd("time " + string sys->millisec()); + + buts := 0; + for (;;) alt { + c := <-wmctl => + if (c == "exit") + sys->write(cliquefd, array[0] of byte, 0); + tkclient->wmctl(win, c); + c := <-mouse => + (nil, toks) := sys->tokenize(c, " "); + if ((hd toks)[0] == '1') + buts |= int hd tl toks; + else + buts &= ~int hd tl toks; + mch <-= (buts, Point(int hd tl tl toks, int hd tl tl tl toks)); + c := <-ucmd => + cliquecmd(c); + } +} + +cliquecmd(s: string): int +{ + if (sys->fprint(cliquefd, "%s\n", s) == -1) { + err := sys->sprint("%r"); + notify(err); + sys->print("bounce: cmd error on '%s': %s\n", s, err); + return 0; + } + return 1; +} + +updateproc() +{ + wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD); + spawn updateproc1(); + 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() +{ + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(cliquefd, buf, len buf)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) + applyupdate(hd lines); + cmd(win, "update"); + } + if (n < 0) + sys->fprint(stderr, "bounce: error reading updates: %r\n"); + sys->fprint(stderr, "bounce: updateproc exiting\n"); +} + +UNKNOWN, BALL, OBSTACLE: con iota; + +applyupdate(s: string) +{ +# sys->print("bounce: got update %s\n", s); + (nt, toks) := sys->tokenize(s, " "); + case hd toks { + "create" => + # create id parentid vis type + id := int hd tl toks; + if (id >= len objects) { + newobjects := array[id + 10] of ref Object; + newobjects[0:] = objects; + objects = newobjects; + } + objects[id] = ref Object; + "del" => + # del parent start end objid... + for (toks = tl tl tl tl toks; toks != nil; toks = tl toks) { + id := int hd toks; + if (objects[id].obstacle != nil) + sys->fprint(stderr, "bounce: cannot delete obstructions yet\n"); + else + objects[id].ballctl <-= Ballexit; + objects[id] = nil; + } + "set" => + # set obj attr val + id := int hd tl toks; + attr := hd tl tl toks; + val := tl tl tl toks; + case attr { + "state" => + # state lasthit owner p.x p.y v.x v.y s time + state := ref Ballstate; + (state.hitobs, val) = (srvobj(int hd val), tl val); + (state.owner, val) = (int hd val, tl val); + (state.p.x, val) = (real hd val, tl val); + (state.p.y, val) = (real hd val, tl val); + (state.v.x, val) = (real hd val, tl val); + (state.v.y, val) = (real hd val, tl val); + (state.speed, val) = (real hd val, tl val); + (state.t0, val) = (int hd val, tl val); + if (objects[id].ballctl == nil) + objects[id].ballctl = makeball(id, state); + else + objects[id].ballctl <-= state; + "pos" or "coords" or "owner" or "id" => + if (objects[id].obstacle == nil) + objects[id].obstacle = Obstacle.new(id); + o := objects[id].obstacle; + case attr { + "pos" => + (o.s1, val) = (real hd val, tl val); + (o.s2, val) = (real hd val, tl val); + o.isbat = 1; + "coords" => + p1, p2: Point; + (p1.x, val) = (int hd val, tl val); + (p1.y, val) = (int hd val, tl val); + (p2.x, val) = (int hd val, tl val); + (p2.y, val) = (int hd val, tl val); + o.line = Line.new(p1, p2); + "owner" => + o.owner = hd val; + if (o.owner == membername) + bats = o :: bats; + "id" => + o.srvid = int hd val; + if (o.srvid >= len srvobjects) { + newobjects := array[id + 10] of ref Obstacle; + newobjects[0:] = srvobjects; + srvobjects = newobjects; + } + srvobjects[o.srvid] = o; + } + if (currentlydragging != id) + o.config(); + "arenasize" => + # arenasize w h + cmd(win, ".c configure -width " + hd val + " -height " + hd tl val); + * => + if (len attr > 5 && attr[0:5] == "score") { + # scoreN val + n := int attr[5:]; + w := ".f." + string n; + if (!tkexists(w)) { + cmd(win, "label " + w + "l -text '" + attr); + cmd(win, "label " + w + " -relief sunken -bd 5 -width 5w"); + cmd(win, "pack " +w + "l " + w + " -side left"); + } + cmd(win, w + " configure -text {" + hd val + "}"); + } else if (len attr > 6 && attr[0:6] == "member") { + # memberN id colour + n := int attr[6:]; + if (n >= len members) { + newmembers := array[n + 1] of ref Member; + newmembers[0:] = members; + members = newmembers; + } + p := members[n] = ref Member(int hd val, hd tl val); + cmd(win, ".c itemconfigure o" + string p.id + " -fill " + p.colour); + if (p.id == memberid) + myturn = n; + } + else + sys->fprint(stderr, "bounce: unknown attr '%s'\n", attr); + } + "time" => + # time offset orig + now := sys->millisec(); + time := int hd tl tl toks; + transit := now - time; + timeoffset = int hd tl toks - transit / 2; + sys->print("transit time %d, timeoffset: %d\n", transit, timeoffset); + * => + sys->fprint(stderr, "chat: unknown update message '%s'\n", s); + } +} + +tkexists(w: string): int +{ + return tk->cmd(win, w + " cget -bd")[0] != '!'; +} + +srvobj(id: int): ref Obstacle +{ + if (id < 0 || id >= len srvobjects || srvobjects[id] == nil) + return Noobs; + return srvobjects[id]; +} + +mouseproc(mch: chan of (int, Point)) +{ + procname("mouse"); + for (;;) { + hitbat: ref Obstacle = nil; + minperp, hitdist: real; + (buts, p) := <-mch; + for (bl := bats; bl != nil; bl = tl bl) { + b := hd bl; + (normal, perp, dist) := b.line.hittest(p); + perp = abs(perp); + + if ((hitbat == nil || perp < minperp) && (dist >= b.s1 && dist <= b.s2)) + (hitbat, minperp, hitdist) = (b, perp, dist); + } + if (hitbat == nil || minperp > 30.0) { + while ((<-mch).t0) + ; + continue; + } + offset := hitdist - hitbat.s1; + if (buts & 2) + (buts, p) = aim(mch, hitbat, p); + if (buts & 1) + drag(mch, hitbat, offset); + } +} + + +drag(mch: chan of (int, Point), hitbat: ref Obstacle, offset: real) +{ + realtosrv := chan of string; + dummytosrv := chan of string; + tosrv := dummytosrv; + currevent := ""; + + currentlydragging = hitbat.id; + + line := hitbat.line; + batlen := hitbat.s2 - hitbat.s1; + + cvsorigin := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty")); + spawn sendproc(realtosrv); + + cmd(win, "grab set .c"); + cmd(win, "focus ."); +loop: for (;;) alt { + tosrv <-= currevent => + tosrv = dummytosrv; + + (buts, p) := <-mch => + if (buts & 2) + (buts, p) = aim(mch, hitbat, p); + (v, perp, dist) := line.hittest(p); + dist -= offset; + # constrain bat and mouse positions + if (dist < 0.0 || dist + batlen > line.s) { + if (dist < 0.0) { + p = line.point(offset); + dist = 1.0; + } else { + p = line.point(line.s - batlen + offset); + dist = line.s - batlen; + } + p.x -= int (v.x * perp); + p.y -= int (v.y * perp); + win.image.display.cursorset(p.add(cvsorigin)); + } + (hitbat.s1, hitbat.s2) = (dist, dist + batlen); + hitbat.config(); + cmd(win, "update"); + currevent = "bat " + string hitbat.s1; + tosrv = realtosrv; + if (!buts) + break loop; + } + cmd(win, "grab release .c"); + realtosrv <-= nil; + currentlydragging = -1; +} + +CHARGETIME: con 1000.0; +MAXCHARGE: con 50.0; + +α: con 0.999; # decay in one millisecond +D: con 5; +aim(mch: chan of (int, Point), hitbat: ref Obstacle, p: Point): (int, Point) +{ + cvsorigin := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty")); + startms := ms := sys->millisec(); + δ := Realpoint(0.0, 0.0); + line := hitbat.line; + charge := 0.0; + pivot := line.point((hitbat.s1 + hitbat.s2) / 2.0); + s1 := p2s(line.point(hitbat.s1)); + s2 := p2s(line.point(hitbat.s2)); + cmd(win, ".c create line 0 0 0 0 -tags wire -fill yellow"); + ballid := makeballitem(-1, myturn); + bp, p2: Point; + buts := 2; + for (;;) { + v := makeunit(δ); + bp = pivot.add((int (v.x * charge), int (v.y * charge))); + cmd(win, ".c coords wire "+s1+" "+p2s(bp)+" "+s2); + ballmove(ballid, bp); + cmd(win, "update"); + if ((buts & 2) == 0) + break; + (buts, p2) = <-mch; + now := sys->millisec(); + fade := math->pow(α, real (now - ms)); + charge = real (now - startms) * (MAXCHARGE / CHARGETIME); + if (charge > MAXCHARGE) + charge = MAXCHARGE; + ms = now; + dp := p2.sub(p); + δ.x = δ.x * fade + real dp.x; + δ.y = δ.y * fade + real dp.y; + mag := δ.x * δ.x + δ.y * δ.y; + if (dp.x != 0 || dp.y != 0) + win.image.display.cursorset(p.add(cvsorigin)); + } + cmd(win, ".c delete wire " + ballid); + cmd(win, "update"); + (δ.x, δ.y) = (-δ.x, -δ.y); + cliquecmd("newball " + string hitbat.id + " " + + p2s(bp) + " " + rp2s(makeunit(δ)) + " " + string (charge / 100.0)); + return (buts, p2); +} + +makeunit(v: Realpoint): Realpoint +{ + mag := math->sqrt(v.x * v.x + v.y * v.y); + if (mag < ZERO) + return (1.0, 0.0); + return (v.x / mag, v.y / mag); +} + +sendproc(tosrv: chan of string) +{ + procname("send"); + while ((ev := <-tosrv) != nil) + cliquecmd(ev); +} + +makeball(id: int, state: ref Ballstate): chan of ref Ballstate +{ + mkballreply := chan of chan of ref Ballstate; + mkball <-= (id, mkballreply); + ballctl := <-mkballreply; + ballctl <-= state; + return ballctl; +} + +blankobstacle: Obstacle; +Obstacle.new(id: int): ref Obstacle +{ + cmd(win, ".c create line 0 0 0 0 -width 3 -fill #aaaaaa" + " -tags l" + string id); + o := ref blankobstacle; + o.line = Line.new((0, 0), (0, 0)); + o.id = id; + o.owner = -1; + o.srvid = -1; + lineversion++; + lines = o :: lines; + return o; +} + +Obstacle.config(o: self ref Obstacle) +{ + if (o.isbat) { + cmd(win, ".c coords l" + string o.id + " " + + p2s(o.line.point(o.s1)) + " " + p2s(o.line.point(o.s2))); + if (o.owner == memberid) + cmd(win, ".c itemconfigure l" + string o.id + " -fill red"); + else + cmd(win, ".c itemconfigure l" + string o.id + " -fill white"); + } else { + cmd(win, ".c coords l" + string o.id + " " + + p2s(o.line.point(0.0)) + " " + p2s(o.line.point(o.line.s))); + } +} + +# make sure cpu time is handed to all ball processes fairly +# by passing a "token" around to each process in turn. +# each process does its work when it *hasn't* got its +# token but it can't go through two iterations without +# waiting its turn. +# +# new processes are created by sending on mkball. +# the channel sent back can be used to control the position +# and velocity of the ball and to destroy it. +monitor(mkball: chan of (int, chan of chan of ref Ballstate)) +{ + procname("mon"); + procl, proc: list of (chan of ref Ballstate, chan of int); + rc := dummyrc := chan of int; + for (;;) { + alt { + (id, ch) := <-mkball => + (newc, newrc) := (chan of ref Ballstate, chan of int); + procl = (newc, newrc) :: procl; + spawn animproc(id, newc, newrc); + ch <-= newc; + if (tl procl == nil) { # first ball + newc <-= nil; + rc = newrc; + proc = procl; + } + alive := <-rc => # got token. + if (!alive) { + # ball has exited: remove from list + newprocl: list of (chan of ref Ballstate, chan of int); + for (; procl != nil; procl = tl procl) + if ((hd procl).t1 != rc) + newprocl = hd procl :: newprocl; + procl = newprocl; + } + if ((proc = tl proc) == nil) + proc = procl; + if (proc == nil) { + rc = dummyrc; + } else { + c: chan of ref Ballstate; + (c, rc) = hd proc; + c <-= nil; # hand token to next process. + } + } + } +} + +# buffer ball state commands, so at least balls we handle +# locally appear glitch free. +bufferproc(cmdch: chan of string) +{ + procname("buffer"); + buffer := ref Queue; + bufhd: string; + dummytosrv := chan of string; + realtosrv := chan of string; + spawn sendproc(realtosrv); + tosrv := dummytosrv; + for (;;) alt { + tosrv <-= bufhd => + if ((bufhd = buffer.get()) == nil) + tosrv = dummytosrv; + s := <-cmdch => + if (s == nil) { + # ignore other queued requests, as they're + # only state changes for a ball that's now been deleted. + realtosrv <-= nil; + exit; + } + buffer.put(s); + if (tosrv == dummytosrv) { + tosrv = realtosrv; + bufhd = buffer.get(); + } + } +} +start: int; +# animate one ball. initial position and unit-velocity are +# given by p and v. +animproc(id: int, c: chan of ref Ballstate, rc: chan of int) +{ + procname("anim"); + while ((newstate := <-c) == nil) + rc <-= 1; + state := *newstate; + totaldist := 0.0; # distance ball has travelled from reference point to last intersection + ballid := makeballitem(id, state.owner); + smallcount := 0; + version := lineversion; + tosrv := chan of string; + start := sys->millisec(); + spawn bufferproc(tosrv); +loop: for (;;) { + hitp: Realpoint; + + dist := 1000000.0; + oldobs := state.hitobs; + hitt: real; + for (l := lines; l != nil; l = tl l) { + obs := hd l; + (ok, hp, hdist, t) := obs.line.intersection(state.p, state.v); + if (ok && hdist < dist && obs != oldobs && (smallcount < 10 || hdist > 1.5)) { + (hitp, state.hitobs, dist, hitt) = (hp, obs, hdist, t); + } + } + if (dist > 10000.0) { + sys->print("no intersection!\n"); + state = ballexit(1, ballid, tosrv, c, rc); + totaldist = 0.0; + continue loop; + } + if (dist < 0.0001) + smallcount++; + else + smallcount = 0; + t0 := int (totaldist / state.speed) + state.t0 - timeoffset; + et := t0 + int (dist / state.speed); + t := sys->millisec() - t0; + dt := et - t0; + do { + s := real t * state.speed; + currp := Realpoint(state.p.x + s * state.v.x, state.p.y + s * state.v.y); + ballmove(ballid, (int currp.x, int currp.y)); + cmd(win, "update"); + if (lineversion > version) { + (state.p, state.hitobs, version) = (currp, oldobs, lineversion); + totaldist += s; + continue loop; + } + if ((newstate := <-c) != nil) { + if (newstate == Ballexit) + ballexit(0, ballid, tosrv, c, rc); + state = *newstate; + totaldist = 0.0; + continue loop; + } + rc <-= 1; + t = sys->millisec() - t0; + } while (t < dt); + totaldist += dist; + state.p = hitp; + hitobs := state.hitobs; + if (hitobs.isbat) { + if (hitobs.owner == memberid) { + if (hitt >= hitobs.s1 && hitt <= hitobs.s2) + state.v = batboing(hitobs, hitt, state.v); + tosrv <-= "state " + + string id + + " " + string hitobs.srvid + + " " + string state.owner + + " " + rp2s(state.p) + " " + rp2s(state.v) + + " " + string state.speed + + " " + string (sys->millisec() + timeoffset); + } else { + # wait for enlightenment + while ((newstate := <-c) == nil) + rc <-= 1; + if (newstate == Ballexit) + ballexit(0, ballid, tosrv, c, rc); + state = *newstate; + totaldist = 0.0; + } + } else if (hitobs.owner == memberid) { + # if line has an owner but isn't a bat, then it's + # a terminating line, so we inform server. + cliquecmd("lost " + string id); + state = ballexit(1, ballid, tosrv, c, rc); + totaldist = 0.0; + } else + state.v = boing(state.v, hitobs.line); + } +} + +#ballmask: ref Image; +imageinit() +{ +# displ := win.image.display; +# ballmask = displ.newimage(((0, 0), (BALLSIZE+1, BALLSIZE+1)), 0, 0, Draw->White); +# ballmask.draw(ballmask.r, displ.zeros, displ.ones, (0, 0)); +# ballmask.fillellipse((BALLSIZE/2, BALLSIZE/2), BALLSIZE/2, BALLSIZE/2, displ.ones, (0, 0)); +# End: con Draw->Endsquare; +# n := 5; +# θ := 0.0; +# δ := (2.0 * π) / real n; +# c := Point(BALLSIZE / 2, BALLSIZE / 2).sub((1, 1)); +# r := real (BALLSIZE / 2); +# for (i := 0; i < n; i++) { +# p2 := Point(int (r * math->cos(θ)), int (r * math->sin(θ))); +# sys->print("drawing from %s to %s\n", p2s(c), p2s(p2.add(c))); +# ballmask.line(c, c.add(p2), End, End, 1, displ.ones, (0, 0)); +# θ += δ; +# } +} + +makeballitem(id, owner: int): string +{ + displ := win.image.display; + return cmd(win, ".c create oval 0 0 1 1 -fill " + members[owner].colour + + " -tags o" + string owner); +} + +ballmove(ballid: string, p: Point) +{ + cmd(win, ".c coords " + ballid + + " " + string (p.x - BALLSIZE) + + " " + string (p.y - BALLSIZE) + + " " + string (p.x + BALLSIZE) + + " " + string (p.y + BALLSIZE)); +} + +ballexit(wait: int, ballid: string, tosrv: chan of string, c: chan of ref Ballstate, rc: chan of int): Ballstate +{ + if (wait) { + while ((s := <-c) != Ballexit) + if (s == nil) + rc <-= 1; + else + return *s; # maybe we're not exiting, after all... + } + cmd(win, ".c delete " + ballid + ";update"); +# cmd(win, "image delete " + ballid); + tosrv <-= nil; + <-c; + rc <-= 0; # inform monitor that we've gone + exit; +} + +# thread-safe access to the Rand module +randgenproc(ch: chan of int) +{ + procname("rand"); + rand := load Rand Rand->PATH; + for (;;) + ch <-= rand->rand(16r7fffffff); +} + +abs(x: real): real +{ + if (x < 0.0) + return -x; + return x; +} + +# bounce ball travelling in direction av off line b. +# return the new unit vector. +boing(av: Realpoint, b: ref Line): Realpoint +{ + d := math->atan2(b.v.y, b.v.x) * 2.0 - math->atan2(av.y, av.x); + return (math->cos(d), math->sin(d)); +} + +# calculate how a bounce vector should be modified when +# hitting a bat. t gives the intersection point on the bat; +# ballv is the ball's vector. +batboing(bat: ref Obstacle, t: real, ballv: Realpoint): Realpoint +{ + ballθ := math->atan2(ballv.y, ballv.x); + batθ := math->atan2(bat.line.v.y, bat.line.v.x); + φ := ballθ - batθ; + δ: real; + t -= bat.s1; + batlen := bat.s2 - bat.s1; + if (math->sin(φ) > 0.0) + δ = (t / batlen) * Maxδ * 2.0 - Maxδ; + else + δ = (t / batlen) * -Maxδ * 2.0 + Maxδ; + θ := math->atan2(bat.line.v.y, bat.line.v.x) * 2.0 - ballθ; # boing + θ += δ; + return (math->cos(θ), math->sin(θ)); +} + +Line.new(p1, p2: Point): ref Line +{ + ln := ref Line; + ln.p = (real p1.x, real p1.y); + v := Realpoint(real (p2.x - p1.x), real (p2.y - p1.y)); + ln.s = math->sqrt(v.x * v.x + v.y * v.y); + if (ln.s > ZERO) + ln.v = (v.x / ln.s, v.y / ln.s); + else + ln.v = (1.0, 0.0); + return ln; +} + +# return normal from line, perpendicular distance from line and distance down line +Line.hittest(l: self ref Line, ip: Point): (Realpoint, real, real) +{ + p := Realpoint(real ip.x, real ip.y); + v := Realpoint(-l.v.y, l.v.x); + (nil, nil, perp, ldist) := l.intersection(p, v); + return (v, perp, ldist); +} + +Line.point(l: self ref Line, s: real): Point +{ + return (int (l.p.x + s * l.v.x), int (l.p.y + s * l.v.y)); +} + +# compute the intersection of lines a and b. +# b is assumed to be fixed, and a is indefinitely long +# but doesn't extend backwards from its starting point. +# a is defined by the starting point p and the unit vector v. +# return whether it hit, the point at which it hit if so, +# the distance of the intersection point from p, +# and the distance of the intersection point from b.p. +Line.intersection(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real) +{ + det := b.v.x * v.y - v.x * b.v.y; + if (det > -ZERO && det < ZERO) + return (0, (0.0, 0.0), 0.0, 0.0); + + y21 := b.p.y - p.y; + x21 := b.p.x - p.x; + s := (b.v.x * y21 - b.v.y * x21) / det; + t := (v.x * y21 - v.y * x21) / det; + if (s < 0.0) + return (0, (0.0, 0.0), s, t); + hit := t >= 0.0 && t <= b.s; + hp: Realpoint; + if (hit) + hp = (p.x+v.x*s, p.y+v.y*s); + return (hit, hp, s, t); +} + +cmd(top: ref Tk->Toplevel, s: string): string +{ + e := tk->cmd(top, s); + if (e != nil && e[0] == '!') + sys->print("tk error %s on '%s'\n", e, s); + return e; +} + +state2s(s: ref Ballstate): string +{ + return sys->sprint("[hitobs:%d(id %d), t0: %d, p: %g %g; v: %g %g; s: %g", + s.hitobs.srvid, s.hitobs.id, s.t0, s.p.x, s.p.y, s.v.x, s.v.y, s.speed); +} + +l2s(l: ref Line): string +{ + return p2s(l.point(0.0)) + " " + p2s(l.point(l.s)); +} + +rp2s(rp: Realpoint): string +{ + return string rp.x + " " + string rp.y; +} + + +p2s(p: Point): string +{ + return string p.x + " " + string p.y; +} + +notifypid := -1; +notify(s: string) +{ + kill(notifypid); + sync := chan of int; + spawn notifyproc(s, sync); + notifypid = <-sync; +} + +notifyproc(s: string, sync: chan of int) +{ + procname("notify"); + sync <-= sys->pctl(0, nil); + cmd(win, ".c delete notify"); + id := cmd(win, ".c create text 0 0 -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(750); + cmd(win, ".c delete notify"); + cmd(win, "update"); + notifypid = -1; +} + +kill(pid: int) +{ + if ((fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE)) != nil) + sys->write(fd, array of byte "kill", 4); +} + +T: type string; + +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; +} + +revlist(ls: list of T) : list of T +{ + rs: list of T; + for (; ls != nil; ls = tl ls) + rs = hd ls :: rs; + return rs; +} + +procname(s: string) +{ +# sys->procname(sys->procname(nil) + " " + s); +} + 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; +} diff --git a/appl/spree/clients/chat.b b/appl/spree/clients/chat.b new file mode 100644 index 00000000..d474ef8f --- /dev/null +++ b/appl/spree/clients/chat.b @@ -0,0 +1,194 @@ +implement Clientmod; +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Point, Rect, Display, Image: import draw; +include "tk.m"; + tk: Tk; +include "tkclient.m"; + tkclient: Tkclient; +include "../client.m"; +include "commandline.m"; + commandline: Commandline; + Cmdline: import commandline; + +stderr: ref Sys->FD; + +memberid := -1; +win: ref Tk->Toplevel; + +client(ctxt: ref Draw->Context, argv: list of string, nil: int) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + draw = load Draw Draw->PATH; + tk = load Tk Tk->PATH; + tkclient = load Tkclient Tkclient->PATH; + if (tkclient == nil) { + sys->fprint(stderr, "chat: cannot load %s: %r\n", Tkclient->PATH); + sys->raise("fail:bad module"); + } + commandline = load Commandline Commandline->PATH; + if (commandline == nil) { + sys->fprint(stderr, "chat: cannot load %s: %r\n", Commandline->PATH); + sys->raise("fail:bad module"); + } + commandline->init(); + + tkclient->init(); + client1(ctxt); +} +cmdlinech: chan of string; +cmdline: ref Cmdline; + +client1(ctxt: ref Draw->Context) +{ + cliquefd := sys->fildes(0); + + sys->pctl(Sys->NEWPGRP, nil); + + winctl: chan of string; + (win, winctl) = tkclient->toplevel(ctxt.screen, nil, + "Cards", Tkclient->Appl); + cmdlinech = chan of string; + + srvcmd := chan of string; + spawn updateproc(cliquefd, srvcmd); + + for (;;) alt { + c := <-cmdlinech => + for (cmds := cmdline.event(c); cmds != nil; cmds = tl cmds) + cliquecmd(cliquefd, "say " + quote(hd cmds)); + c := <-srvcmd => + applyupdate(c); + cmd(win, "update"); + c := <-winctl => + if (c == "exit") + sys->write(cliquefd, array[0] of byte, 0); + tkclient->wmctl(win, c); + } +} + +quote(s: string): string +{ + for (i := 0; i < len s; i++) + if (s[i] == ' ') + s[i] = '_'; + return s; +} + +unquote(s: string): string +{ + for (i := 0; i < len s; i++) + if (s[i] == '_') + s[i] = ' '; + return s; +} + +cliquecmd(fd: ref Sys->FD, s: string): int +{ + if (sys->fprint(fd, "%s\n", s) == -1) { + sys->print("chat: cmd error on '%s': %r\n", s); + return 0; + } + return 1; +} + + +updateproc(fd: ref Sys->FD, srvcmd: chan of string) +{ + wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD); + spawn updateproc1(fd, srvcmd); + 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(fd: ref Sys->FD, srvcmd: chan of string) +{ + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(fd, buf, len buf)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) + srvcmd <-= hd lines; + } + if (n < 0) + sys->fprint(stderr, "chat: error reading updates: %r\n"); + sys->fprint(stderr, "chat: updateproc exiting\n"); +} + + +applyupdate(s: string) +{ + (nt, toks) := sys->tokenize(s, " "); + case hd toks { + "memberid" => + # memberid clientid memberid name + memberid = int hd tl tl toks; + cmd(win, "frame .me"); + cmd(win, "label .me.l -text {Type here}"); + (cmdline, cmdlinech) = Cmdline.new(win, ".me.f", nil); + cmd(win, "pack .me -side top -fill x"); + cmd(win, "pack .me.l -side top"); + cmd(win, "pack .me.f -side top -fill both -expand 1 -anchor w"); + + "joinclique" => + # joinclique cliqueid clientid memberid name + id := int hd tl tl tl toks; + name := hd tl tl tl tl toks; + if (id == memberid) + break; + f := "." + string id; + cmd(win, "frame " + f); + cmd(win, "label " + f + ".l -text '" + name); + tf := f + ".tf"; + cmd(win, "frame " + tf); + cmd(win, "scrollbar " + tf + ".s -orient vertical -command {" + tf + ".t yview}"); + cmd(win, "text " + tf + ".t -height 5h"); + cmd(win, "pack " + f + ".l -side top"); + cmd(win, "pack " + tf + ".s -side left -fill y"); + cmd(win, "pack " + tf + ".t -side top -fill both -expand 1"); + cmd(win, "pack " + tf + " -side top -fill both -expand 1"); + cmd(win, "pack " + f + " -side top -fill both -expand 1"); + + "say" => + # say memberid text + id := int hd tl toks; + if (id == memberid) + break; + t := "." + string id + ".tf.t"; + cmd(win, t + " insert end '" + unquote(hd tl tl toks) + "\n"); + cmd(win, t + " see end"); + * => + sys->fprint(stderr, "chat: unknown update message '%s'\n", s); + } +} + +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; +} + +kill(pid: int) +{ + if ((fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE)) != nil) + sys->write(fd, array of byte "kill", 4); +} + +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); + return e; +} + diff --git a/appl/spree/clients/gather.b b/appl/spree/clients/gather.b new file mode 100644 index 00000000..113985b3 --- /dev/null +++ b/appl/spree/clients/gather.b @@ -0,0 +1,178 @@ +implement Gather; + +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 "commandline.m"; + commandline: Commandline; + Cmdline: import commandline; +include "sh.m"; + +Gather: module { + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; + +CLIENTDIR: con "/dis/spree/clients"; + +drawctxt: ref Draw->Context; +cliquefd: ref Sys->FD; +stderr: ref Sys->FD; + +mnt, dir: string; + +init(ctxt: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + draw = load Draw Draw->PATH; + tk = load Tk Tk->PATH; + tkclient = load Tkclient Tkclient->PATH; + if (tkclient == nil) { + sys->fprint(stderr, "gather: cannot load %s: %r\n", Tkclient->PATH); + raise "fail:bad module"; + } + tkclient->init(); + commandline = load Commandline Commandline->PATH; + if(commandline == nil) { + sys->fprint(stderr, "gather: cannot load %s: %r\n", Commandline->PATH); + raise "fail:bad module"; + } + commandline->init(); + drawctxt = ctxt; + cliquefd = sys->fildes(0); + + if (len argv >= 3) { + mnt = hd tl argv; + dir = hd tl tl argv; + } else + sys->fprint(stderr, "gather: expected mnt, dir args\n"); + client1(); +} + +client1() +{ + (win, winctl) := tkclient->toplevel(drawctxt, nil, "Gathering", Tkclient->Appl); + ech := chan of string; + tk->namechan(win, ech, "e"); + (chat, chatevent) := Cmdline.new(win, ".chat", nil); + updatech := chan of string; + spawn readproc(updatech); + + cmd(win, "button .b -text Start -command {send e start}"); + cmd(win, "pack .b -side top -anchor w"); + cmd(win, "pack .chat -fill both -expand 1"); + cmd(win, "pack propagate . 0"); + cmd(win, "update"); + tkclient->onscreen(win, nil); + tkclient->startinput(win, "kbd"::"ptr"::nil); + for (;;) alt { + s := <-win.ctxt.kbd => + tk->keyboard(win, s); + s := <-win.ctxt.ptr => + tk->pointer(win, *s); + s := <-win.ctxt.ctl or + s = <-win.wreq or + s = <-winctl => + tkclient->wmctl(win, s); + line := <-updatech => + (n, toks) := sys->tokenize(line, " "); + if (toks == nil) + continue; + case hd toks { + "clienttype" => + chat.addtext("starting " + hd tl toks + " session...\n"); + cmd(win, "update"); + path := CLIENTDIR + "/" + hd tl toks + ".dis"; + mod := load Command path; + if (mod == nil) { + chat.addtext(sys->sprint("could not load %s: %r\n", path)); + chat.addtext("bye bye\n"); + cliquefd = nil; + } else { + win = nil; + chat = nil; + startclient(mod, hd tl toks :: mnt :: dir :: tl tl toks); + exit; + } + "chat" => + chat.addtext(hd tl toks + ": " + concat(tl tl toks) + "\n"); + "title" => + tkclient->settitle(win, "Gather " + concat(tl toks)); + "join" or + "leave" or + "watch" or + "unwatch" => + chat.addtext(line + "\n"); + * => + chat.addtext("unknown update: " + line + "\n"); + } + cmd(win, "update"); + c := <-chatevent => + lines := chat.event(c); + for (; lines != nil; lines = tl lines) + cliquecmd("chat " + hd lines, chat); + c := <-ech => + cliquecmd(c, chat); + } +} + +cliquecmd(s: string, chat: ref Cmdline) +{ + if (sys->fprint(cliquefd, "%s", s) == -1) { + chat.addtext(sys->sprint("command failed: %r\n")); + cmd(chat.top, "update"); + } +} + +prefixed(s: string, prefix: string): int +{ + return len s >= len prefix && s[0:len prefix] == prefix; +} + +readproc(updatech: chan of string) +{ + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(cliquefd, buf, Sys->ATOMICIO)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) { + updatech <-= hd lines; + if (prefixed(hd lines, "clienttype")) + exit; + } + } + updatech <-= nil; +} + +startclient(mod: Command, argv: list of string) +{ + { + mod->init(drawctxt, argv); + } exception e { + "*" => + sys->print("client %s broken: %s\n", hd argv, e); + } +} + +cmd(win: ref Tk->Toplevel, s: string): string +{ + r := tk->cmd(win, s); + if(len r > 0 && r[0] == '!') + sys->print("error executing '%s': %s\n", s, r[1:]); + return r; +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} diff --git a/appl/spree/clients/lobby.b b/appl/spree/clients/lobby.b new file mode 100644 index 00000000..1af52827 --- /dev/null +++ b/appl/spree/clients/lobby.b @@ -0,0 +1,562 @@ +implement Lobby; + +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 "../join.m"; + join: Join; +include "dividers.m"; + dividers: Dividers; + Divider: import dividers; +include "commandline.m"; + commandline: Commandline; + Cmdline: import commandline; +include "sh.m"; + +Lobby: module { + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; + +CLIENTDIR: con "/dis/spree/clients"; +NAMEFONT: con "/fonts/charon/plain.small.font"; +TITLEFONT: con "/fonts/charon/bold.normal.font"; +HEADERFONT: con "/fonts/charon/italic.normal.font"; + +Object: adt { + id: int; + pick { + Session => + filename: string; + owner: string; + invitations: list of string; + members: list of string; + invited: int; + Sessiontype => + start: string; + name: string; + title: string; + clienttype: string; + Invite => + session: ref Object.Session; + name: string; + Member => + parentid: int; + name: string; + Archive => + Other => + } +}; + +drawctxt: ref Draw->Context; +cliquefd: ref Sys->FD; +objects: array of ref Object; +myname: string; +maxid := 0; + +badmodule(m: string) +{ + sys->fprint(sys->fildes(2), "lobby: cannot load %s: %r\n", m); + raise "fail:bad module"; +} + +init(ctxt: ref Draw->Context, nil: list of string) +{ + sys = load Sys Sys->PATH; + draw = load Draw Draw->PATH; + tk = load Tk Tk->PATH; + + tkclient = load Tkclient Tkclient->PATH; + if (tkclient == nil) + badmodule(Tkclient->PATH); + tkclient->init(); + + commandline = load Commandline Commandline->PATH; + if(commandline == nil) + badmodule(Commandline->PATH); + commandline->init(); + + dividers = load Dividers Dividers->PATH; + if (dividers == nil) + badmodule(Dividers->PATH); + dividers->init(); + + join = load Join Join->PATH; + if (join == nil) + badmodule(Join->PATH); + + drawctxt = ctxt; + cliquefd = sys->fildes(0); + sys->pctl(Sys->NEWPGRP, nil); + client1(); +} + +columns := array[] of {("name", ""), ("members", ""), ("watch", "Watch"), ("join", "Join"), ("invite", "Invite")}; + +reqwidth(win: ref Tk->Toplevel, w: string): int +{ + return 2 * int cmd(win, w + " cget -bd") + int cmd(win, w + " cget -width"); +} + +client1() +{ + (win, winctl) := tkclient->toplevel(drawctxt, nil, "Lobby", Tkclient->Appl); + ech := chan of string; + tk->namechan(win, ech, "e"); + (chat, chatevent) := Cmdline.new(win, ".d2", nil); + updatech := chan of list of string; + spawn readproc(updatech); + + cmd(win, "frame .buts"); + cmd(win, "menubutton .buts.start -text New -menu .buts.start.m"); + cmd(win, "menu .buts.start.m"); + cmd(win, "pack .buts.start -side left"); + cmd(win, "button .buts.kick -text Kick -command {send e kick}"); + cmd(win, "pack .buts.kick -side left"); + cmd(win, "pack .buts -side top -fill x"); + + cmd(win, "frame .d1"); + + cmd(win, "scrollbar .d1.s -orient vertical -command {.d1.c yview}"); + cmd(win, "canvas .d1.c -yscrollcommand {.d1.s set}"); + cmd(win, "pack .d1.s -side left -fill y"); + cmd(win, "pack .d1.c -side top -fill both -expand 1"); + cmd(win, "frame .t"); + cmd(win, ".d1.c create window 0 0 -anchor nw -window .t"); + cmd(win, "frame .t.f1 -bd 2 -relief sunken"); + cmd(win, "pack .t.f1 -side top -fill both -expand 1"); + + cmd(win, "label .t.f1.sessionlabel -text Sessions -font " + TITLEFONT); + cmd(win, "pack .t.f1.sessionlabel"); + cmd(win, "frame .t.s"); + cmd(win, "pack .t.s -in .t.f1 -side top -fill both -expand 1"); + + cmd(win, "frame .t.f2 -bd 2 -relief sunken"); + cmd(win, "label .t.archiveslabel -text Archives -font " + TITLEFONT); + cmd(win, "pack .t.archiveslabel"); + cmd(win, "frame .t.a"); + cmd(win, "pack .t.a -in .t.f2 -side top -fill both -expand 1 -anchor w"); + cmd(win, "pack .t.f2 -side top -fill both -expand 1"); + + cmd(win, "label .t.a.title0 -text Title -font " + HEADERFONT); + cmd(win, "label .t.a.title1 -text Members -font " + HEADERFONT); + cmd(win, "grid .t.a.title0 .t.a.title1 -sticky w"); + cmd(win, "grid columnconfigure .t.a 1 -weight 1"); + + cmd(win, "bind .t <Configure> {.d1.c configure -scrollregion {0 0 [.t cget -width] [.t cget -height]}}"); + + cmd(win, "button .tmp"); + for (i := 0; i < len columns; i++) { + (name, mintext) := columns[i]; + cmd(win, ".tmp configure -text '" + mintext); + cmd(win, "grid columnconfigure .t.s " + string i + + " -name " + name + + " -minsize " + string reqwidth(win, ".tmp")); + } + cmd(win, "grid columnconfigure .t.s members -weight 1"); + cmd(win, "destroy .tmp"); + cmd(win, "menu .invite"); + + (divider, dividerevent) := Divider.new(win, ".d", ".d1" :: ".d2" :: nil, Dividers->NS); + cmd(win, "pack .d -side top -fill both"); + cmd(win, "pack propagate . 0"); + tkclient->onscreen(win, nil); + tkclient->startinput(win, "kbd"::"ptr"::nil); + for (;;) { + alt { + s := <-win.ctxt.kbd => + tk->keyboard(win, s); + s := <-win.ctxt.ptr => + tk->pointer(win, *s); + s := <-win.ctxt.ctl or + s = <-win.wreq or + s = <-winctl => + tkclient->wmctl(win, s); + c := <-dividerevent => + divider.event(c); + c := <-chatevent => + lines := chat.event(c); + for (; lines != nil; lines = tl lines) { + line := hd lines; + if (len line > 0 && line[len line-1]=='\n') + line = line[0:len line-1]; + cliquecmd("chat " + line); + } + lines := <-updatech => +#sys->print("++\n"); + for (; lines != nil; lines = tl lines) { +#sys->print("+%s\n", hd lines); + doupdate(win, chat, hd lines); + } + cmd(win, "update"); + c := <-ech => + (n, toks) := sys->tokenize(c, " "); + case hd toks { + "watch" => + joinclique(win, chat, int hd tl toks, "watch"); + "join" => + joinclique(win, chat, int hd tl toks, "join"); + "start" => + start(win, chat, int hd tl toks); + "postinvite" => + postinvite(win, int hd tl toks, hd tl tl toks); + "unarchive" => + e := cliquecmd("unarchive " + hd tl toks); + if (e != nil) + chat.addtext("failed to unarchive: " + e + "\n"); + "invite" => + # invite sessionid name + (id, name) := (hd tl toks, hd tl tl toks); + vname := "inv." + name; + v := int cmd(win, "variable " + vname); + s := "invite"; + if (!v) + s = "uninvite"; + e := cliquecmd(s + " " + string id + " " + name); + if (e != nil) { + chat.addtext("invite failed: " + e + "\n"); + cmd(win, "variable " + vname + " " + string !v); + } + "kick" => + e := cliquecmd("kick"); + if (e != nil) + chat.addtext("kick failed: " + e + "\n"); + * => + sys->print("unknown msg %s\n", c); + } + cmd(win, "update"); + } + } +} + +joinclique(nil: ref Tk->Toplevel, chat: ref Cmdline, id: int, how: string) +{ + pick o := objects[id] { + Session => + e := join->join(drawctxt, "/n/remote", o.filename, how); + if (e != nil) + chat.addtext("couldn't join clique: " + e + "\n"); + else + chat.addtext("joined clique ok\n"); + * => + sys->print("join bad id %d (type %d)\n", id, tagof objects[id]); + } +} + +start(nil: ref Tk->Toplevel, chat: ref Cmdline, id: int) +{ + pick o := objects[id] { + Sessiontype => + e := cliquecmd("start " + o.start); + if (e != nil) + chat.addtext("failed to start clique: " + e + "\n"); + * => + sys->print("start bad id %d (type %d)\n", id, tagof objects[id]); + } +} + +postinvite(win: ref Tk->Toplevel, id: int, widget: string) +{ + pick o := objects[id] { + Session => + cmd(win, ".invite delete 0 end"); + cmd(win, ".invite add checkbutton -text All -variable inv.all -command {send e invite " + string id + " all}"); + for (invites := o.invitations; invites != nil; invites = tl invites) + if (hd invites == "all") + break; + cmd(win, "variable inv.all " + string (invites != nil)); + + for (i := 0; i < len objects; i++) { + if (objects[i] == nil) + continue; + pick p := objects[i] { + Member => + if (tagof(objects[p.parentid]) != tagof(Object.Session) && p.name != o.owner) { + for (invites = o.invitations; invites != nil; invites = tl invites) + if (hd invites == p.name) + break; + invited := invites != nil; + cmd(win, "variable inv." + p.name + " " + string invited); + cmd(win, ".invite add checkbutton -variable inv." + p.name + + " -command {send e invite " + string id + " " + p.name + "}" + + " -text '" + p.name); + } + } + } + x := int cmd(win, widget + " cget -actx"); + y := int cmd(win, widget + " cget -acty"); + h := 2 * int cmd(win, widget + " cget -bd") + int cmd(win, widget + " cget -actheight"); + cmd(win, ".invite post " + string x + " " + string (y + h)); + * => + sys->print("bad invited id %d (type %d)\n", id, tagof objects[id]); + } +} + +panic(s: string) +{ + sys->print("lobby panic: %s\n", s); + raise "panic"; +} + +doupdate(win: ref Tk->Toplevel, chat: ref Cmdline, line: string) +{ + (n, toks) := sys->tokenize(line, " "); + if (n == 0) + return; + case hd toks { + "chat" => + chat.addtext(sys->sprint("%s: %s\n", hd tl toks, concat(tl tl 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; + objtype := tl tl tl tl toks; + o: ref Object; + case hd objtype { + "sessiontype" => + o = ref Object.Sessiontype(id, nil, nil, nil, nil); + "session" => + cmd(win, "grid rowinsert .t.s 0"); + cmd(win, "grid rowconfigure .t.s 0 -name id" + string id); + f := ".t.s.f" + string id; + cmd(win, "frame " + f); # dummy, so we can destroy row easily + cmd(win, "label "+f+".name"); + cmd(win, "grid "+f+".name -row id" + string id + " -column name -in .t.s"); + cmd(win, "button "+f+".watch -text Watch -command {send e watch " + string id + "}"); + cmd(win, "grid "+f+".watch -row id" + string id + " -column watch -in .t.s"); + cmd(win, "label "+f+".members -font " + NAMEFONT); + cmd(win, "grid "+f+".members -row id" + string id + " -column members -in .t.s"); + o = ref Object.Session(id, nil, nil, nil, nil, 0); + "member" => + o = ref Object.Member(id, parentid, nil); + "invite" => + pick parent := objects[parentid] { + Session => + o = ref Object.Invite(id, parent, nil); + * => + panic("invite not under session"); + } + "archive" => + cmd(win, "grid rowinsert .t.a 1"); + cmd(win, "grid rowconfigure .t.a 1 -name id" + string id); + f := ".t.a.f" + string id; + cmd(win, "frame " + f); + cmd(win, "label "+f+".name"); + cmd(win, "grid "+f+".name -row id" + string id + " -column 0 -in .t.a -sticky w"); + cmd(win, "label "+f+".members -anchor w -font " + NAMEFONT); + cmd(win, "grid "+f+".members -row id" + string id + " -column 1 -in .t.a -sticky ew"); + cmd(win, "button "+f+".unarchive -text Unarchive -command {send e unarchive " + string id + "}"); + cmd(win, "grid "+f+".unarchive -row id" + string id + " -column 2 -in .t.a"); + o = ref Object.Archive(id); + * => + o = ref Object.Other(id); + } + objects[id] = o; + + "del" => + # del parent start end objs... + for (objs := tl tl tl tl toks; objs != nil; objs = tl objs) { + id := int hd objs; + pick o := objects[id] { + Session => + cmd(win, "grid rowdelete .t.s id" + string id); + cmd(win, "destroy .t.s.f" + string id); + Archive => + cmd(win, "grid rowdelete .t.a id" + string id); + cmd(win, "destroy .t.a.f" + string id); + Sessiontype => + sys->print("cannot destroy sessiontypes yet\n"); + Member => + pick parent := objects[o.parentid] { + Session => + parent.members = removeitem(parent.members, o.name); + cmd(win, sys->sprint(".t.s.f%d.members configure -text '%s", o.parentid, concat(parent.members))); + * => + chat.addtext(o.name + " has left\n"); + } + Invite => + s := o.session; + invites := s.invitations; + invited := 0; + for (s.invitations = nil; invites != nil; invites = tl invites) { + inv := hd invites; + if (inv != o.name) { + s.invitations = inv :: s.invitations; + if (inv == "all" || inv == myname) + invited = 1; + } + } + if (!invited && s.invited) { + cmd(win, "destroy .t.s.f" + hd tl toks + ".join"); + s.invited = 0; + } + } + objects[id] = nil; + } + + "name" => + myname = hd tl toks; + tkclient->settitle(win, "Lobby (" + myname + ")"); + + "set" => + # set obj attr val + id := int hd tl toks; + (attr, val) := (hd tl tl toks, tl tl tl toks); + pick o := objects[id] { + Session => + f := ".t.s.f" + string id; + case attr { + "filename" => + o.filename = hd val; + "owner" => + if (hd val == myname) { + cmd(win, "label "+f+".invite -text Invite -bd 2 -relief raised"); + cmd(win, "bind "+f+".invite <Button-1> {send e postinvite " + string id + " %W}"); + cmd(win, "grid "+f+".invite -row id" + string id + " -column invite -in .t.s"); + } + o.owner = hd val; + "title" => + cmd(win, f + ".name configure -text '" + concat(val)); + } + Archive => + f := ".t.a.f" + string id; + case attr { + "name" => + cmd(win, f + ".name configure -text '" + concat(val)); + "members" => + cmd(win, f + ".members configure -text '" + concat(val)); + } + Sessiontype => + case attr { + "start" => + o.start = concat(val); + "clienttype" => + o.clienttype = hd val; + "title" => + if (o.title != nil) + panic("can't change sessiontype name!"); + else { + o.title = concat(val); + cmd(win, ".buts.start.m add command" + + " -command {send e start " + string id + "}" + + " -text '" + o.title); + } + "name" => + o.name = hd val; + } + Member => + case attr { + "name" => + if (o.name != nil) + panic("cannot change member name!"); + o.name = hd val; + pick parent := objects[o.parentid] { + Session => + parent.members = o.name :: parent.members; + cmd(win, sys->sprint(".t.s.f%d.members configure -text '%s", o.parentid, concat(parent.members))); + * => + chat.addtext(o.name + " has arrived\n"); + } + } + Invite => + case attr { + "name" => + o.name = hd val; + s := o.session; + sid := string s.id; + f := ".t.s.f" + sid; + invited := o.name == myname || o.name == "all"; + s.invitations = o.name :: s.invitations; + if (invited && !s.invited) { + cmd(win, "button "+f+".join -text Join -command {send e join " + sid + "}"); + cmd(win, "grid "+f+".join -row id" + sid + " -column join -in .t.s"); + s.invited = 1; + } + } + } + } +} + +removeitem(l: list of string, i: string): list of string +{ + rl: list of string; + for (; l != nil; l = tl l) + if (hd l != i) + rl = hd l :: rl; + return rl; +} + +numsplit(s: string): (string, int) +{ + for (i := len s - 1; i >= 0; i--) + if (s[i] < '0' || s[i] > '9') + break; + if (i == len s -1) + return (s, 0); + return (s[0:i+1], int s[i+1:]); +} + +cliquecmd(s: string): string +{ + if (sys->fprint(cliquefd, "%s", s) == -1) { + e := sys->sprint("%r"); + sys->print("error on '%s': %s\n", s, e); + return e; + } + return nil; +} + +prefixed(s: string, prefix: string): int +{ + return len s >= len prefix && s[0:len prefix] == prefix; +} + +readproc(updatech: chan of list of string) +{ + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(cliquefd, buf, Sys->ATOMICIO)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + if (lines != nil) + updatech <-= lines; + } + updatech <-= nil; +} + +startclient(mod: Command, argv: list of string) +{ + { + mod->init(drawctxt, argv); + } exception e { + "*" => + sys->print("client %s broken: %s\n", hd argv, e); + exit; + } + mod->init(drawctxt, argv); +} + +cmd(win: ref Tk->Toplevel, s: string): string +{ + r := tk->cmd(win, s); + if(len r > 0 && r[0] == '!') + sys->print("error executing '%s': %s\n", s, r[1:]); + return r; +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} diff --git a/appl/spree/clients/othello.b b/appl/spree/clients/othello.b new file mode 100644 index 00000000..2a146b8e --- /dev/null +++ b/appl/spree/clients/othello.b @@ -0,0 +1,270 @@ +implement Othello; +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Point, Rect: import draw; +include "tk.m"; + tk: Tk; +include "tkclient.m"; + tkclient: Tkclient; + +SQ: con 30; # Square size in pixels +N: con 8; + +stderr: ref Sys->FD; + +Othello: module { + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; + +Black, White, Nocolour: con iota; +colours := array[] of {White => "white", Black => "black"}; + +win: ref Tk->Toplevel; +board: array of array of int; +notifypid := -1; +membername: string; +membernames := array[2] of string; + +init(ctxt: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + draw = load Draw Draw->PATH; + tk = load Tk Tk->PATH; + tkclient = load Tkclient Tkclient->PATH; + if (tkclient == nil) { + sys->fprint(stderr, "othello: cannot load %s: %r\n", Tkclient->PATH); + raise "fail:bad module"; + } + tkclient->init(); + + if (len argv >= 3) { # argv: modname mnt dir ... + membername = readfile(hd tl argv + "/name"); + sys->print("name is %s\n", membername); + } + client1(ctxt); +} + +configcmds := array[] of { +"canvas .c -height " + string (SQ * N) + " -width " + string (SQ * N) + " -bg green", +"label .status -text {No clique in progress}", +"frame .f", +"label .f.l -text {watching} -bg white", +"label .f.turn -text {}", +"pack .f.l -side left -expand 1 -fill x", +"pack .f.turn -side left -fill x -expand 1", +"pack .c -side top", +"pack .status .f -side top -fill x", +"bind .c <ButtonRelease-1> {send cmd b1up %x %y}", +}; + +client1(ctxt: ref Draw->Context) +{ + cliquefd := sys->fildes(0); + + sys->pctl(Sys->NEWPGRP, nil); + + winctl: chan of string; + (win, winctl) = tkclient->toplevel(ctxt, nil, + "Othello", Tkclient->Appl); + bcmd := chan of string; + tk->namechan(win, bcmd, "cmd"); + for (i := 0; i < len configcmds; i++) + cmd(win, configcmds[i]); + + for (i = 0; i < N; i++) + for (j := 0; j < N; j++) + cmd(win, ".c create rectangle " + r2s(square(i, j))); + board = array[N] of {* => array[N] of {* => Nocolour}}; + tkclient->onscreen(win, nil); + tkclient->startinput(win, "ptr"::"kbd"::nil); + spawn updateproc(cliquefd); + + for (;;) alt { + c := <-bcmd => + (n, toks) := sys->tokenize(c, " "); + case hd toks { + "b1up" => + (inboard, x, y) := boardpos((int hd tl toks, int hd tl tl toks)); + if (!inboard) + break; + othellocmd(cliquefd, "move " + string x + " " + string y); + cmd(win, "update"); + } + s := <-win.ctxt.kbd => + tk->keyboard(win, s); + s := <-win.ctxt.ptr => + tk->pointer(win, *s); + 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); + } +} + +othellocmd(fd: ref Sys->FD, s: string): int +{ + if (sys->fprint(fd, "%s\n", s) == -1) { + notify(sys->sprint("%r")); + return 0; + } + return 1; +} + +updateproc(cliquefd: ref Sys->FD) +{ + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(cliquefd, buf, len buf)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) + applyupdate(hd lines); + cmd(win, "update"); + } + if (n < 0) + sys->fprint(stderr, "othello: error reading updates: %r\n"); + sys->fprint(stderr, "othello: updateproc exiting\n"); +} + +applyupdate(s: string) +{ + (nt, toks) := sys->tokenize(s, " "); + case hd toks { + "create" => + ; # ignore - there's only one object (the board) + "set" => + # set objid attr val + toks = tl tl toks; + (attr, val) := (hd toks, hd tl toks); + case attr { + "members" => + membernames[Black] = hd tl toks; + membernames[White] = hd tl tl toks; + status(membernames[Black]+ "(Black) vs. " + string membernames[White] + "(White)"); + if (membername == membernames[Black]) + cmd(win, ".f.l configure -text Black"); + else if (membername == membernames[White]) + cmd(win, ".f.l configure -text White"); + "turn" => + turn := int val; + if (turn != Nocolour) { + if (membername == membernames[turn]) + cmd(win, ".f.turn configure -text {(Your turn)}"); + else if (membername == membernames[!turn]) + cmd(win, ".f.turn configure -text {}"); + } + "winner" => + text := "it was a draw"; + winner := int val; + if (winner != Nocolour) + text = colours[int val] + " won."; + status("clique over. " + text); + cmd(win, ".f.l configure -text {watching}"); + * => + (x, y) := (attr[0] - 'a', attr[1] - 'a'); + set(x, y, int val); + } + * => + sys->fprint(stderr, "othello: unknown update message '%s'\n", s); + } +} + +status(s: string) +{ + cmd(win, ".status configure -text '" + s); +} + +itemopts(colour: int): string +{ + return "-fill " + colours[colour] + + " -outline " + colours[!colour]; +} + +set(x, y, colour: int) +{ + id := piece(x, y); + if (colour == Nocolour) + cmd(win, ".c delete " + id); + else if (board[x][y] != Nocolour) + cmd(win, ".c itemconfigure " + id + " " + itemopts(colour)); + else + cmd(win, ".c create oval " + r2s(square(x, y)) + " " + + itemopts(colour) + + " -tags {piece " + id + "}"); + board[x][y] = colour; +} + +notify(s: string) +{ + kill(notifypid); + sync := chan of int; + 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 0 0 -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(750); + cmd(win, ".c delete notify"); + cmd(win, "update"); + notifypid = -1; +} + +boardpos(p: Point): (int, int, int) +{ + (x, y) := (p.x / SQ, p.y / SQ); + if (x < 0 || x > N - 1 || y < 0 || y > N - 1) + return (0, 0, 0); + return (1, x, y); +} + +square(x, y: int): Rect +{ + return ((SQ*x, SQ*y), (SQ*(x + 1), SQ*(y + 1))); +} + +piece(x, y: int): string +{ + return "p" + string x + "." + string y; +} + +cmd(top: ref Tk->Toplevel, s: string): string +{ + e := tk->cmd(top, s); + if (e != nil && e[0] == '!') + sys->fprint(stderr, "tk error %s on '%s'\n", e, s); + return e; +} + +r2s(r: Rect): string +{ + return sys->sprint("%d %d %d %d", r.min.x, r.min.y, r.max.x, r.max.y); +} + +kill(pid: int) +{ + if ((fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE)) != nil) + sys->write(fd, array of byte "kill", 4); +} + +readfile(f: string): string +{ + if ((fd := sys->open(f, Sys->OREAD)) == nil) + return nil; + a := array[8192] of byte; + n := sys->read(fd, a, len a); + if (n <= 0) + return nil; + return string a[0:n]; +} + diff --git a/appl/spree/engines/afghan.b b/appl/spree/engines/afghan.b new file mode 100644 index 00000000..0ca2ca49 --- /dev/null +++ b/appl/spree/engines/afghan.b @@ -0,0 +1,302 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + All, None: import Sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember: import cardlib; + dTOP, dLEFT, oLEFT, oRIGHT, EXPAND, FILLX, FILLY, aUPPERCENTRE, + Stackspec: import Cardlib; +include "../gather.m"; + +CLICK, REDEAL: con iota; + +clique: ref Clique; +rows: array of ref Object; # [10] +central: array of ref Object; # [4] +chokey, deck: ref Object; +direction := 0; +nredeals := 0; + +Rowpilespec := Stackspec( + "display", # style + 10, # maxcards + 0, # conceal + nil # title +); + +Centralpilespec := Stackspec( + "pile", + 13, + 0, + nil +); + +clienttype(): string +{ + return "cards"; +} + +maxmembers(): int +{ + return 1; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + return nil; +} + +propose(members: array of string): string +{ + if (len members != 1) + return "one member only"; + return nil; +} + +archive() +{ + archiveobj := cardlib->archive(); + allow->archive(archiveobj); + cardlib->archivearray(rows, "rows"); + cardlib->archivearray(central, "central"); + cardlib->setarchivename(chokey, "chokey"); + cardlib->setarchivename(deck, "deck"); + archiveobj.setattr("direction", string direction, None); + archiveobj.setattr("nredeals", string nredeals, None); +} + +start(members: array of ref Member, archived: int) +{ + if (archived) { + archiveobj := cardlib->unarchive(); + allow->unarchive(archiveobj); + rows = cardlib->getarchivearray("rows"); + central = cardlib->getarchivearray("central"); + chokey = cardlib->getarchiveobj("chokey"); + deck = cardlib->getarchiveobj("deck"); + direction = int archiveobj.getattr("direction"); + nredeals = int archiveobj.getattr("nredeals"); + } else { + p := members[0]; + Cmember.join(p, -1).layout.lay.setvisibility(All); + startclique(); + allow->add(CLICK, p, "click %o %d"); + } +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "you are not playing"; + + case tag { + REDEAL => + if (nredeals >= 3) + return "no more redeals"; + redeal(); + nredeals++; + CLICK => + # click stack index + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + + if (sel.isempty() || sel.stack == stack) { + # selecting a card to move + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + case stype { + "row" or + "chokey" => + select(cp, stack, (nc - 1, nc)); + * => + return "you can't move cards from there"; + } + } else { + # selecting a stack to move to. + card := cardlib->getcard(sel.stack.children[sel.r.start]); + case stype { + "central" => + top := cardlib->getcard(stack.children[nc - 1]); + if (direction == 0) { + if (card.number != (top.number + 1) % 13 && + card.number != (top.number + 12) % 13) + return "out of sequence"; + if (card.suit != top.suit) + return "wrong suit"; + direction = card.number - top.number; + } else { + if (card.number != (top.number + direction + 13) % 13) + return "out of sequence"; + if (card.suit != top.suit) + return "wrong suit"; + } + "row" => + if (nc == 0 || sel.stack.getattr("type") == "chokey") + return "you wish!"; + top := cardlib->getcard(stack.children[nc - 1]); + if (card.suit != top.suit) + return "wrong suit"; + if (card.number != (top.number + 1) % 13 && + card.number != (top.number + 12) % 13) + return "out of sequence"; + "chokey" => + if (nc != 0) + return "only one card allowed there"; + * => + return "can't move there"; + } + sel.transfer(stack, -1); + } + } + return nil; +} + +startclique() +{ + addlayobj, addlayframe: import cardlib; + + entry := clique.newobject(nil, All, "widget entry"); + entry.setattr("command", "say", All); + + but := clique.newobject(nil, All, "widget button"); + but.setattr("text", "Redeal", All); + but.setattr("command", "redeal", All); + allow->add(REDEAL, Cmember.index(0).p, "redeal"); + + addlayframe("topf", nil, nil, dTOP|EXPAND|FILLX|aUPPERCENTRE, dTOP); + addlayobj(nil, "topf", nil, dLEFT, but); + addlayobj(nil, "topf", nil, dLEFT|EXPAND|FILLX, entry); + + addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + + addlayframe("left", "arena", nil, dLEFT|EXPAND, dTOP); + addlayframe("central", "arena", nil, dLEFT|EXPAND, dTOP); + addlayframe("right", "arena", nil, dLEFT|EXPAND, dTOP); + + rows = array[10] of {* => newstack(nil, Rowpilespec, "row")}; + central = array[4] of {* => newstack(nil, Centralpilespec, "central")}; + chokey = newstack(nil, Centralpilespec, "chokey"); + + deck = clique.newobject(nil, All, "stack"); + cardlib->makecards(deck, (0, 13), nil); + cardlib->shuffle(deck); + + for (i := 0; i < 5; i++) + addlayobj(nil, "left", nil, dTOP|oRIGHT, rows[i]); + for (i = 5; i < 10; i++) + addlayobj(nil, "right", nil, dTOP|oRIGHT, rows[i]); + for (i = 0; i < 4; i++) + addlayobj(nil, "central", nil, dTOP, central[i]); + addlayobj(nil, "central", nil, dTOP, chokey); + + for (i = 0; i < 52; i++) + cardlib->setface(deck.children[i], 1); + # get top card from deck for central piles. + c := deck.children[len deck.children - 1]; + v := cardlib->getcard(c); + j := 0; + for (i = len deck.children - 1; i >= 0; i--) { + w := cardlib->getcard(deck.children[i]); + if (w.number == v.number) + deck.transfer((i, i + 1), central[j++], -1); + } + for (i = 0; i < 10; i += 5) { + for (j = i; j < i + 4; j++) + deck.transfer((0, 5), rows[j], -1); + deck.transfer((0, 4), rows[j], -1); + } +} + +redeal() +{ + for (i := 0; i < len rows; i++) + cardlib->discard(rows[i], deck, 0); + cardlib->shuffle(deck); + + i = 0; + while ((n := len deck.children) > 0) { + l, r: int; + if (n >= 10) + l = r = 5; + else { + l = n / 2; + r = n - l; + } + deck.transfer((0, l), rows[i], 0); + deck.transfer((0, r), rows[i + 5], 0); + i++; + } + + n = cardlib->nmembers(); + for (i = 0; i < n; i++) + Cmember.index(i).sel.set(nil); +} + +newstack(parent: ref Object, spec: Stackspec, stype: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + return stack; +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} + +archivearray(a: array of ref Object, name: string) +{ + for (i := 0; i < len a; i++) + cardlib->setarchivename(a[i], name + string i); +} + +unarchivearray(a: array of ref Object, name: string) +{ + for (i := 0; i < len a; i++) + a[i] = cardlib->getarchiveobj(name + string i); +} diff --git a/appl/spree/engines/bounce.b b/appl/spree/engines/bounce.b new file mode 100644 index 00000000..05e476d4 --- /dev/null +++ b/appl/spree/engines/bounce.b @@ -0,0 +1,258 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Point, Rect: import draw; +include "sets.m"; + sets: Sets; + Set, All, None, A, B: import sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member: import spree; +include "../gather.m"; + +clique: ref Clique; + +W, H: con 500; +INSET: con 20; +D: con 30; +BATLEN: con 100.0; +GOALSIZE: con 0.1; + +MAXPLAYERS: con 32; +nmembers := 0; + +Line: adt { + p1, p2: Point; + seg: fn(l: self Line, s1, s2: real): Line; +}; + +Dmember: adt { + p: ref Member; + score: int; + bat: ref Object; +}; + +Eusage: con "bad command usage"; +colours := array[4] of {"blue", "orange", "yellow", "white"}; +batpos: array of Line; +borderpos: array of Line; + +members: array of Dmember; +arena: ref Object; +clienttype(): string +{ + return "bounce"; +} + +maxmembers(): int +{ + return 4; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + draw = load Draw Draw->PATH; + clique = g; + spree = srvmod; + + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("spit: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + sets->init(); + + r := Rect((0, 0), (W, H)); + walls := sides(r.inset(INSET)); + addlines(segs(walls, 0.0, 0.5 - GOALSIZE), nil); + addlines(segs(walls, 0.5 + GOALSIZE, 1.0), nil); + + batpos = l2a(segs(sides(r.inset(INSET + 50)), 0.1, 0.9)); + borderpos = l2a(sides(r.inset(-1))); + + arena = clique.newobject(nil, All, "arena"); + arena.setattr("arenasize", string W + " " + string H, All); + + return nil; +} + +propose(members: array of string): string +{ + if (len members < 2) + return "need at least two members"; + if (len members > 4) + return "too many members"; + return nil; +} + +archive() +{ +} + +start(pl: array of ref Member, archived: int) +{ + if (archived) { + } else { + members = array[len pl] of Dmember; + for (i := 0; i < len pl; i++) { + p := pl[i]; + bat := addline(batpos[i], nil); + bat.setattr("pos", "10 " + string (10.0 + BATLEN), All); + bat.setattr("owner", p.name, All); + addline(borderpos[i], ("owner", p.name) :: nil); + arena.setattr("member" + string i, p.name + " " + colours[i], All); + members[i] = (p, 0, bat); + } + r := Rect((0, 0), (W, H)).inset(INSET + 1); + goals := l2a(sides(r)); + for (i = len members; i < len batpos; i++) { + addline(goals[i], nil); + addline(borderpos[i], ("owner", pl[0].name) :: nil); + } + } +} + +addline(lp: (Point, Point), attrs: list of (string, string)): ref Object +{ + (p1, p2) := lp; + l := clique.newobject(nil, All, "line"); + l.setattr("coords", p2s(p1) + " " + p2s(p2), All); + l.setattr("id", string l.id, All); + for (; attrs != nil; attrs = tl attrs) { + (attr, val) := hd attrs; + l.setattr(attr, val, All); + } + return l; +} + + +p2s(p: Point): string +{ + return string p.x + " " + string p.y; +} + +command(member: ref Member, cmd: string): string +{ + ord := order(member); + sys->print("cmd: %s", cmd); + { + (n, toks) := sys->tokenize(cmd, " \n"); + assert(n > 0, "unknown command"); + case hd toks { + "newball" => + # newball batid p.x p.y v.x v.y speed + assert(n == 7, Eusage); + bat := member.obj(int hd tl toks); + assert(bat != nil, "no such bat"); + ball := clique.newobject(nil, All, "ball"); + ball.setattr("state", string bat.id + " " + string ord + + " " + concat(tl tl toks) + " " + string sys->millisec(), All); + "lost" => + # lost ballid + assert(n == 2, Eusage); + o := member.obj(int hd tl toks); + assert(o != nil, "bad object"); + assert(o.getattr("state") != nil, "can only lose balls"); + o.delete(); + "state" => + # state ballid lasthit owner p.x p.y v.x v.y s time + assert(n == 10, Eusage); + assert(ord >= 0, "you are not playing"); + o := member.obj(int hd tl toks); + assert(o != nil, "object does not exist"); + o.setattr("state", concat(tl tl toks), All); + members[ord].score++; + arena.setattr("score" + string ord, string members[ord].score, All); + "bat" => + # bat pos + assert(n == 2, Eusage); + s1 := real hd tl toks; + members[ord].bat.setattr("pos", hd tl toks + " " + string (s1 + BATLEN), All); + "time" => + # time millisec + assert(n == 2, Eusage); + tm := int hd tl toks; + offset := sys->millisec() - tm; + clique.action("time " + string offset + " " + string tm, nil, nil, None.add(member.id)); + * => + assert(0, "bad command"); + } + } exception e { + "parse:*" => + return e[6:]; + } + return nil; +} + +order(p: ref Member): int +{ + for (i := 0; i < len members; i++) + if (members[i].p == p) + return i; + return -1; +} + +assert(b: int, err: string) +{ + if (b == 0) + raise "parse:" + err; +} + +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; +} + +Line.seg(l: self Line, s1, s2: real): Line +{ + (dx, dy) := (l.p2.x - l.p1.x, l.p2.y - l.p1.y); + return (((l.p1.x + int (s1 * real dx)), l.p1.y + int (s1 * real dy)), + ((l.p1.x + int (s2 * real dx)), l.p1.y + int (s2 * real dy))); +} + +sides(r: Rect): list of Line +{ + return ((r.min.x, r.min.y), (r.min.x, r.max.y)) :: + ((r.max.x, r.min.y), (r.max.x, r.max.y)) :: + ((r.min.x, r.min.y), (r.max.x, r.min.y)) :: + ((r.min.x, r.max.y), (r.max.x, r.max.y)) :: nil; +} + +addlines(ll: list of Line, attrs: list of (string, string)) +{ + for (; ll != nil; ll = tl ll) + addline(hd ll, attrs); +} + +segs(ll: list of Line, s1, s2: real): list of Line +{ + nll: list of Line; + for (; ll != nil; ll = tl ll) + nll = (hd ll).seg(s1, s2) :: nll; + ll = nil; + for (; nll != nil; nll = tl nll) + ll = hd nll :: ll; + return ll; +} + +l2a(ll: list of Line): array of Line +{ + a := array[len ll] of Line; + for (i := 0; ll != nil; ll = tl ll) + a[i++] = hd ll; + return a; +} diff --git a/appl/spree/engines/canfield.b b/appl/spree/engines/canfield.b new file mode 100644 index 00000000..dbf3734f --- /dev/null +++ b/appl/spree/engines/canfield.b @@ -0,0 +1,340 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + All, None: import Sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember, Card: import cardlib; + dTOP, dRIGHT, dLEFT, oDOWN, + aCENTRELEFT, aUPPERRIGHT, + EXPAND, FILLX, FILLY, Stackspec: import Cardlib; +include "../gather.m"; + +clique: ref Clique; + +sevens: array of ref Object; # [7] +spare1, spare2: ref Object; +acepiles: array of ref Object; # [4] +top2botcount := 3; +top2bot: ref Object; + +CLICK, TOP2BOT, REDEAL, SHOW: con iota; + +Openspec := Stackspec( + "display", # style + 19, # maxcards + 0, # conceal + "" # title +); + +Pilespec := Stackspec( + "pile", # style + 19, # maxcards + 0, # conceal + "pile" # title +); + +Untitledpilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "" # title +); + +clienttype(): string +{ + return "cards"; +} + +rank := array[] of {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}; + +maxmembers(): int +{ + return 1; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + return nil; +} + +propose(members: array of string): string +{ + if (len members != 1) + return "one member only"; + return nil; +} + +start(members: array of ref Member, archived: int) +{ + allow->add(SHOW, nil, "show"); + if (archived) { + archiveobj := cardlib->unarchive(); + sevens = cardlib->getarchivearray("sevens"); + acepiles = cardlib->getarchivearray("acepiles"); + spare1 = cardlib->getarchiveobj("spare1"); + spare2 = cardlib->getarchiveobj("spare2"); + top2bot = cardlib->getarchiveobj("top2bot"); + top2botcount = int archiveobj.getattr("top2botcount"); + + allow->unarchive(archiveobj); + archiveobj.delete(); + } else { + p := members[0]; + Cmember.join(p, -1).layout.lay.setvisibility(All); + startclique(); + allow->add(CLICK, p, "click %o %d"); + allow->add(TOP2BOT, p, "top2bot"); + allow->add(REDEAL, p, "redeal"); + } +} + +archive() +{ + archiveobj := cardlib->archive(); + cardlib->archivearray(sevens, "sevens"); + cardlib->archivearray(acepiles, "acepiles"); + cardlib->setarchivename(spare1, "spare1"); + cardlib->setarchivename(spare2, "spare2"); + cardlib->setarchivename(top2bot, "top2bot"); + archiveobj.setattr("top2botcount", string top2botcount, None); + allow->archive(archiveobj); +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "you are not playing"; + + case tag { + CLICK => + # click stack index + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + if (sel.isempty() || sel.stack == stack) { + if (nc == 0 && stype == "spare1") { + cardlib->flip(spare2); + spare2.transfer((0, len spare2.children), spare1, 0); + return nil; + } + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + case stype { + "spare2" or + "open" => + select(cp, stack, (idx, nc)); + "spare1" => + if ((n := nc) > 3) + n = 3; + for (i := 0; i < n; i++) { + cardlib->setface(stack.children[nc - 1], 1); + stack.transfer((nc - 1, nc), spare2, -1); + nc--; + } + * => + return "you can't move cards from there"; + } + } else { + from := sel.stack; + case stype { + "acepile" => + if (sel.r.end != sel.r.start + 1) + return "only one card at a time!"; + card := getcard(sel.stack.children[sel.r.start]); + if (nc == 0) { + if (card.number != 0) + return "aces only"; + } else { + top := getcard(stack.children[nc - 1]); + if (card.number != top.number + 1) + return "out of sequence"; + if (card.suit != top.suit) + return "wrong suit"; + } + sel.transfer(stack, -1); + "open" => + c := getcard(sel.stack.children[sel.r.start]); + col := !isred(c); + n := c.number + 1; + for (i := sel.r.start; i < sel.r.end; i++) { + c2 := getcard(sel.stack.children[i]); + if (c2.face == 0) + return "cannot move face-down cards"; + if (isred(c2) == col) + return "bad colour sequence"; + if (c2.number != n - 1) + return "bad number sequence"; + n = c2.number; + col = isred(c2); + } + if (nc != 0) { + c2 := getcard(stack.children[nc - 1]); + if (isred(c2) == isred(c) || c2.number != c.number + 1) + return "invalid move"; + } else if (c.number != 12) + return "only kings allowed there"; + sel.transfer(stack, -1); + * => + return "can't move there"; + } + if (from.getattr("type") == "open" && len from.children > 0) + cardlib->setface(from.children[len from.children - 1], 1); + } + TOP2BOT => + if (len spare2.children != 0) + return "can only top-to-bottom on the whole pile"; + if (top2botcount <= 0) + return "too late"; + nc := len spare1.children; + if (nc > 0) { + spare1.transfer((nc - 1, nc), spare1, 0); + top2botcount--; + settop2bottext(); + } + REDEAL => + clearup(); + cardlib->shuffle(spare1); + deal(); + top2botcount = 3; + settop2bottext(); + SHOW => + clique.show(nil); + } + return nil; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +settop2bottext() +{ + top2bot.setattr("text", + sys->sprint("top to bottom (%d left)", top2botcount), All); +} + +startclique() +{ + addlayobj, addlayframe: import cardlib; + + entry := clique.newobject(nil, All, "widget entry"); + entry.setattr("command", "say", All); + addlayobj("entry", nil, nil, dTOP|FILLX, entry); + addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + + addlayframe("top", "arena", nil, dTOP|EXPAND, dTOP); + addlayframe("mid", "arena", nil, dTOP|EXPAND, dTOP); + addlayframe("bot", "arena", nil, dTOP|EXPAND, dTOP); + + sevens = array[7] of {* => newstack(nil, Openspec, "open")}; + acepiles = array[4] of {* => newstack(nil, Untitledpilespec, "acepile")}; + spare1 = newstack(nil, Untitledpilespec, "spare1"); + spare2 = newstack(nil, Untitledpilespec, "spare2"); + + cardlib->makecards(spare1, (0, 13), nil); + + for (i := 0; i < 4; i++) + addlayobj(nil, "top", nil, dRIGHT, acepiles[i]); + for (i = 0; i < len sevens; i++) + addlayobj(nil, "mid", nil, dLEFT|oDOWN|EXPAND, sevens[i]); + addlayframe("buts", "bot", nil, dLEFT|EXPAND|aUPPERRIGHT, dTOP); + top2bot = newbutton("top2bot", "top to bottom"); + addlayobj(nil, "buts", nil, dTOP, top2bot); + addlayobj(nil, "buts", nil, dTOP, newbutton("redeal", "redeal")); + addlayobj(nil, "bot", nil, dLEFT, spare1); + addlayobj(nil, "bot", nil, dLEFT|EXPAND|aCENTRELEFT, spare2); + deal(); + settop2bottext(); +} + +clearup() +{ + for (i := 0; i < len sevens; i++) + cardlib->discard(sevens[i], spare1, 1); + for (i = 0; i < len acepiles; i++) + cardlib->discard(acepiles[i], spare1, 1); + cardlib->discard(spare2, spare1, 1); +} + +deal() +{ + cardlib->shuffle(spare1); + + for (i := 0; i < 7; i++) { + spare1.transfer((0, i + 1), sevens[i], 0); + cardlib->setface(sevens[i].children[i], 1); + } + +} + +newbutton(cmd, text: string): ref Object +{ + but := clique.newobject(nil, All, "widget button"); + but.setattr("command", cmd, All); + but.setattr("text", text, All); + return but; +} + +newstack(parent: ref Object, spec: Stackspec, stype: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + return stack; +} + +getcard(card: ref Object): Card +{ + c := cardlib->getcard(card); + c.number = rank[c.number]; + return c; +} + +isred(c: Card): int +{ + return c.suit == Cardlib->DIAMONDS || c.suit == Cardlib->HEARTS; +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} diff --git a/appl/spree/engines/chat.b b/appl/spree/engines/chat.b new file mode 100644 index 00000000..c409b272 --- /dev/null +++ b/appl/spree/engines/chat.b @@ -0,0 +1,60 @@ +implement Engine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member: import spree; + +clique: ref Clique; + +clienttype(): string +{ + return "chat"; +} + +init(g: ref Clique, srvmod: Spree): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + return nil; +} + +join(nil: ref Member): string +{ + return nil; +} + +leave(nil: ref Member) +{ +} + +Eusage: con "bad command usage"; + +command(member: ref Member, cmd: string): string +{ + e := ref Sys->Exception; + if (sys->rescue("parse:*", e) == Sys->EXCEPTION) { + sys->rescued(Sys->ONCE, nil); + return e.name[6:]; + } + (n, toks) := sys->tokenize(cmd, " \n"); + assert(n > 0, "unknown command"); + case hd toks { + "say" => + # say something + assert(n == 2, Eusage); + clique.action("say " + string member.id + " " + hd tl toks, nil, nil, ~0); + * => + assert(0, "bad command"); + } + return nil; +} + +assert(b: int, err: string) +{ + if (b == 0) + sys->raise("parse:" + err); +} diff --git a/appl/spree/engines/debug.b b/appl/spree/engines/debug.b new file mode 100644 index 00000000..96acede0 --- /dev/null +++ b/appl/spree/engines/debug.b @@ -0,0 +1,163 @@ +implement Engine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member: import spree; + +clique: ref Clique; + +init(g: ref Clique, srvmod: Spree): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + return nil; +} + +join(nil: ref Member): string +{ + return nil; +} + +leave(nil: ref Member) +{ +} + +number := 0; +currmember: ref Member; + +obj(ext: int): ref Object +{ + o := currmember.obj(ext); + if (o == nil) + sys->raise("parse:bad object"); + return o; +} + +Eusage: con "bad command usage"; + +assert(b: int, err: string) +{ + if (b == 0) + sys->raise("parse:" + err); +} + +command(member: ref Member, cmd: string): string +{ + e := ref Sys->Exception; + if (sys->rescue("parse:*", e) == Sys->EXCEPTION) { + sys->rescued(Sys->ONCE, nil); + currmember = nil; + return e.name[6:]; + } + currmember = member; + (nlines, lines) := sys->tokenize(cmd, "\n"); + assert(nlines > 0, "unknown command"); + (n, toks) := sys->tokenize(hd lines, " "); + assert(n > 0, "unknown command"); + case hd toks { + "new" => # new parent visibility\nvisibility attr val\nvisibility attr val... + assert(n == 3, Eusage); + setattrs(clique.newobject(obj(int hd tl toks), int hd tl tl toks), tl lines); + "deck" => + stack := clique.newobject(nil, ~0); + stack.setattr("type", "stack", ~0); + for (i := 0; i < 6; i++) { + o := clique.newobject(stack, ~0); + o.setattr("face", "down", ~0); + o.setattr("number", string number++, 0); + } + "flip" => + # flip objid start [end] + assert(n == 2 || n == 3 || n == 4, Eusage); + o := obj(int hd tl toks); + if (n > 2) { + start := int hd tl tl toks; + end := start + 1; + if (n == 4) + end = int hd tl tl tl toks; + assert(start >= 0 && start < len o.children && + end >= start && end >= 0 && end <= len o.children, "index out of range"); + for (; start < end; start++) + flip(o.children[start]); + } else + flip(o); + + "set" => # set objid attr val + assert(n == 4, Eusage); + obj(int hd tl toks).setattr(hd tl tl toks, hd tl tl tl toks, ~0); + "vis" => # vis objid flags + assert(n == 3, Eusage); + obj(int hd tl toks).setvisibility(int hd tl tl toks); + "attrvis" => # attrvis objid attr flags + assert(n == 4, Eusage); + o := obj(int hd tl toks); + name := hd tl tl toks; + attr := o.attrs.get(name); + assert(attr != nil, "attribute not found"); + o.setattrvisibility(name, int hd tl tl tl toks); + "show" => # show [memberid] + p: ref Member = nil; + if (n == 2) { + memberid := int hd tl toks; + p = clique.member(memberid); + assert(p != nil, "bad memberid"); + } + clique.show(p); + "del" or "delete" => # del obj + assert(n == 2, Eusage); + obj(int hd tl toks).delete(); + "tx" => # tx src from to dest [index] + assert(n == 5 || n == 6, Eusage); + src, dest: ref Object; + r: Range; + (src, toks) = (obj(int hd tl toks), tl tl toks); + (r.start, toks) = (int hd toks, tl toks); + (r.end, toks) = (int hd toks, tl toks); + (dest, toks) = (obj(int hd toks), tl toks); + index := len dest.children; + if (n == 6) + index = int hd toks; + assert(r.start >= 0 && r.start < len src.children && + r.end >= 0 && r.end <= len src.children && r.end >= r.start, + "bad range"); + src.transfer(r, dest, index); + * => + assert(0, "bad command"); + } + currmember = nil; + return nil; +} + + +flip(o: ref Object) +{ + face := o.getattr("face"); + if (face == "down") { + face = "up"; + o.setattrvisibility("number", ~0); + } else { + face = "down"; + o.setattrvisibility("number", 0); + } + o.setattr("face", face, ~0); +} + +setattrs(o: ref Object, lines: list of string): string +{ + for (; lines != nil; lines = tl lines) { + # attr val [visibility] + (n, toks) := sys->tokenize(hd lines, " "); + if (n != 2 && n != 3) + return "bad attribute line"; + vis := 0; + if (n == 3) + vis = int hd tl tl toks; + o.setattr(hd toks, hd tl toks, vis); + } + return nil; +} + diff --git a/appl/spree/engines/freecell.b b/appl/spree/engines/freecell.b new file mode 100644 index 00000000..8005926c --- /dev/null +++ b/appl/spree/engines/freecell.b @@ -0,0 +1,428 @@ +implement Gatherengine; + +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 "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember, Card: import cardlib; + getcard: import cardlib; + dTOP, dRIGHT, dLEFT, oRIGHT, oDOWN, + aCENTRERIGHT, aCENTRELEFT, aUPPERRIGHT, + EXPAND, FILLX, FILLY, Stackspec: import Cardlib; +include "../gather.m"; + +clique: ref Clique; + +open: array of ref Object; # [8] +cells: array of ref Object; # [4] +acepiles: array of ref Object; # [4] +txpiles: array of ref Object; # [len open + len cells] +deck: ref Object; + +fnames := array[] of { +"qua", +"quack", +"quackery", +"quad", +"quadrangle", +"quadrangular", +"quadrant", +"quadratic", +"quadrature", +"quadrennial", +}; +dir(name: string, perm: int, owner: string): Sys->Dir +{ + d := Sys->zerodir; + d.name = name; + d.uid = owner; + d.gid = owner; + d.qid.qtype = (perm >> 24) & 16rff; + d.mode = perm; + # d.atime = now; + # d.mtime = now; + return d; +} + + +suitsout := array[4] of {* => -1}; + +mainmember: ref Cmember; + +CLICK: con iota; + +Openspec := Stackspec( + "display", # style + 19, # maxcards + 0, # conceal + "" # title +); + +Pilespec := Stackspec( + "pile", # style + 19, # maxcards + 0, # conceal + "pile" # title +); + +Untitledpilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "" # title +); + +clienttype(): string +{ + return "cards"; +} + +maxmembers(): int +{ + return 1; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("whist: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + g.fcreate(0, -1, dir("data", 8r555|Sys->DMDIR, "spree")); + for(i := 0; i < len fnames; i++) + g.fcreate(i + 1, 0, dir(fnames[i], 8r444, "arble")); + return nil; +} + +propose(members: array of string): string +{ + if (len members != 1) + return "one member only"; + return nil; +} + +start(members: array of ref Member, archived: int) +{ +sys->print("freecell: starting\n"); + if (archived) { + archiveobj := cardlib->unarchive(); + open = cardlib->getarchivearray("open"); + cells = cardlib->getarchivearray("cells"); + acepiles = cardlib->getarchivearray("acepiles"); + txpiles = cardlib->getarchivearray("txpiles"); + deck = cardlib->getarchiveobj("deck"); + for (i := 0; i < len suitsout; i++) + suitsout[i] = int archiveobj.getattr("suitsout" + string i); + mainmember = Cmember.findid(int archiveobj.getattr("mainmember")); + allow->unarchive(archiveobj); + archiveobj.delete(); + } else { + sys->print("freecell: starting afresh\n"); + mainmember = Cmember.join(members[0], -1); + mainmember.layout.lay.setvisibility(All); + startclique(); + movefree(); + allow->add(CLICK, members[0], "click %o %d"); + } +} + +readfile(f: int, boffset: big, n: int): array of byte +{ + offset := int boffset; + f--; + if (f < 0 || f >= len fnames) + return nil; + data := array of byte fnames[f]; + if (offset >= len data) + return nil; + if (offset + n > len data) + n = len data - offset; + return data[offset:offset + n]; +} + +archive() +{ + sys->print("freecell: archiving\n"); + archiveobj := cardlib->archive(); + cardlib->archivearray(open, "open"); + cardlib->archivearray(cells, "cells"); + cardlib->archivearray(acepiles, "acepiles"); + cardlib->archivearray(txpiles, "txpiles"); + cardlib->setarchivename(deck, "deck"); + for (i := 0; i < len suitsout; i++) + archiveobj.setattr("suitsout" + string i, string suitsout[i], None); + archiveobj.setattr("mainmember", string mainmember.id, None); + allow->archive(archiveobj); +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "you are not playing"; + case tag { + CLICK => + # click stack index + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + if (sel.isempty() || sel.stack == stack) { + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + case stype { + "cell" or + "open" => + select(cp, stack, (idx, nc)); + * => + return "you can't move cards from there"; + } + } else { + from := sel.stack; + case stype { + "acepile" => + if (sel.r.end != sel.r.start + 1) + return "only one card at a time!"; + addtoacepile(sel.stack); + sel.set(nil); + movefree(); + "open" => + c := getcard(sel.stack.children[sel.r.start]); + col := !isred(c.suit); + n := c.number + 1; + for (i := sel.r.start; i < sel.r.end; i++) { + c2 := getcard(sel.stack.children[i]); + if (isred(c2.suit) == col) + return "bad colour sequence"; + if (c2.number != n - 1) + return "bad number sequence"; + n = c2.number; + col = isred(c2.suit); + } + if (nc != 0) { + c2 := getcard(stack.children[nc - 1]); + if (isred(c2.suit) == isred(c.suit) || c2.number != c.number + 1) + return "opposite colours, descending, only"; + } + r := sel.r; + selstack := sel.stack; + sel.set(nil); + fc := freecells(stack); + if (r.end - r.start - 1 > len fc) + return "not enough free cells"; + n = 0; + for (i = r.end - 1; i >= r.start + 1; i--) + selstack.transfer((i, i + 1), fc[n++], -1); + selstack.transfer((i, i + 1), stack, -1); + while (--n >= 0) + fc[n].transfer((0, 1), stack, -1); + movefree(); + "cell" => + if (sel.r.end - sel.r.start > 1 || nc > 0) + return "only one card allowed there"; + sel.transfer(stack, -1); + movefree(); + * => + return "can't move there"; + } + } + } + return nil; +} + +freecells(dest: ref Object): array of ref Object +{ + fc := array[len txpiles] of ref Object; + n := 0; + for (i := 0; i < len txpiles; i++) + if (len txpiles[i].children == 0 && txpiles[i] != dest) + fc[n++] = txpiles[i]; + return fc[0:n]; +} + +# move any cards that can be moved. +movefree() +{ + nmoved := 1; + while (nmoved > 0) { + nmoved = 0; + for (i := 0; i < len txpiles; i++) { + pile := txpiles[i]; + nc := len pile.children; + if (nc == 0) + continue; + card := getcard(pile.children[nc - 1]); + if (suitsout[card.suit] != card.number - 1) + continue; + # card can be moved; now make sure there's no card out + # that might be moved onto this card + for (j := 0; j < len suitsout; j++) + if (isred(j) != isred(card.suit) && card.number > 1 && suitsout[j] < card.number - 1) + break; + if (j == len suitsout) { + addtoacepile(pile); + nmoved++; + } + } + } +} + +addtoacepile(pile: ref Object) +{ + nc := len pile.children; + if (nc == 0) + return; + card := getcard(pile.children[nc - 1]); + for (i := 0; i < len acepiles; i++) { + anc := len acepiles[i].children; + if (anc == 0) { + if (card.number == 0) + break; + continue; + } + acard := getcard(acepiles[i].children[anc - 1]); + if (acard.suit == card.suit && acard.number == card.number - 1) + break; + } + if (i < len acepiles) { + pile.transfer((nc - 1, nc), acepiles[i], -1); + suitsout[card.suit] = card.number; + } +} + +startclique() +{ + addlayobj, addlayframe: import cardlib; + + open = array[8] of {* => newstack(nil, Openspec, "open", nil)}; + acepiles = array[4] of {* => newstack(nil, Untitledpilespec, "acepile", nil)}; + cells = array[4] of {* => newstack(nil, Untitledpilespec, "cell", "cell")}; + for (i := 0; i < len cells; i++) + cells[i].setattr("showsize", "0", All); + + txpiles = array[12] of ref Object; + txpiles[0:] = open; + txpiles[len open:] = cells; + deck = clique.newobject(nil, All, "stack"); + + cardlib->makecards(deck, (0, 13), nil); + + addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + addlayframe("top", "arena", nil, dTOP|EXPAND, dTOP); + addlayframe("bot", "arena", nil, dTOP|EXPAND, dTOP); + for (i = 0; i < 4; i++) + addlayobj(nil, "top", nil, dRIGHT, acepiles[i]); + for (i = 0; i < 4; i++) + addlayobj(nil, "top", nil, dLEFT, cells[i]); + for (i = 0; i < len open; i++) + addlayobj(nil, "bot", nil, dLEFT|oDOWN|EXPAND, open[i]); + deal(); +} + +deal() +{ + cardlib->shuffle(deck); + cardlib->deal(deck, 7, open, 0); +} + +newstack(parent: ref Object, spec: Stackspec, stype, title: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + stack.setattr("title", title, All); + return stack; +} + +isred(suit: int): int +{ + return suit == Cardlib->DIAMONDS || suit == Cardlib->HEARTS; +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} + +#randstate := 1; +#srand(seed: int) +#{ +# randstate = seed; +#} +# +#rand(): int +#{ +# randstate = randstate * 214013 + 2531011; +# return (randstate >> 16) & 0x7fff; +#} +##From: jimh@MICROSOFT.com (Jim Horne) +## +##I'm happy to share the card shuffle algorithm, but I warn you, +##it does depend on the rand() and srand() function built into MS +##compilers. The good news is that I believe these work the same +##for all our compilers. +## +##I use cards.dll which has it's own mapping of numbers (0-51) to +##cards. The following will give you the idea. Play around with +##this and you'll be able to generate all the cliques. +## +##Go ahead and post the code. People might as well have fun with it. +##Please keep me posted on anything interesting that comes of it. +##Thanks. +# +#msdeal(cliquenumber: int): array of array of Card +#{ +# deck := array[52] of Card; +# for (i := 0; i < len deck; i++) # put unique card in each deck loc. +# deck[i] = Card(i % 4, i / 4, 0); +# wleft := 52; # cards left to be chosen in shuffle +# cards := array[8] of {* => array[7] of Card}; +# max := array[8] of {* => 0}; +# srand(cliquenumber); +# for (i = 0; i < 52; i++) { +# j := rand() % wleft; +# card[i % 8][i / 8] = deck[j]; +# max[i % 8] = i / 8; +# deck[j] = deck[--wleft]; +# } +# for (i = 0; i < len cards; i++) +# cards[i] = cards[i][0:max[i]]; +# return cards; +#} diff --git a/appl/spree/engines/gather.b b/appl/spree/engines/gather.b new file mode 100644 index 00000000..59b7bfb2 --- /dev/null +++ b/appl/spree/engines/gather.b @@ -0,0 +1,267 @@ +implement Engine; + +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; + archives: Archives; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "daytime.m"; + daytime: Daytime; +include "../gather.m"; + +clique: ref Clique; + +started := 0; +halted := 0; +suspended: Set; # set of members currently suspended from the clique. +count := 0; +nmembers := 0; +title := "unknown"; +cliquemod: Gatherengine; + +members: Set; +watchers: Set; + +invited: list of string; + +# options: +# <n> cliquemodule opts +init(srvmod: Spree, g: ref Clique, argv: list of string): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("gather: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + sets->init(); + daytime = load Daytime Daytime->PATH; + if (daytime == nil) { + sys->print("gather: cannot load %s: %r\n", Daytime->PATH); + return "bad module"; + } + archives = load Archives Archives->PATH; + if (archives == nil) { + sys->print("gather: cannot load %s: %r\n", Archives->PATH); + return "bad module"; + } + archives->init(srvmod); + argv = tl argv; + n := len argv; + if (n < 2) + return "bad init options"; + count = int hd argv; + if (count != -1 && count <= 0) + return "bad gather count"; + argv = tl argv; + if (count < len clique.archive.members) + count = len clique.archive.members; + cliquemod = load Gatherengine "/dis/spree/engines/" + hd argv + ".dis"; + if (cliquemod == nil) + return sys->sprint("bad module: %r"); + title = concat(argv); + e := cliquemod->init(srvmod, clique, tl argv, len clique.archive.members > 0); + if (e != nil) + return e; + if (len clique.archive.members > 0) { + for (i := 0; i < len clique.archive.members; i++) + invited = clique.archive.members[i] :: invited; + } else + invited = clique.owner() :: nil; + for (inv := invited; inv != nil; inv = tl inv) + clique.notify(clique.parentid, "invite " + hd inv); + clique.notify(clique.parentid, "title (" + title + ")"); + return nil; +} + +join(p: ref Member, cmd: string, susp: int): string +{ +sys->print("gather: %s[%d] joining '%s' (suspended: %d)\n", p.name, p.id, cmd, susp); + case cmd { + "join" => + if (started) { + if (!susp || !halted) + return "clique has already started"; + suspended = suspended.del(p.id); + if (suspended.eq(None)) { + halted = 0; + # XXX inform participants that clique is starting again + } + pset := None.add(p.id); + clique.action("clienttype " + cliquemod->clienttype(), nil, nil, pset); + clique.breakmsg(pset); + return nil; + } + for (inv := invited; inv != nil; inv = tl inv) + if (hd inv == p.name || hd inv == "all") + break; + if (inv == nil) + return "you have not been invited"; + if (nmembers >= cliquemod->maxmembers() || (count != -1 && nmembers >= count)) + return "too many members already"; + if (len clique.archive.members > 0) { + for (i := 0; i < len clique.archive.members; i++) + if (p.name == clique.archive.members[i]) + break; + if (i == len clique.archive.members) + return "you are not part of that clique"; + } + nmembers++; + members = members.add(p.id); + clique.notify(clique.parentid, "join " + p.name); + s := None.add(p.id); + # special case for single member cliques: don't need a gather client as we can start right now. + if (cliquemod->maxmembers() == 1) + return startclique(); + clique.action("clienttype gather", nil, nil, s); + clique.breakmsg(s); + clique.action("title " + title, nil, nil, s); + clique.action("join " + p.name, nil, nil, All); + "watch" => + if (susp) + return "you cannot watch if you are playing"; + watchers = watchers.add(p.id); + s := None.add(p.id); + if (started) + clique.action("clienttype " + cliquemod->clienttype(), nil, nil, s); + else + clique.action("clienttype gather", nil, nil, s); + clique.breakmsg(s); + if (!started) + clique.action("watch " + p.name, nil, nil, All); + * => + return "unknown join request"; + } + return nil; +} + +leave(p: ref Member): int +{ + if (members.holds(p.id)) { + if (started) { + suspended = suspended.add(p.id); + if (suspended.eq(members)) { + cliquemod->archive(); + name := spree->newarchivename(); + e := archives->write(clique, + ("title", concat(tl tl clique.archive.argv)) :: + ("date", string daytime->now()) :: nil, + name, members); + if (e != nil) + sys->print("warning: cannot archive clique: %s\n", e); + else + clique.notify(clique.parentid, "archived " + name); + clique.hangup(); + return 1; + } else { + halted = 1; + return 0; + } + } + + members = members.del(p.id); + nmembers--; + clique.notify(clique.parentid, "leave " + p.name); + if (nmembers == 0) + clique.hangup(); + } else { + watchers = watchers.del(p.id); + clique.action("unwatch " + p.name, nil, nil, All); + } + return 1; +} + +notify(nil: int, note: string) +{ + (n, toks) := sys->tokenize(note, " "); + case hd toks { + "invite" => + invited = hd tl toks :: invited; + "uninvite" => + inv := invited; + for (invited = nil; inv != nil; inv = tl inv) + if (hd inv != hd tl toks) + invited = hd inv :: invited; + * => + sys->print("gather: unknown notification '%s'\n", note); + } +} + +command(p: ref Member, cmd: string): string +{ + if (halted) + return "clique is halted for the time being"; + if (started) { + if (!members.holds(p.id)) { +sys->print("members (%s) doesn't hold %s[%d]\n", members.str(), p.name, p.id); + return "you are only watching"; + } + return cliquemod->command(p, cmd); + } + + (n, toks) := sys->tokenize(cmd, " \n"); + if (n == 0) + return "bad command"; + case hd toks { + "start" => + if (len clique.archive.members == 0 && p.name != clique.owner()) + return "only the owner can start a clique"; + if (count != -1 && nmembers != count) + return "need " + string count + " members"; + return startclique(); + "chat" => + clique.action("chat " + p.name + " " + concat(tl toks), nil, nil, All); + * => + return "unknown command"; + } + return nil; +} + +startclique(): string +{ + # XXX could randomly shuffle members here + + pa := array[nmembers] of ref Member; + names := array[nmembers] of string; + j := nmembers; + for (i := members.limit(); i >= 0; i--) + if (members.holds(i)) { + pa[--j] = clique.member(i); + names[j] = pa[j].name; + } + e := cliquemod->propose(names); + if (e != nil) + return e; + clique.action("clienttype " + cliquemod->clienttype(), nil, nil, All); + clique.breakmsg(All); + cliquemod->start(pa, len clique.archive.members > 0); + clique.start(); + started = 1; + clique.notify(clique.parentid, "started"); + clique.notify(clique.parentid, "title " + concat(tl tl clique.archive.argv)); + return nil; +} + +readfile(f: int, offset: big, n: int): array of byte +{ + if (!started) + return nil; + return cliquemod->readfile(f, offset, n); +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} diff --git a/appl/spree/engines/hearts.b b/appl/spree/engines/hearts.b new file mode 100644 index 00000000..759f07e2 --- /dev/null +++ b/appl/spree/engines/hearts.b @@ -0,0 +1,300 @@ +implement Engine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + dTOP, dLEFT, oLEFT, oRIGHT, EXPAND, FILLX, FILLY, Stackspec: import Cardlib; +include "tricks.m"; + tricks: Tricks; + Trick: import tricks; +clique: ref Clique; +CLICK, START, SAY: con iota; + +started := 0; + +buttons: ref Object; +scores: ref Object; +deck, pile: ref Object; +hands, taken, passon: array of ref Object; + +MINPLAYERS: con 2; +MAXPLAYERS: con 4; + +leader, turn: int; +trick: ref Trick; + +Trickpilespec := Stackspec( + "display", # style + 4, # maxcards + 0, # conceal + "trick pile" # title +); + +Handspec := Stackspec( + "display", + 13, + 1, + "" +); + +Passonspec := Stackspec( + "display", + 3, + 0, + "pass on" +); + +Takenspec := Stackspec( + "pile", + 52, + 0, + "tricks" +); + +clienttype(): string +{ + return "cards"; +} + +init(g: ref Clique, srvmod: Spree): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("hearts: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + allow->add(SAY, nil, "say &"); + + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("hearts: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + + tricks = load Tricks Tricks->PATH; + if (tricks == nil) { + sys->print("hearts: cannot load %s: %r\n", Tricks->PATH); + return "bad module"; + } + tricks->init(spree, clique, cardlib); + + deck = clique.newobject(nil, ~0, "stack"); + cardlib->makecards(deck, (0, 13), 1); + cardlib->shuffle(deck); + buttons = clique.newobject(nil, ~0, "buttons"); + scores = clique.newobject(nil, ~0, "scoretable"); + + return nil; +} + +join(p: ref Member): string +{ + sys->print("%s(%d) joining\n", p.name(), p.id); + if (!started && cardlib->nmembers() < MAXPLAYERS) { + (nil, err) := cardlib->join(p, -1); + if (err == nil) { + if (cardlib->nmembers() == MINPLAYERS) { + mkbutton("Start", "start"); + allow->add(START, nil, "start"); + } + } else + sys->print("error on join: %s\n", err); + } + return nil; +} + +leave(p: ref Member) +{ + cardlib->leave(p); + started == 0; + if (cardlib->nmembers() < MINPLAYERS) { + buttons.deletechildren((0, len buttons.children)); + allow->del(START, nil); + } +} + +command(p: ref Member, cmd: string): string +{ + e := ref Sys->Exception; + if (sys->rescue("parse:*", e) == Sys->EXCEPTION) { + sys->rescued(Sys->ONCE, nil); + return e.name[6:]; + } + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + ord := cardlib->order(p); + case tag { + START => + buttons.deletechildren((0, len buttons.children)); + allow->del(START, nil); + startclique(); + n := cardlib->nmembers(); + leader = rand(n); + starthand(); + titles := ""; + for (i := 0; i < n; i++) + titles += cardlib->info(i).p.name() + " "; + clique.newobject(scores, ~0, "score").setattr("score", titles, ~0); + + CLICK => + # click stackid index + hand := hands[ord]; + if (int hd tl toks != hand.id) + return "can't click there"; + index := int hd tl tl toks; + if (index < 0 || index >= len hand.children) + return "index out of range"; + cardlib->setsel(hands[ord], (index, len hands[ord].children), p); + break; + err := trick.play(cardlib->order(p), int hd tl toks); + if (err != nil) + return err; + + turn = next(turn); # clockwise + if (turn == leader) { # come full circle + winner := trick.winner; + inf := cardlib->info(winner); + remark(sys->sprint("%s won the trick", inf.p.name())); + cardlib->discard(pile, taken[winner], 0); + taken[winner].setattr("title", + string (len taken[winner].children / cardlib->nmembers()) + + " " + "tricks", ~0); + o := cardlib->info(winner).obj; + trick = nil; + s := ""; + for (i := 0; i < cardlib->nmembers(); i++) { + if (i == winner) + s += "1 "; + else + s += "0 "; + } + clique.newobject(scores, ~0, "score").setattr("score", s, ~0); + if (len hands[winner].children > 0) { + leader = turn = winner; + trick = Trick.new(pile, -1, hands); + } else { + remark("one round down, some to go"); + leader = turn = -1; # XXX this round over + } + } + canplay(turn); + SAY => + clique.action("say member " + string p.id + ": '" + joinwords(tl toks) + "'", nil, nil, ~0); + } + return nil; +} + +startclique() +{ + cardlib->startclique(); + entry := clique.newobject(nil, ~0, "widget entry"); + entry.setattr("command", "say", ~0); + cardlib->addlayobj("entry", nil, nil, dTOP|FILLX, entry); + cardlib->addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + cardlib->maketable("arena"); + + pile = cardlib->newstack(nil, nil, Trickpilespec); + cardlib->addlayobj(nil, "public", nil, dTOP|oLEFT, pile); + n := cardlib->nmembers(); + hands = array[n] of ref Object; + taken = array[n] of ref Object; + passon = array[n] of ref Object; + tt := clique.newobject(nil, ~0, "widget menu"); + tt.setattr("text", "hello", ~0); + for (ml := "one" :: "two" :: "three" :: nil; ml != nil; ml = tl ml) { + o := clique.newobject(tt, ~0, "menuentry"); + o.setattr("text", hd ml, ~0); + o.setattr("command", hd ml, ~0); + } + for (i := 0; i < n; i++) { + inf := cardlib->info(i); + hands[i] = cardlib->newstack(inf.obj, inf.p, Handspec); + taken[i] = cardlib->newstack(inf.obj, inf.p, Takenspec); + passon[i] = cardlib->newstack(inf.obj, inf.p, Passonspec); + p := "p" + string i; + cardlib->addlayframe(p + ".f", p, nil, dLEFT|oLEFT, dTOP); + cardlib->addlayobj(nil, p + ".f", inf.layout, dTOP, tt); + cardlib->addlayobj(nil, p + ".f", nil, dTOP|oLEFT, hands[i]); + cardlib->addlayobj(nil, p, nil, dLEFT|oLEFT, taken[i]); + cardlib->addlayobj(nil, p, nil, dLEFT|oLEFT, passon[i]); + } +} + +joinwords(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; +} + +starthand() +{ + cardlib->deal(deck, 13, hands, 0); + trick = Trick.new(pile, -1, hands); + turn = leader; + canplay(turn); +} + +canplay(ord: int) +{ + allow->del(CLICK, nil); + for (i := 0; i < cardlib->nmembers(); i++) { + inf := cardlib->info(i); + inf.obj.setattr("status", nil, 1<<inf.p.id); + hands[i].setattr("actions", nil, 1<<inf.p.id); + } + if (ord != -1) { + allow->add(CLICK, member(ord), "click %o %d"); + inf := cardlib->info(ord); + inf.obj.setattr("status", "It's your turn to play", 1<<inf.p.id); + hands[ord].setattr("actions", "click", 1<<inf.p.id); + } +} + +memberobj(p: ref Member): ref Object +{ + return cardlib->info(cardlib->order(p)).obj; +} + +member(ord: int): ref Member +{ + return cardlib->info(ord).p; +} + +next(i: int): int +{ + i++; + if (i >= cardlib->nmembers()) + i = 0; + return i; +} + +remark(s: string) +{ + clique.action("remark " + s, nil, nil, ~0); +} + +mkbutton(text, cmd: string): ref Object +{ + but := clique.newobject(buttons, ~0, "button"); + but.setattr("text", text, ~0); + but.setattr("command", cmd, ~0); + return but; +} diff --git a/appl/spree/engines/liars.b b/appl/spree/engines/liars.b new file mode 100644 index 00000000..488e993b --- /dev/null +++ b/appl/spree/engines/liars.b @@ -0,0 +1,490 @@ +implement Engine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; + +MAXPLAYERS: con 32; + +clique: ref Clique; + +# each member is described by a state machine. +# a member progresses through the following states: +# +# Notplaying +# istart -> Havedice +# otherstarts -> Waiting +# Havedice +# declare -> Waiting +# look -> Looking +# Looking +# expose -> Looking +# unexpose -> Looking +# declare -> Waiting +# roll -> Rolled +# Rolled +# expose -> Rolled +# unexpose -> Rolled +# declare -> Waiting +# Waiting +# queried -> Queried +# lost -> Havedice +# Queried +# reject,win -> Waiting +# reject,lose -> Havedice +# accept -> Havedice + + +plate, cup, space, members: ref Object; +dice := array[5] of ref Object; + +declared: int; + +# member states +Notplaying, Havedice, Looking, Rolled, Waiting, Queried: con iota; + +# info on a particular member +Info: adt { + state: int; + id: int; + member: ref Object; + action: ref Object; +}; + +info := array[MAXPLAYERS] of ref Info; +plorder := array[MAXPLAYERS] of int; # map member id to their place around the table +nplaying := 0; +nmembers := 0; +turn := 0; + +clienttype(): string +{ + return "none"; +} + +init(g: ref Clique, srvmod: Spree): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + plate = clique.newobject(nil, ~0, "plate"); + cup = clique.newobject(plate, 0, "cup"); + space = clique.newobject(plate, ~0, "space"); + members = clique.newobject(nil, ~0, "members"); + + for (i := 0; i < len dice; i++) { + dice[i] = clique.newobject(cup, ~0, "die"); + dice[i].setattr("number", string rand(6), ~0); + } + + return nil; +} + +join(member: ref Member): string +{ + check(); + pmask := 1 << member.id; + + ord := nmembers++; + inf := info[ord] = ref Info; + inf.state = -1; + inf.id = member.id; + inf.action = clique.newobject(nil, pmask, "actions" + string member.id); + plorder[member.id] = ord; + setstate(ord, Notplaying); + check(); + return nil; +} + +leave(member: ref Member) +{ + check(); + + ord := plorder[member.id]; + state := info[ord].state; + info[ord] = nil; + for (i := 0; i < nmembers; i++) + if (i != ord) + setstate(i, Notplaying); + nmembers--; + nplaying = 0; + clique.action("say member " + string ord + " has left. the clique stops.", nil, nil, ~0); + check(); +} + +currmember: ref Member; +currcmd: string; +command(member: ref Member, cmd: string): string +{ + check(); + e := ref Sys->Exception; + if (sys->rescue("parse:*", e) == Sys->EXCEPTION) { + sys->rescued(Sys->ONCE, nil); + check(); + currmember = nil; + currcmd = nil; + return e.name[6:]; + } + currmember = member; + currcmd = cmd; + (nlines, lines) := sys->tokenize(cmd, "\n"); + assert(nlines > 0, "unknown command"); + (n, toks) := sys->tokenize(hd lines, " "); + assert(n > 0, "unknown command"); + pmask := 1 << member.id; + ord := plorder[member.id]; + state := info[ord].state; + case hd toks { + "say" or + "show" or + "showme" => + case hd toks { + "say" => + clique.action("say member " + string member.id + ": '" + (hd lines)[4:] + "'", nil, nil, ~0); + "show" => # show [memberid] + p: ref Member = nil; + if (n == 2) { + memberid := int hd tl toks; + p = clique.member(memberid); + assert(p != nil, "bad memberid"); + } + clique.show(p); + "showme" => + clique.show(member); + } + currmember = nil; + currcmd = nil; + return nil; + } + case state { + Notplaying => + case hd toks { + "start" => + assert(nplaying == 0, "clique is in progress"); + assert(nmembers > 1, "need at least two members"); + newinfo := array[len info] of ref Info; + members.deletechildren((0, len members.children)); + j := 0; + for (i := 0; i < len info; i++) + if (info[i] != nil) + newinfo[j++] = info[i]; + info = newinfo; + nplaying = nmembers; + for (i = 0; i < nplaying; i++) { + info[i].member = clique.newobject(members, ~0, nil); + info[i].member.setattr("id", string info[i].id, ~0); + } + turn = rand(nplaying); + start(); + * => + assert(0, "you are not playing"); + } + Havedice => + case hd toks { + "declare" => + # declare hand + declare(ord, tl toks); + "look" => + cup.setattr("raised", "1", ~0); + cup.setvisibility(pmask); + setstate(ord, Looking); + * => + assert(0, "bad command"); + } + Looking => + case hd toks { + "expose" or + "unexpose" => + expose(n, toks); + "declare" => + declare(ord, tl toks); + "roll" => + # roll index... + # XXX should be able to roll in the open too + for (toks = tl toks; toks != nil; toks = tl toks) { + index := int hd toks; + checkrange((index, index), cup); + cup.children[index].setattr("number", string rand(6), ~0); + } + setstate(ord, Rolled); + * => + assert(0, "bad command"); + } + Rolled => + case hd toks { + "expose" or + "unexpose" => + expose(n, toks); + "declare" => + declare(ord, tl toks); + * => + assert(0, "bad command"); + } + Waiting => + assert(0, "not your turn"); + Queried => + case hd toks { + "reject" => + # lift the cup! + cup.transfer((0, len cup.children), space, len space.children); + assert(len space.children == 5, "lost a die somewhere!"); + dvals := array[5] of int; + for (i := 0; i < 5; i++) + dvals[i] = int space.children[i].getattr("number"); + actval := value(dvals); + if (actval >= declared) { + # declaration was correct; rejector loses + clique.action("say member " + string ord + " loses.", nil, nil, ~0); + turn = ord; + start(); + } else { + # liar caught out. rejector wins. + clique.action("say member " + string turn + " was lying...", nil, nil, ~0); + start(); + } + "accept" => + # dice accepted, turn moves on + # XXX should allow for anticlockwise play + newturn := (turn + 1) % nplaying; + plate.setattr("owner", string newturn, ~0); + setstate(ord, Havedice); + setstate(turn, Waiting); + } + } + check(); + currmember = nil; + currcmd = nil; + return nil; +} + +expose(n: int, toks: list of string) +{ + # (un)expose index + assert(n == 2, Eusage); + (src, dest) := (cup, space); + if (hd toks == "unexpose") + (src, dest) = (space, cup); + index := int hd tl toks; + checkrange((index, index+1), cup); + src.transfer((index, index+1), dest, len dest.children); +} + +start() +{ + clique.action("start", nil, nil, ~0); + space.transfer((0, len space.children), cup, len cup.children); + cup.setvisibility(0); + for (i := 0; i < len dice; i++) + dice[i].setattr("number", string rand(6), ~0); + + plate.setattr("owner", string turn, ~0); + for (i = 0; i < nplaying; i++) { + if (i == turn) + setstate(i, Havedice); + else + setstate(i, Waiting); + } + declared = 0; +} + +declare(ord: int, toks: list of string) +{ + cup.setvisibility(0); + assert(len toks == 1 && len hd toks == 5, "bad declaration"); + d := hd toks; + v := array[5] of {* => 0}; + for (i := 0; i < 5; i++) { + v[i] = (hd toks)[i] - '0'; + assert(v[i] >= 0 && v[i] <= 5, "bad declaration"); + } + newval := value(v); + assert(newval > declared, "declaration not high enough"); + declared = newval; + + setstate(turn, Waiting); + setstate((turn + 1) % nplaying, Queried); +} + +# check that range is valid for object's children +checkrange(r: Range, o: ref Object) +{ + assert(r.start >= 0 && r.start < len o.children && + r.end >= r.start && r.end >= 0 && + r.end <= len o.children, + "index out of range"); +} + +setstate(ord: int, state: int) +{ + poss: string; + case state { + Notplaying => + poss = "start"; + Havedice => + poss = "declare look"; + Looking => + poss = "expose unexpose declare roll"; + Rolled => + poss = "expose unexpose declare"; + Waiting => + poss = ""; + Queried => + poss = "accept reject"; + * => + sys->print("liarclique: unknown state %d, member %d\n", state, ord); + sys->raise("panic"); + } + info[ord].action.setattr("actions", poss, 1<<info[ord].id); + info[ord].state = state; +} + +obj(ext: int): ref Object +{ + assert((o := currmember.obj(ext)) != nil, "bad object"); + return o; +} + +Eusage: con "bad command usage"; + +assert(b: int, err: string) +{ + if (b == 0) { + sys->print("cardclique: error '%s' on %s", err, currcmd); + sys->raise("parse:" + err); + } +} + +checkobj(o: ref Object, what: string) +{ + if (o != nil && o.id == -1) { + clique.show(currmember); + sys->print("object %d has been deleted unexpectedly (%s)\n", o.id, what); + sys->raise("panic"); + } +} + +check() +{ +} + +NOTHING, PAIR, TWOPAIRS, THREES, LOWSTRAIGHT, +FULLHOUSE, HIGHSTRAIGHT, FOURS, FIVES: con iota; + +what := array[] of { +NOTHING => "nothing", +PAIR => "pair", +TWOPAIRS => "twopairs", +THREES => "threes", +LOWSTRAIGHT => "lowstraight", +FULLHOUSE => "fullhouse", +HIGHSTRAIGHT => "highstraight", +FOURS => "fours", +FIVES => "fives" +}; + +same(dice: array of int): int +{ + x := dice[0]; + for (i := 0; i < len dice; i++) + if (dice[i] != x) + return 0; + return 1; +} + +val(hi, lo: int): int +{ + return hi * 100000 + lo; +} + +D: con 10; + +value(dice: array of int): int +{ + mergesort(dice, array[5] of int); + + for (i := 0; i < 5; i++) + sys->print("%d ", dice[i]); + sys->print("\n"); + + # five of a kind + x := dice[0]; + if (same(dice)) + return val(FIVES, dice[0]); + + # four of a kind + if (same(dice[1:])) + return val(FOURS, dice[0] + dice[1]*D); + if (same(dice[0:4])) + return val(FOURS, dice[4] + dice[0]*D); + + # high straight + if (dice[0] == 1 && dice[1] == 2 && dice[2] == 3 && + dice[3] == 4 && dice[4] == 5) + return val(HIGHSTRAIGHT, 0); + + # full house + if (same(dice[0:3]) && same(dice[3:5])) + return val(FULLHOUSE, dice[0]*D + dice[4]); + if (same(dice[0:2]) && same(dice[2:5])) + return val(FULLHOUSE, dice[4]*D + dice[0]); + + # low straight + if (dice[0] == 0 && dice[1] == 1 && dice[2] == 2 && + dice[3] == 3 && dice[4] == 4) + return val(LOWSTRAIGHT, 0); + # three of a kind + if (same(dice[0:3])) + return val(THREES, dice[3] + dice[4]*D + dice[0]*D*D); + if (same(dice[1:4])) + return val(THREES, dice[0] + dice[4]*D + dice[1]*D*D); + if (same(dice[2:5])) + return val(THREES, dice[0] + dice[1]*D + dice[2]*D*D); + + for (i = 0; i < 4; i++) + if (same(dice[i:i+2])) + break; + case i { + 4 => + return val(NOTHING, dice[0] + dice[1]*D + dice[2]*D*D + + dice[3]*D*D*D + dice[4]*D*D*D*D); + 3 => + return val(PAIR, dice[0] + dice[1]*D + dice[2]*D*D + dice[3]*D*D*D); + 2 => + return val(PAIR, dice[0] + dice[1]*D + dice[4]*D*D + dice[2]*D*D*D); + } + h := array[5] of int; + h[0:] = dice; + if (i == 1) + (h[0], h[2]) = (h[2], h[0]); + # pair is in first two dice + if (same(h[2:4])) + return val(TWOPAIRS, h[4] + h[2]*D + h[0]*D*D); + if (same(h[3:5])) + return val(TWOPAIRS, h[2] + h[0]*D + h[4]*D*D); + return val(PAIR, dice[2] + dice[3]*D + dice[4]*D*D + dice[0]*D*D*D); +} + +mergesort(a, b: array of int) +{ + r := len a; + if (r > 1) { + m := (r-1)/2 + 1; + mergesort(a[0:m], b[0:m]); + mergesort(a[m:], b[m:]); + b[0:] = a; + for ((i, j, k) := (0, m, 0); i < m && j < r; k++) { + if (b[i] > b[j]) + 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]; + } +} diff --git a/appl/spree/engines/liars.y b/appl/spree/engines/liars.y new file mode 100644 index 00000000..1e191076 --- /dev/null +++ b/appl/spree/engines/liars.y @@ -0,0 +1,132 @@ +%{ + + +YYSTYPE: adt { +}; + +YYLEX: adt { + lval: YYSTYPE; + lex: fn(l: self ref YYLEX): int; + error: fn(l: self ref YYLEX, err: string); + toks: list of string; +}; +%} + +%module Sh { + # module definition is in shell.m +} +%token A ALL AND BROKEN FIVE FOUR FUCK FULL HIGH +%token HOUSE KIND LOW NOTHING OF ON PAIR PAIRS STRAIGHT THREE TWO VALUE + +%start phrase +%% +phrase: nothing + | pair + | twopairs + | threes + | lowstraight + | fullhouse + | highstraight + | fours + | fives + +pair: PAIR + | PAIR ofsomething ',' extras + +nothing: NOTHING + | BROKEN STRAIGHT + | FUCK ALL + +twopairs: TWO PAIRS moretuppers + | TWO VALUE optcomma TWO VALUE and_a VALUE + | PAIR OF VALUE ',' PAIR OF VALUE and_a VALUE + +moretuppers: + | ',' VALUE ',' VALUE and_a VALUE + +threes: THREE OF A KIND extras + | THREE VALUE extras + +lowstraight: LOW STRAIGHT + +fullhouse: FULL HOUSE + | FULL HOUSE optcomma VALUE + | FULL HOUSE optcomma VALUE ON VALUE + | FULL HOUSE optcomma VALUE HIGH + +highstraight: HIGH STRAIGHT + +fours: FOUR OF A KIND extras + | FOUR VALUE extras + +fives: FIVE OF A KIND + | FIVE VALUE +and_a: # null + | AND A +optcomma: + | ',' +extras: VALUE + | extras VALUE +%% + +Tok: adt { + s: string; + tok: int; + val: int; +}; + +known := array of { +Tok("an", A, -1), +Tok("a", A, -1), +Tok("all", ALL, -1), +Tok("and", AND, -1), +Tok("broken", BROKEN, -1), +Tok(",", ',', -1), +Tok("five", FIVE, -1), +Tok("5", FIVE, -1), +Tok("four", FOUR, -1), +Tok("4", FOUR, -1), +Tok("fuck", FUCK, -1), +Tok("full", FULL, -1), +Tok("high", HIGH, -1), +Tok("house", HOUSE, -1), +Tok("kind", KIND, -1), +Tok("low", LOW, -1), +Tok("nothing", NOTHING, -1), +Tok("of", OF, -1), +Tok("on", ON, -1), +Tok("pair", PAIR, -1), +Tok("pairs", PAIRS, -1), +Tok("straight", STRAIGHT, -1), +Tok("three", THREE, -1), +Tok("3", THREE, -1), +Tok("two", TWO, -1), +Tok("2", TWO, -1), + +Tok("A", VALUE, 5), +Tok("K", VALUE, 4), +Tok("Q", VALUE, 3), +Tok("J", VALUE, 2), +Tok("10", VALUE, 1), +Tok("9", VALUE, 0), + +Tok("ace" +}; + +YYLEX.lex(l: self ref YYLEX): int +{ + if (l.toks == nil) + return -1; + t := hd l.toks; + for (i := 0; i < len known; i++) { + if (known[i].t0 == t) + return known[i].t1; + + case hd l.toks { + + +%token A ALL AND BROKEN FIVE FOUR FUCK FULL HIGH +%token HOUSE KIND LOW NOTHING OF ON PAIR PAIRS STRAIGHT THREE TWO VALUE +%token END + +}
\ No newline at end of file diff --git a/appl/spree/engines/lobby.b b/appl/spree/engines/lobby.b new file mode 100644 index 00000000..119922e2 --- /dev/null +++ b/appl/spree/engines/lobby.b @@ -0,0 +1,389 @@ +implement Engine; + +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; + archives: Archives; + Archive: import Archives; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "readdir.m"; + readdir: Readdir; + +# what the lobby provides: +# a list of cliques it's started +# name of clique +# current members +# list of members inside the lobby. +# name +# invites +# how does a gather engine know who's been invited? +# as the lobby's the only place with the knowledge of who's around to invite. +# could allow lobby to communicate with the cliques it's started... +# but clique also needs to communicate with the lobby +# (e.g. to say clique has started, no more invites necessary or allowed) +# +# list of available engines +# title +# clienttype(s?) +# +# understands commands: +# chat message +# invite +# new name params +# +# question: how do we know about archives? +# answer: maybe we don't... could have another module +# that does, or maybe an option to gather ("gather unarchive"?) +# +# the one that's started the clique is always invited. +# start clique. +# clique says to parent "invite x, y and z" (perhaps they were in the archive) +# how should we deal with recursive invocation? +# could queue up requests to other clique engines, +# and deliver them after the current request has been processed. +# no return available (one way channel) but maybe that's good, +# as if sometime in the future engines do run in parallel, we will +# need to avoid deadlock. +# Clique.notify(clique: self ref Clique, cliqueid: int, note: string); +# when a request has been completed, we run notify requests +# for all the cliques that have been notified, and repeat +# until no more. (could keep a count to check for infinite loop). +# don't allow communication between unrelated cliques. + +clique: ref Clique; + +members: ref Object; +sessions: ref Object; +available: ref Object; +archiveobj: ref Object; + +ARCHIVEDIR: con "./archive"; + +init(srvmod: Spree, g: ref Clique, nil: list of string): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("lobby: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + readdir = load Readdir Readdir->PATH; + if (readdir == nil) { + sys->print("lobby: cannot load %s: %r\n", Readdir->PATH); + return "bad module"; + } + archives = load Archives Archives->PATH; + if (archives == nil) { + sys->print("lobby: cannot load %s: %r\n", Archives->PATH); + return "bad module"; + } + archives->init(srvmod); + members = clique.newobject(nil, All, "members"); + sessions = clique.newobject(nil, All, "sessions"); + available = clique.newobject(nil, All, "available"); + o := clique.newobject(available, All, "sessiontype"); + o.setattr("name", "freecell", All); + o.setattr("title", "Freecell", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 1 freecell", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Lobby", All); + o.setattr("name", "lobby", All); + o.setattr("clienttype", "lobby", All); + o.setattr("start", "lobby", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Spit", All); + o.setattr("name", "spit", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 2 spit", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Canfield", All); + o.setattr("name", "canfield", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 1 canfield", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Afghan", All); + o.setattr("name", "afghan", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 1 afghan", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Spider", All); + o.setattr("name", "spider", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 1 spider", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Racing Demon", All); + o.setattr("name", "racingdemon", All); + o.setattr("clienttype", "cards", All); + o.setattr("start", "gather 3 racingdemon", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Othello", All); + o.setattr("name", "othello", All); + o.setattr("clienttype", "othello", All); + o.setattr("start", "gather 2 othello", All); + + o = clique.newobject(available, All, "sessiontype"); + o.setattr("title", "Whist", All); + o.setattr("name", "whist", All); + o.setattr("clienttype", "whist", All); + o.setattr("start", "gather 4 whist", All); + + getarchives(); + + clique.start(); + + return nil; +} + +join(p: ref Member, cmd: string, nil: int): string +{ + sys->print("%s joins '%s'\n", p.name, cmd); + clique.notify(clique.parentid, "join " + p.name); + s := None.add(p.id); + clique.action("clienttype lobby", nil, nil, s); + clique.breakmsg(s); + clique.action("name " + p.name, nil, nil, s); + o := clique.newobject(members, All, "member"); + o.setattr("name", p.name, All); + return nil; +} + +leave(p: ref Member): int +{ + clique.notify(clique.parentid, "leave " + p.name); + deletename(members, p.name, "member"); + sys->print("%s leaves\n", p.name); + return 1; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +command(p: ref Member, cmd: string): string +{ + sys->print("%s: '%s'\n", p.name, cmd); + (n, toks) := sys->tokenize(cmd, " \n"); + if (n == 0) + return "bad command"; + case hd toks { + "kick" => + getarchives(); + return nil; + "chat" => + clique.action("chat " + p.name + " " + concat(tl toks), nil, nil, All); + return nil; + "start" => + # start engine [params] + if (n >= 2) { + (gid, fname, err) := clique.new( + ref Archive(tl toks, nil, nil, nil), + p.name); + if (gid == -1) + return err; + s := addname(sessions, string gid, "session"); + s.setattr("title", concat(tl toks), All); + s.setattr("filename", fname, All); + s.setattr("cliqueid", string gid, None); + s.setattr("owner", p.name, All); + return nil; + } + return "bad start params"; + "invite" or + "uninvite"=> + # invite sessionid name + if (n == 3) { + (what, sessionid, name) := (hd toks, int hd tl toks, hd tl tl toks); + if ((s := p.obj(sessionid)) == nil) + return "bad object id"; + if (s.objtype != "session") + return "bad session type " + s.objtype; + if (s.getattr("owner") != p.name) + return "permission denied"; + clique.notify(int s.getattr("cliqueid"), what + " " + name); + if (hd toks == "invite") + addname(s, name, "invite"); + else + deletename(s, name, "invite"); + return nil; + } + return "bad invite params"; + "unarchive" => + # unarchive object + if (n == 2) { + o := p.obj(int hd tl toks); + if (o == nil || o.objtype != "archive") + return "bad archive object"; + # archive object contains: + # name name of clique + # members members of the clique + # file filename of archive + + aname := o.getattr("file"); + (archive, err) := archives->read(aname); + if (archive == nil) + return sys->sprint("cannot load archive: %s", err); + for (i := 0; i < len archive.members; i++) + if (p.name == archive.members[i]) + break; + if (i == len archive.members) + return "you did not participate in that session"; + (gid, fname, err2) := clique.new(archive, p.name); + if (gid == -1) + return err2; + s := addname(sessions, string gid, "session"); + s.setattr("title", concat(archive.argv), All); + s.setattr("filename", fname, All); + s.setattr("cliqueid", string gid, None); + s.setattr("owner", p.name, All); + + o.delete(); + (ok, d) := sys->stat(aname); + if (ok != -1) { + d.name += ".old"; + sys->wstat(aname, d); + } + # XXX delete old archive file? + return nil; + } + return "bad unarchive params"; + * => + return "bad command"; + } +} + +notify(srcid: int, note: string) +{ + sys->print("lobby: note from %d: %s\n", srcid, note); + s := findname(sessions, string srcid); + if (s == nil) { + sys->print("cannot find srcid %d\n", srcid); + return; + } + if (note == nil) { + s.delete(); + return; + } + if (srcid == clique.parentid) + return; + (n, toks) := sys->tokenize(note, " "); + case hd toks { + "join" => + p := addname(s, hd tl toks, "member"); + "leave" => + deletename(s, hd tl toks, "member"); + "invite" => + addname(s, hd tl toks, "invite"); + "uninvite" => + deletename(s, hd tl toks, "invite"); + "title" => + s.setattr("title", concat(tl toks), All); + "archived" => + # archived filename + arch := clique.newobject(archiveobj, All, "archive"); + arch.setattr("name", s.getattr("title"), All); + pnames := ""; + for (i := 0; i < len s.children; i++) + if (s.children[i].objtype == "member") + pnames += " " + s.children[i].getattr("name"); + if (pnames != nil) + pnames = pnames[1:]; + arch.setattr("members", pnames, All); + arch.setattr("file", hd tl toks, None); + * => + sys->print("unknown note from %d: %s\n", srcid, note); + } +} + +addname(o: ref Object, name: string, otype: string): ref Object +{ + x := clique.newobject(o, All, otype); + x.setattr("name", name, All); + return x; +} + +findname(o: ref Object, name: string): ref Object +{ + c := o.children; + for (i := 0; i < len c; i++) + if (c[i].getattr("name") == name) + return c[i]; + return nil; +} + +deletename(o: ref Object, name: string, objtype: string) +{ + c := o.children; + for (i := 0; i < len c; i++) + if (c[i].objtype == objtype && c[i].getattr("name") == name) { + o.deletechildren((i, i+1)); + break; + } +} + +getarchives() +{ + if (archiveobj == nil) + archiveobj = clique.newobject(nil, All, "archives"); + else + archiveobj.deletechildren((0, len archiveobj.children)); + for (names := spree->archivenames(); names != nil; names = tl names) { + fname := hd names; + (a, err) := archives->readheader(fname); + if (a == nil) { + sys->print("lobby: cannot read archive header on %s: %s\n", fname, err); + continue; + } + title := ""; + for (inf := a.info; inf != nil; inf = tl inf) { + if ((hd inf).t0 == "title") { + title = (hd inf).t1; + break; + } + } + if (title == nil) + title = concat(a.argv); + arch := clique.newobject(archiveobj, All, "archive"); + arch.setattr("name", title, All); + arch.setattr("members", concatarray(a.members), All); + arch.setattr("file", fname, None); + j := 0; + for (info := a.info; info != nil; info = tl info) + arch.setattr("info" + string j++, (hd info).t0 + " " + (hd info).t1, All); + } +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} + +concatarray(a: array of string): string +{ + if (len a == 0) + return nil; + s := a[0]; + for (i := 1; i < len a; i++) + s += " " + a[i]; + return s; +} diff --git a/appl/spree/engines/othello.b b/appl/spree/engines/othello.b new file mode 100644 index 00000000..2f36c47b --- /dev/null +++ b/appl/spree/engines/othello.b @@ -0,0 +1,242 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + All, None: import Sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member: import spree; +include "objstore.m"; + objstore: Objstore; +include "../gather.m"; + +clique: ref Clique; + +Black, White, Nocolour: con iota; # first two must be 0 and 1. +N: con 8; + +boardobj: ref Object; +board: array of array of int; +pieces: array of int; +turn := Nocolour; +members := array[2] of ref Member; # member ids of those playing + +Point: adt { + x, y: int; + add: fn(p: self Point, p1: Point): Point; + inboard: fn(p: self Point): int; +}; + +clienttype(): string +{ + return "othello"; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + objstore = load Objstore Objstore->PATH; + if (objstore == nil) { + sys->print("othello: cannot load %s: %r", Objstore->PATH); + return "bad module"; + } + objstore->init(srvmod, g); + + return nil; +} + +maxmembers(): int +{ + return 2; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +propose(members: array of string): string +{ + if (len members != 2) + return "need exactly two members"; + return nil; +} + +archive() +{ + objstore->setname(boardobj, "board"); +} + +start(pl: array of ref Member, archived: int) +{ + members = pl; + board = array[N] of {* => array[N] of {* => Nocolour}}; + pieces = array[2] of {* => 0}; + if (archived) { + objstore->unarchive(); + boardobj = objstore->get("board"); + for (i := 0; i < N; i++) { + for (j := 0; j < N; j++) { + a := boardobj.getattr(pt2attr((j, i))); + if (a != nil) { + piece := int a; + board[j][i] = piece; + if (piece != Nocolour) + pieces[piece]++; + } + } + } + turn = int boardobj.getattr("turn"); + } else { + boardobj = clique.newobject(nil, All, nil); + boardobj.setattr("members", string members[Black].name + " " + string members[White].name, All); + for (ps := (Black, (3, 3)) :: (Black, (4, 4)) :: (White, (3, 4)) :: (White, Point(4, 3)) :: nil; + ps != nil; + ps = tl ps) { + (colour, p) := hd ps; + setpiece(colour, p); + } + turn = Black; + boardobj.setattr("turn", string Black, All); + } +} + +cliqueover() +{ + turn = Nocolour; + boardobj.setattr("winner", string winner(), All); + boardobj.setattr("turn", string turn, All); +} + +command(member: ref Member, cmd: string): string +{ + { + (n, toks) := sys->tokenize(cmd, " \n"); + assert(n > 0, "unknown command"); + + case hd toks { + "move" => + assert(n == 3, "bad command usage"); + assert(turn != Nocolour, "clique has finished"); + assert(member == members[White] || member == members[Black], "you are not playing"); + assert(member == members[turn], "it is not your turn"); + p := Point(int hd tl toks, int hd tl tl toks); + assert(p.x >= 0 && p.x < N && p.y >= 0 && p.y < N, "invalid move position"); + assert(board[p.x][p.y] == Nocolour, "position is already occupied"); + assert(newmove(turn, p, 1), "cannot move there"); + + turn = reverse(turn); + if (!canplay()) { + turn = reverse(turn); + if (!canplay()) + cliqueover(); + } + boardobj.setattr("turn", string turn, All); + return nil; + } + sys->print("othello: unknown client command '%s'\n", hd toks); + return "who knows"; + } exception e { + "parse:*" => + return e[6:]; + } +} + +Directions := array[] of {Point(0, 1), (1, 1), (1, 0), (1, -1), (0, -1), (-1, -1), (-1, 0), (-1, 1)}; + +setpiece(colour: int, p: Point) +{ + v := board[p.x][p.y]; + if (v != Nocolour) + pieces[v]--; + board[p.x][p.y] = colour; + pieces[colour]++; + boardobj.setattr(pt2attr(p), string colour, All); +} + +pt2attr(pt: Point): string +{ + s := " "; + s[0] = pt.x + 'a'; + s[1] = pt.y + 'a'; + return s; +} + +# member colour has tried to place a piece at mp. +# return -1 if it's an illegal move, 0 otherwise. +# (in which case appropriate updates are sent out all round). +# if update is 0, just check for the move's validity +# (no change to the board, no updates sent) +newmove(colour: int, mp: Point, update: int): int +{ + totchanged := 0; + for (i := 0; i < len Directions; i++) { + d := Directions[i]; + n := 0; + for (p := mp.add(d); p.inboard(); p = p.add(d)) { + n++; + if (board[p.x][p.y] == colour || board[p.x][p.y] == Nocolour) + break; + } + if (p.inboard() && board[p.x][p.y] == colour && n > 1) { + if (!update) + return 1; + totchanged += n - 1; + for (p = mp.add(d); --n > 0; p = p.add(d)) + setpiece(reverse(board[p.x][p.y]), p); + } + } + if (totchanged > 0) { + setpiece(colour, mp); + return 1; + } + return 0; +} + +# who has most pieces? +winner(): int +{ + if (pieces[White] > pieces[Black]) + return White; + else if (pieces[Black] > pieces[White]) + return Black; + return Nocolour; +} + +# is there any possible legal move? +canplay(): int +{ + for (y := 0; y < N; y++) + for (x := 0; x < N; x++) + if (board[x][y] == Nocolour && newmove(turn, (x, y), 0)) + return 1; + return 0; +} + +reverse(colour: int): int +{ + if (colour == Nocolour) + return Nocolour; + return !colour; +} + +Point.add(p: self Point, p1: Point): Point +{ + return (p.x + p1.x, p.y + p1.y); +} + +Point.inboard(p: self Point): int +{ + return p.x >= 0 && p.x < N && p.y >= 0 && p.y < N; +} + +assert(b: int, err: string) +{ + if (b == 0) + raise "parse:" + err; +} diff --git a/appl/spree/engines/racingdemon.b b/appl/spree/engines/racingdemon.b new file mode 100644 index 00000000..f839e29a --- /dev/null +++ b/appl/spree/engines/racingdemon.b @@ -0,0 +1,464 @@ +implement Gatherengine; + +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 "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember, Card: import cardlib; + dTOP, dLEFT, oDOWN, EXPAND, FILLX, FILLY, aCENTRELEFT, Stackspec: import Cardlib; +include "../gather.m"; + +clique: ref Clique; + +CLICK, SAY, SHOW: con iota; +KING: con 12; +NACES: con 7; # number of ace piles to fit across the board. + +Dmember: adt { + pile, + spare1, + spare2: ref Object; + open: array of ref Object; # [4] + acepiles: array of ref Object; +}; +scores: array of int; +scorelabel: ref Object; + +dmembers: array of ref Dmember; + +Openspec := Stackspec( + "display", # style + 4, # maxcards + 0, # conceal + "" # title +); + +Pilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "pile" # title +); + +Untitledpilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "" # title +); + +clienttype(): string +{ + return "cards"; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("whist: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + sets->init(); + + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + + return nil; +} + +maxmembers(): int +{ + return 100; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +propose(members: array of string): string +{ + if (len members < 3) + return "need at least 3 members"; + return nil; +} + +archive() +{ + archiveobj := cardlib->archive(); + allow->archive(archiveobj); + for (i := 0; i < len dmembers; i++) { + dp := dmembers[i]; + s := "d" + string i + "_"; + cardlib->setarchivename(dp.spare1, s + "spare1"); + cardlib->setarchivename(dp.spare2, s + "spare2"); + cardlib->setarchivename(dp.pile, s + "pile"); + cardlib->archivearray(dp.open, s + "open"); + cardlib->archivearray(dp.acepiles, s + "acepiles"); + } + cardlib->setarchivename(scorelabel, "scorelabel"); + s := ""; + for (i = 0; i < len scores; i++) + s += " " + string scores[i]; + archiveobj.setattr("scores", s, None); + +} + +start(members: array of ref Member, archived: int) +{ + if (archived) { + archiveobj := cardlib->unarchive(); + allow->unarchive(archiveobj); + dmembers = array[len members] of ref Dmember; + for (i := 0; i < len dmembers; i++) { + dp := dmembers[i] = ref Dmember; + s := "d" + string i + "_"; + dp.spare1 = cardlib->getarchiveobj(s + "spare1"); + dp.spare2 = cardlib->getarchiveobj(s + "spare2"); + dp.pile = cardlib->getarchiveobj(s + "pile"); + dp.open = cardlib->getarchivearray(s + "open"); + dp.acepiles = cardlib->getarchivearray(s + "acepiles"); + } + scorelabel = cardlib->getarchiveobj("scorelabel"); + s := archiveobj.getattr("scores"); + (n, toks) := sys->tokenize(s, " "); + scores = array[len members] of int; + for (i = 0; toks != nil; toks = tl toks) + scores[i++] = int hd toks; + } else { + pset := None; + for (i := 0; i < len members; i++) { + p := members[i]; + Cmember.join(p, i); + pset = pset.add(p.id); + allow->add(CLICK, p, "click %o %d"); + } + Cmember.index(0).layout.lay.setvisibility(All.X(A&~B, pset).add(members[0].id)); + + layout(); + deal(); + allow->add(SAY, nil, "say &"); + } +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "bad member"; + case tag { + CLICK => + # click stack index + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + d := dmembers[cp.ord]; + if (sel.isempty() || sel.stack == stack) { + # selecting a card to move + if (nc == 0 && stype == "spare1") { + cardlib->flip(d.spare2); + d.spare2.transfer((0, len d.spare2.children), d.spare1, 0); + return nil; + } + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + if (owner(stack) != cp) + return "not yours, don't touch!"; + case stype { + "spare2" or + "pile" => + select(cp, stack, (nc - 1, nc)); + "open" => + select(cp, stack, (idx, nc)); + "spare1" => + if ((n := nc) > 3) + n = 3; + for (i := 0; i < n; i++) { + cardlib->setface(stack.children[nc - 1], 1); + stack.transfer((nc - 1, nc), d.spare2, -1); + nc--; + } + * => + return "you can't move cards from there"; + } + } else { + # selecting a stack to move to. + frompile := sel.stack.getattr("type") == "pile"; + case stype { + "acepile" => + if (sel.r.end != sel.r.start + 1) + return "only one card at a time!"; + card := getcard(sel.stack.children[sel.r.start]); + if (nc == 0) { + if (card.number != 0) + return "aces only"; + } else { + top := getcard(stack.children[nc - 1]); + if (card.number != top.number + 1) + return "out of sequence"; + if (card.suit != top.suit) + return "wrong suit"; + } + sel.transfer(stack, -1); + if (card.number == KING) # kings get flipped + cardlib->setface(stack.children[len stack.children - 1], 0); + "open" => + if (owner(stack) != cp) + return "not yours, don't touch!"; + c := getcard(sel.stack.children[sel.r.start]); + col := !isred(c); + n := c.number + 1; + for (i := sel.r.start; i < sel.r.end; i++) { + c2 := getcard(sel.stack.children[i]); + if (isred(c2) == col) + return "bad colour sequence"; + if (c2.number != n - 1) + return "bad number sequence"; + n = c2.number; + col = isred(c2); + } + if (nc != 0) { + c2 := getcard(stack.children[nc - 1]); + if (isred(c2) == isred(c) || c2.number != c.number + 1) + return "invalid move"; + } + sel.transfer(stack, -1); + * => + return "can't move there"; + } + if (frompile) { + nc = len d.pile.children; + if (nc == 0) { + endround(); + deal(); + } else { + cardlib->setface(d.pile.children[nc - 1], 1); + d.pile.setattr("title", "pile [" + string nc + "]", All); + } + } + } + SAY => + clique.action("say member " + string p.id + ": '" + joinwords(tl toks) + "'", nil, nil, All); + + SHOW => + clique.show(nil); + } + return nil; +} + +getcard(card: ref Object): Card +{ + return cardlib->getcard(card); +} + +isred(c: Card): int +{ + return c.suit == Cardlib->DIAMONDS || c.suit == Cardlib->HEARTS; +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} + +owner(stack: ref Object): ref Cmember +{ + parent := clique.objects[stack.parentid]; + n := cardlib->nmembers(); + for (i := 0; i < n; i++) { + cp := Cmember.index(i); + if (cp.obj == parent) + return cp; + } + return nil; +} + +layout() +{ + n := cardlib->nmembers(); + dmembers = array[n] of ref Dmember; + for (i := 0; i < n; i++) { + cp := Cmember.index(i); + d := dmembers[i] = ref Dmember; + d.spare1 = newstack(cp.obj, Untitledpilespec, "spare1"); + d.spare2 = newstack(cp.obj, Untitledpilespec, "spare2"); + d.pile = newstack(cp.obj, Pilespec, "pile"); + d.open = array[4] of {* => newstack(cp.obj, Openspec, "open")}; + d.acepiles = array[4] of {* => newstack(cp.obj, Untitledpilespec, "acepile")}; + cardlib->makecards(d.spare1, (0, 13), string i); + } + + entry := clique.newobject(nil, All, "widget entry"); + entry.setattr("command", "say", All); + cardlib->addlayobj(nil, nil, nil, dTOP|FILLX, entry); + + scores = array[n] of {* => 0}; + scorelabel = clique.newobject(nil, All, "widget label"); + setscores(); + cardlib->addlayobj(nil, nil, nil, dTOP|FILLX, scorelabel); + + cardlib->addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + row := 0; + col := 0; + maketable("arena"); + for (i = 0; i < n; i++) { + d := dmembers[i]; + f := "p" + string i; + cardlib->addlayobj(nil, f, nil, dLEFT, d.spare1); + cardlib->addlayobj(nil, f, nil, dLEFT, d.spare2); + cardlib->addlayobj(nil, f, nil, dLEFT, d.pile); + for (j := 0; j < len d.open; j++) + cardlib->addlayobj(nil, f, nil, dLEFT|EXPAND|oDOWN, d.open[j]); + for (j = 0; j < len d.acepiles; j++) { + cardlib->addlayobj(nil, "a" + string row, nil, dLEFT|EXPAND, d.acepiles[j]); + if (++col >= NACES) { + col = 0; + row++; + } + } + } +} + +setscores() +{ + s := "Scores: "; + n := cardlib->nmembers(); + for (i := 0; i < n; i++) { + s += Cmember.index(i).p.name + ": " + string scores[i]; + if (i < n - 1) + s[len s] = ' '; + } + scorelabel.setattr("text", s, All); +} + +deal() +{ + n := cardlib->nmembers(); + for (i := 0; i < n; i++) { + cp := Cmember.index(i); + d := dmembers[i]; + deck := d.spare1; + cardlib->shuffle(deck); + deck.transfer((0, 13), d.pile, 0); + cardlib->setface(d.pile.children[12], 1); + d.pile.setattr("title", "pile [13]", All); + for (j := 0; j < len d.open; j++) { + deck.transfer((0, 1), d.open[j], 0); + cardlib->setface(d.open[j].children[0], 1); + } + } +} + +endround() +{ + # go through all the ace piles, moving cards back to the appropriate deck + # and counting appropriately. + # move all other cards back too. + n := cardlib->nmembers(); + for (i := 0; i < n; i++) { + d := dmembers[i]; + Cmember.index(i).sel.set(nil); + for (j := 0; j < len d.acepiles; j++) { + acepile := d.acepiles[j]; + nc := len acepile.children; + for (k := nc - 1; k >= 0; k--) { + card := acepile.children[k]; + back := int card.getattr("rear"); + scores[back]++; + if (getcard(card).number == KING) + scores[back] += 5; + cardlib->setface(card, 0); + acepile.transfer((k, k + 1), dmembers[back].spare1, -1); + } + } + if (len d.pile.children == 0) + scores[i] += 10; # bonus for going out + else + scores[i] -= len d.pile.children; + cardlib->discard(d.pile, d.spare1, 1); + cardlib->discard(d.spare2, d.spare1, 1); + for (j = 0; j < len d.open; j++) + cardlib->discard(d.open[j], d.spare1, 1); + } + setscores(); +} + +maketable(parent: string) +{ + addlayframe: import cardlib; + + n := cardlib->nmembers(); + na := ((n * 4) + (NACES - 1)) / NACES; + for (i := 0; i < n; i++) { + layout := Cmember.index(i).layout; + # one frame for each member other than self; + # then all the ace piles; then self. + for (j := 0; j < n; j++) + if (j != i) + addlayframe("p" + string j, parent, layout, dTOP|EXPAND, dTOP); + for (j = 0; j < na; j++) + addlayframe("a" + string j, parent, layout, dTOP|EXPAND|aCENTRELEFT, dTOP); + addlayframe("p" + string i, parent, layout, dTOP|EXPAND, dTOP); + } +} + +newstack(parent: ref Object, spec: Stackspec, stype: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + return stack; +} + +joinwords(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; +} + +remark(s: string) +{ + clique.action("remark " + s, nil, nil, All); +} diff --git a/appl/spree/engines/snap.b b/appl/spree/engines/snap.b new file mode 100644 index 00000000..ff7166cb --- /dev/null +++ b/appl/spree/engines/snap.b @@ -0,0 +1,241 @@ +implement Engine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + publicstack: import cardlib; + VERT, HORIZ, TOP, BOTTOM, LEFT, RIGHT, Stackspec: import Cardlib; + +clique: ref Clique; +PLAY, START, SAY, SNAP: con iota; + +started := 0; + +buttons: ref Object; +scores: ref Object; +deck: ref Object; + +HAND, PILE: con iota; + +hands := array[2] of ref Object; +piles := array[2] of ref Object; + +publicspec: array of Stackspec; + +privatespec := array[] of { + HAND => Stackspec(Cardlib->sPILE, + 52, + 0, + "hand", + HORIZ, + BOTTOM), + PILE => Stackspec(Cardlib->sPILE, + 52, + 0, + "pile", + HORIZ, + TOP), +}; + +oneplayed := 0; # true if only one member's put down a card so far + +MINPLAYERS: con 2; +MAXPLAYERS: con 2; + +clienttype(): string +{ + return "cards"; +} + +init(g: ref Clique, srvmod: Spree): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + allow->add(SAY, nil, "say &"); + + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + + cardlib->init(clique, spree); + deck = clique.newobject(nil, ~0, "stack"); + cardlib->makepack(deck, (0, 52), 1); + cardlib->shuffle(deck); + buttons = clique.newobject(nil, ~0, "buttons"); + scores = clique.newobject(nil, ~0, "scoretable"); + + return nil; +} + +join(p: ref Member): string +{ + sys->print("%s(%d) joining\n", p.name(), p.id); + if (!started && cardlib->nmembers() < MAXPLAYERS) { + (nil, err) := cardlib->join(p, -1); + if (err == nil) { + if (cardlib->nmembers() == MINPLAYERS) { + mkbutton("Start", "start"); + allow->add(START, nil, "start"); + } + } else + sys->print("error on join: %s\n", err); + } + return nil; +} + +leave(p: ref Member) +{ + cardlib->leave(p); + started == 0; + if (cardlib->nmembers() < MINPLAYERS) { + buttons.deletechildren((0, len buttons.children)); + allow->del(START, nil); + } +} + +command(p: ref Member, cmd: string): string +{ + e := ref Sys->Exception; + if (sys->rescue("parse:*", e) == Sys->EXCEPTION) { + sys->rescued(Sys->ONCE, nil); + return e.name[6:]; + } + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + case tag { + START => + buttons.deletechildren((0, len buttons.children)); + allow->del(START, nil); + allow->add(SNAP, nil, "snap"); + mkbutton("Snap!", "snap"); + cardlib->startclique(publicspec, privatespec); + for (i := 0; i < 2; i++) { + hands[i] = cardlib->info(i).stacks[HAND]; + piles[i] = cardlib->info(i).stacks[PILE]; + } + deck.transfer((0, 26), hands[0], 0); + deck.transfer((0, 26), hands[1], 0); + canplay(0); + canplay(1); + + PLAY => + # click index + ord := cardlib->order(p); + inf := cardlib->info(ord); + + hand := hands[ord]; + pile := piles[ord]; + hand.transfer((len hand.children - 1, len hand.children), pile, len pile.children); + cardlib->setface(pile.children[len pile.children - 1], 1); + cantplay(ord); + oneplayed = !oneplayed; + if (!oneplayed || len hands[!ord].children == 0) { + for (i := 0; i < 2; i++) + if (len hands[i].children > 0) + canplay(i); + } + SNAP => + # snap + ord := cardlib->order(p); + inf := cardlib->info(ord); + if (oneplayed) # XXX allow for case where one person has no cards. + return "must wait for two cards to be put down"; + if (len piles[0].children == 0 || len piles[1].children == 0) + return "no cards"; + c0 := cardlib->getcard(piles[0].children[len piles[0].children - 1]); + c1 := cardlib->getcard(piles[1].children[len piles[0].children - 1]); + if (c0.number != c1.number) { + remark(p.name() + " said snap wrongly!"); + return "cards must be the same"; + } else { + transferall(piles[!ord], piles[ord], len piles[ord].children); + flipstack(piles[ord]); + transferall(piles[ord], hands[ord], 0); + if (len hands[!ord].children == 0) + remark(p.name() + " has won!"); + oneplayed = 0; + for (i := 0; i < 2; i++) + if (len hands[i].children > 0) + canplay(i); + else + cantplay(i); + } + SAY => + clique.action("say member " + string p.id + ": '" + joinwords(tl toks) + "'", nil, nil, ~0); + } + return nil; +} + +transferall(stack, into: ref Object, idx: int) +{ + stack.transfer((0, len stack.children), into, idx); +} + +flipstack(stack: ref Object) +{ + for (i := 0; i < len stack.children; i++) { + card := stack.children[i]; + cardlib->setface(card, ! int card.getattr("face")); + } +} + +joinwords(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; +} + +canplay(ord: int) +{ + inf := cardlib->info(ord); + allow->del(PLAY, inf.p); + allow->add(PLAY, inf.p, "click %d"); + inf.stacks[HAND].setattr("actions", "click", 1<<inf.p.id); +} + +cantplay(ord: int) +{ + inf := cardlib->info(ord); + allow->del(PLAY, inf.p); + inf.stacks[HAND].setattr("actions", nil, 1<<inf.p.id); +} + +member(ord: int): ref Member +{ + return cardlib->info(ord).p; +} + +remark(s: string) +{ + clique.action("remark " + s, nil, nil, ~0); +} + +mkbutton(text, cmd: string): ref Object +{ + but := clique.newobject(buttons, ~0, "button"); + but.setattr("text", text, ~0); + but.setattr("command", cmd, ~0); + return but; +} diff --git a/appl/spree/engines/spider.b b/appl/spree/engines/spider.b new file mode 100644 index 00000000..08576ff0 --- /dev/null +++ b/appl/spree/engines/spider.b @@ -0,0 +1,259 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + All, None: import Sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember, Card: import cardlib; + getcard: import cardlib; + dTOP, dRIGHT, dLEFT, oRIGHT, oDOWN, + aCENTRERIGHT, aCENTRELEFT, aUPPERRIGHT, aUPPERCENTRE, + EXPAND, FILLX, FILLY, Stackspec: import Cardlib; +include "../gather.m"; + +clique: ref Clique; + +open: array of ref Object; # [10] +deck: ref Object; +discard: ref Object; +dealbutton: ref Object; + +CLICK, MORECARDS: con iota; + +Openspec := Stackspec( + "display", # style + 19, # maxcards + 0, # conceal + "" # title +); + +clienttype(): string +{ + return "cards"; +} + +maxmembers(): int +{ + return 1; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + return nil; +} + +propose(members: array of string): string +{ + if (len members != 1) + return "one member only"; + return nil; +} + +archive() +{ + archiveobj := cardlib->archive(); + allow->archive(archiveobj); + cardlib->archivearray(open, "open"); + cardlib->setarchivename(deck, "deck"); + cardlib->setarchivename(discard, "discard"); + cardlib->setarchivename(dealbutton, "dealbutton"); +} + +start(members: array of ref Member, archived: int) +{ + cardlib->init(spree, clique); + if (archived) { + archiveobj := cardlib->unarchive(); + allow->unarchive(archiveobj); + open = cardlib->getarchivearray("open"); + discard = cardlib->getarchiveobj("discard"); + deck = cardlib->getarchiveobj("deck"); + dealbutton = cardlib->getarchiveobj("dealbutton"); + } else { + p := members[0]; + Cmember.join(p, -1).layout.lay.setvisibility(All); + startclique(); + allow->add(CLICK, p, "click %o %d"); + allow->add(MORECARDS, p, "morecards"); + } +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "you are not playing"; + case tag { + CLICK => + # click stack index + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + if (sel.isempty() || sel.stack == stack) { + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + case stype { + "open" => + select(cp, stack, (idx, nc)); + * => + return "you can't move cards from there"; + } + } else { + from := sel.stack; + case stype { + "open" => + c := getcard(sel.stack.children[sel.r.start]); + n := c.number + 1; + for (i := sel.r.start; i < sel.r.end; i++) { + c2 := getcard(sel.stack.children[i]); + if (c2.face == 0) + return "cannot move face down cards"; + if (c2.number != n - 1) + return "bad number sequence"; + n = c2.number; + } + if (nc != 0) { + c2 := getcard(stack.children[nc - 1]); + if (c2.number != c.number + 1) + return "descending, only"; + } + srcstack := sel.stack; + sel.transfer(stack, -1); + turntop(srcstack); + + nc = len stack.children; + if (nc >= 13) { + c = getcard(stack.children[nc - 1]); + suit := c.suit; + for (i = 0; i < 13; i++) { + c = getcard(stack.children[nc - i - 1]); + if (c.suit != suit || c.number != i) + break; + } + if (i == 13) { + stack.transfer((nc - 13, nc), discard, -1); + turntop(stack); + } + } + * => + return "can't move there"; + } + } + MORECARDS => + for (i := 0; i < 10; i++) + if (len open[i].children == 0) + return "spaces must be filled before redeal"; + for (i = 0; i < 10; i++) { + if (len deck.children == 0) + break; + cp.sel.set(nil); + cardlib->setface(deck.children[0], 1); + deck.transfer((0, 1), open[i], -1); + } + setdealbuttontext(); + } + return nil; +} + +setdealbuttontext() +{ + dealbutton.setattr("text", sys->sprint("deal more (%d left)", len deck.children), All); +} + +turntop(stack: ref Object) +{ + if (len stack.children > 0) + cardlib->setface(stack.children[len stack.children - 1], 1); +} + +startclique() +{ + addlayobj, addlayframe: import cardlib; + open = array[10] of {* => newstack(nil, Openspec, "open", nil)}; + deck = clique.newobject(nil, All, "stack"); + discard = clique.newobject(nil, All, "stack"); + cardlib->makecards(deck, (0, 13), "0"); + cardlib->makecards(deck, (0, 13), "1"); + addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + addlayframe("top", "arena", nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + + for (i := 0; i < 10; i++) + addlayobj(nil, "top", nil, dLEFT|oDOWN|EXPAND|aUPPERCENTRE, open[i]); + addlayframe("bot", "arena", nil, dTOP, dTOP); + dealbutton = newbutton("morecards", "deal more"); + addlayobj(nil, "bot", nil, dLEFT, dealbutton); + deal(); + setdealbuttontext(); +} + +deal() +{ + cardlib->shuffle(deck); + for (i := 0; i < 10; i++) { + deck.transfer((0, 4), open[i], 0); + turntop(open[i]); + } +} + +newstack(parent: ref Object, spec: Stackspec, stype, title: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + stack.setattr("title", title, All); + return stack; +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} + +newbutton(cmd, text: string): ref Object +{ + but := clique.newobject(nil, All, "widget button"); + but.setattr("command", cmd, All); + but.setattr("text", text, All); + return but; +} + diff --git a/appl/spree/engines/spit.b b/appl/spree/engines/spit.b new file mode 100644 index 00000000..2c42cb95 --- /dev/null +++ b/appl/spree/engines/spit.b @@ -0,0 +1,483 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + sets: Sets; + Set, All, None, A, B: import sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember, Card: import cardlib; + dTOP, dLEFT, dBOTTOM, oDOWN, EXPAND, FILLX, FILLY, aCENTRELEFT, Stackspec: import Cardlib; +include "../gather.m"; + +clique: ref Clique; +CLICK, SPIT, SAY, SHOW: con iota; +playing := 0; +dealt := 0; +deck: ref Object; +buttons: ref Object; +winner: ref Member; + +Dmember: adt { + spare: ref Object; + row: array of ref Object; + centre: ref Object; +}; + +dmembers := array[2] of ref Dmember; + +Openspec := Stackspec( + "display", # style + 4, # maxcards + 0, # conceal + "" # title +); + +Pilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "pile" # title +); + +Untitledpilespec := Stackspec( + "pile", # style + 13, # maxcards + 0, # conceal + "" # title +); + +clienttype(): string +{ + return "cards"; +} + + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("spit: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("spit: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + sets->init(); + + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("spit: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + cardlib->init(spree, clique); + + return nil; +} + +maxmembers(): int +{ + return 2; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +propose(members: array of string): string +{ + if (len members != 2) + return "need exactly two members"; + return nil; +} + +archive() +{ + archiveobj := cardlib->archive(); + allow->archive(archiveobj); + for (i := 0; i < len dmembers; i++) { + dp := dmembers[i]; + s := "d" + string i + "_"; + cardlib->setarchivename(dp.spare, s + "spare"); + cardlib->setarchivename(dp.centre, s + "centre"); + for (j := 0; j < len dp.row; j++) + cardlib->setarchivename(dp.row[j], s + "row" + string j); + } + archiveobj.setattr("playing", string playing, None); + archiveobj.setattr("dealt", string dealt, None); + cardlib->setarchivename(deck, "deck"); +} + +start(members: array of ref Member, archived: int) +{ + cardlib->init(spree, clique); + if (archived) { + archiveobj := cardlib->unarchive(); + allow->unarchive(archiveobj); + playing = int archiveobj.getattr("playing"); + dealt = int archiveobj.getattr("dealt"); + deck = cardlib->getarchiveobj("deck"); + for (i := 0; i < len dmembers; i++) { + dp := dmembers[i] = ref Dmember; + s := "d" + string i + "_"; + dp.spare = cardlib->getarchiveobj(s + "spare"); + dp.centre = cardlib->getarchiveobj(s + "centre"); + dp.row = array[4] of ref Object; + for (j := 0; j < len dp.row; j++) + dp.row[j] = cardlib->getarchiveobj(s + "row" + string j); + } + } else { + buttons = clique.newobject(nil, All, "buttons"); + pset := None; + for (i := 0; i < len members; i++) { + Cmember.join(members[i], i); + pset = pset.add(members[i].id); + } + # member 0 layout visible to member 0 and everyone else but other member. + # could be All.del(members[1].id) but doing it this way extends to many-member cliques. + Cmember.index(0).layout.lay.setvisibility(All.X(A&~B, pset).add(members[0].id)); + layout(); + deal(); + dealt = 1; + playing = 0; + allow->add(SPIT, nil, "spit"); + allow->add(SAY, nil, "say &"); + allow->add(SHOW, nil, "show"); + } +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil){ + if(winner != nil){ + if(winner == p) + return "game has finished: you have won"; + return "game has finished: you have lost"; + } + return err; + } + cp := Cmember.find(p); + if (cp == nil) + return "you're only watching"; + case tag { + SPIT => + if (!dealt) { + deal(); + dealt = 1; + } else if (!playing) { + go(); + allow->add(CLICK, nil, "click %o %d"); + playing = 1; + } else if (!canplay(!cp.ord)) { + go(); + } else + return "it is possible to play"; + + CLICK => + stack := clique.objects[int hd tl toks]; + nc := len stack.children; + idx := int hd tl tl toks; + sel := cp.sel; + stype := stack.getattr("type"); + d := dmembers[cp.ord]; + if (sel.isempty() || sel.stack == stack) { + # selecting a card to move + if (idx < 0 || idx >= len stack.children) + return "invalid index"; + if (owner(stack) != cp) + return "not yours, don't touch!"; + case stype { + "row" => + card := getcard(stack.children[nc - 1]); + if (card.face == 0) + cardlib->setface(stack.children[nc - 1], 1); + else + select(cp, stack, (nc - 1, nc)); + * => + return "you can't move cards from there"; + } + } else { + # selecting a stack to move to. + case stype { + "centre" => + card := getcard(sel.stack.children[sel.r.start]); + onto := getcard(stack.children[nc - 1]); + if ((card.number + 1) % 13 != onto.number && + (card.number + 12) % 13 != onto.number) { + sel.set(nil); + return "out of sequence"; + } + sel.transfer(stack, -1); + for (i := 0; i < len d.row; i++) + if (len d.row[i].children > 0) + break; + if (i == len d.row) { + if (len d.spare.children == 0) { + remark(p.name + " has won"); + winner = p; + allow->del(CLICK, nil); + allow->del(SPIT, nil); + clearsel(); + } else + finish(cp); + } + "row" => + if (owner(stack) != cp) { + sel.set(nil); + return "not yours, don't touch!"; + } + if (nc != 0) { + sel.set(nil); + return "cannot stack cards"; + } + sel.transfer(stack, -1); + * => + sel.set(nil); + return "can't move there"; + } + } + + SAY => + clique.action("say member " + string p.id + ": '" + concat(tl toks) + "'", nil, nil, All); + + SHOW => + clique.show(nil); + } + return nil; +} + +canplay(ord: int): int +{ + d := dmembers[ord]; + nmulti := nfree := 0; + for (j := 0; j < len d.row; j++) { + s1 := d.row[j]; + if (len s1.children > 0) { + nmulti += len s1.children > 1; + card1 := getcard(s1.children[len s1.children - 1]); + for (k := 0; k < 2; k++) { + s2 := dmembers[k].centre; + if (len s2.children > 0) { + card2 := getcard(s2.children[len s2.children - 1]); + if ((card1.number + 1) % 13 == card2.number || + (card1.number + 12) % 13 == card2.number) + return 1; + } + } + } else + nfree++; + } + return nmulti > 0 && nfree > 0; +} + +bottomdiscard(src, dst: ref Object) +{ + cardlib->flip(src); + for (i := 0; i < len src.children; i++) + cardlib->setface(src.children[i], 0); + src.transfer((0, len src.children), dst, 0); +} + +finish(winner: ref Cmember) +{ + loser := dmembers[!winner.ord]; + for (i := 0; i < 2; i++) { + d := dmembers[i]; + bottomdiscard(d.centre, loser.spare); + for (j := 0; j < len d.row; j++) + bottomdiscard(d.row[j], loser.spare); + } + playing = 0; + dealt = 0; + allow->del(CLICK, nil); + allow->add(SPIT, nil, "spit"); + clearsel(); +} + +go() +{ + for (i := 0; i < 2; i++) { + d := dmembers[i]; + n := len d.spare.children; + if (n > 0) + d.spare.transfer((n - 1, n), d.centre, -1); + else if ((m := len dmembers[!i].spare.children) > 0) + dmembers[!i].spare.transfer((m - 1, m), d.centre, -1); + else { + # both members' spare piles are used up; use central piles instead + for (j := 0; j < 2; j++) { + cardlib->discard(dmembers[j].centre, dmembers[j].spare, 0); + cardlib->flip(dmembers[j].spare); + } + go(); + return; + } + cardlib->setface(d.centre.children[len d.centre.children - 1], 1); + } +} + +getcard(card: ref Object): Card +{ + return cardlib->getcard(card); +} + +select(cp: ref Cmember, stack: ref Object, r: Range) +{ + if (cp.sel.isempty()) { + cp.sel.set(stack); + cp.sel.setrange(r); + } else { + if (cp.sel.r.start == r.start && cp.sel.r.end == r.end) + cp.sel.set(nil); + else + cp.sel.setrange(r); + } +} + +owner(stack: ref Object): ref Cmember +{ + parent := clique.objects[stack.parentid]; + n := cardlib->nmembers(); + for (i := 0; i < n; i++) { + cp := Cmember.index(i); + if (cp.obj == parent) + return cp; + } + return nil; +} + +layout() +{ + for (i := 0; i < 2; i++) { + cp := Cmember.index(i); + d := dmembers[i] = ref Dmember; + d.spare = newstack(cp.obj, Untitledpilespec, "spare"); + d.row = array[4] of {* => newstack(cp.obj, Openspec, "row")}; + d.centre = newstack(cp.obj, Untitledpilespec, "centre"); + } + deck = clique.newobject(nil, All, "stack"); + cardlib->makecards(deck, (0, 13), "0"); + cardlib->shuffle(deck); + + entry := clique.newobject(nil, All, "widget entry"); + entry.setattr("command", "say", All); + cardlib->addlayobj(nil, nil, nil, dTOP|FILLX, entry); + + cardlib->addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + maketable("arena"); + spitbutton := newbutton("spit", "Spit!"); + for (i = 0; i < 2; i++) { + d := dmembers[i]; + f := "p" + string i; + + subf := "f" + string i; + cardlib->addlayframe(subf, f, nil, dLEFT, dTOP); + cardlib->addlayobj(nil, subf, Cmember.index(i).layout, dTOP, spitbutton); + cardlib->addlayobj(nil, subf, nil, dTOP, d.spare); + for (j := 0; j < len d.row; j++) + cardlib->addlayobj(nil, f, nil, dLEFT|EXPAND|oDOWN, d.row[j]); + cardlib->addlayobj(nil, "centre", nil, dLEFT|EXPAND, d.centre); + } +} + +newbutton(cmd, text: string): ref Object +{ + but := clique.newobject(nil, All, "widget button"); + but.setattr("command", cmd, All); + but.setattr("text", text, All); + return but; +} + +settopface(stack: ref Object, face: int) +{ + n := len stack.children; + if (n > 0) + cardlib->setface(stack.children[n - 1], face); +} + +transfertop(src, dst: ref Object, index: int) +{ + n := len src.children; + src.transfer((n - 1, n), dst, index); +} + +deal() +{ + clearsel(); + n := len deck.children; + if (n > 0) { + deck.transfer((0, n / 2), dmembers[0].spare, 0); + deck.transfer((0, len deck.children), dmembers[1].spare, 0); + } + + for (i := 0; i < 2; i++) { + d := dmembers[i]; +loop: for (j := 0; j < len d.row; j++) { + for (k := j; k < len d.row; k++) { + if (len d.spare.children == 0) + break loop; + transfertop(d.spare, d.row[k], -1); + } + } + for (j = 0; j < len d.row; j++) + settopface(d.row[j], 1); + } +} + +maketable(parent: string) +{ + addlayframe: import cardlib; + + for (i := 0; i < 2; i++) { + layout := Cmember.index(i).layout; + addlayframe("p" + string !i, parent, layout, dTOP|EXPAND, dBOTTOM); + addlayframe("p" + string i, parent, layout, dBOTTOM|EXPAND, dTOP); + addlayframe("centre", parent, layout, dTOP|EXPAND, dTOP); + } +} + +newstack(parent: ref Object, spec: Stackspec, stype: string): ref Object +{ + stack := cardlib->newstack(parent, nil, spec); + stack.setattr("type", stype, None); + stack.setattr("actions", "click", All); + return stack; +} + +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; +} + +remark(s: string) +{ + clique.action("remark " + s, nil, nil, All); +} + +clearsel() +{ + n := cardlib->nmembers(); + for (i := 0; i < n; i++) + Cmember.index(i).sel.set(nil); +} diff --git a/appl/spree/engines/whist.b b/appl/spree/engines/whist.b new file mode 100644 index 00000000..ca0c26f9 --- /dev/null +++ b/appl/spree/engines/whist.b @@ -0,0 +1,305 @@ +implement Gatherengine; + +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sets.m"; + sets: Sets; + Set, All, None, A, B: import sets; +include "../spree.m"; + spree: Spree; + Attributes, Range, Object, Clique, Member, rand: import spree; +include "allow.m"; + allow: Allow; +include "cardlib.m"; + cardlib: Cardlib; + Selection, Cmember: import cardlib; + dTOP, dLEFT, oRIGHT, EXPAND, FILLX, FILLY, Stackspec: import Cardlib; +include "tricks.m"; + tricks: Tricks; + Trick: import tricks; +include "../gather.m"; + +clique: ref Clique; +CLICK, SAY: con iota; + +scores: ref Object; +deck, pile: ref Object; +hands, taken: array of ref Object; +leader, turn: ref Cmember; +trick: ref Trick; + +Trickpilespec := Stackspec( + "display", # style + 4, # maxcards + 0, # conceal + "trick pile" # title +); + +Handspec := Stackspec( + "display", + 13, + 1, + "" +); + +Takenspec := Stackspec( + "pile", + 52, + 0, + "tricks" +); + +clienttype(): string +{ + return "cards"; +} + +init(srvmod: Spree, g: ref Clique, nil: list of string, nil: int): string +{ + sys = load Sys Sys->PATH; + clique = g; + spree = srvmod; + + allow = load Allow Allow->PATH; + if (allow == nil) { + sys->print("whist: cannot load %s: %r\n", Allow->PATH); + return "bad module"; + } + allow->init(spree, clique); + + sets = load Sets Sets->PATH; + if (sets == nil) { + sys->print("spit: cannot load %s: %r\n", Sets->PATH); + return "bad module"; + } + sets->init(); + + cardlib = load Cardlib Cardlib->PATH; + if (cardlib == nil) { + sys->print("whist: cannot load %s: %r\n", Cardlib->PATH); + return "bad module"; + } + + tricks = load Tricks Tricks->PATH; + if (tricks == nil) { + sys->print("hearts: cannot load %s: %r\n", Tricks->PATH); + return "bad module"; + } + + return nil; +} + +maxmembers(): int +{ + return 4; +} + +readfile(nil: int, nil: big, nil: int): array of byte +{ + return nil; +} + +propose(members: array of string): string +{ + if (len members < 2) + return "need at least two members"; + if (len members > 4) + return "too many members"; + return nil; +} + +archive() +{ + archiveobj := cardlib->archive(); + allow->archive(archiveobj); + + cardlib->setarchivename(scores, "scores"); + cardlib->setarchivename(deck, "deck"); + cardlib->setarchivename(pile, "pile"); + cardlib->archivearray(hands, "hands"); + cardlib->archivearray(taken, "taken"); + if (leader != nil) + archiveobj.setattr("leader", string leader.ord, None); + if (turn != nil) + archiveobj.setattr("turn", string turn.ord, None); + trick.archive(archiveobj, "trick"); +} + +start(members: array of ref Member, archived: int) +{ + cardlib->init(spree, clique); + tricks->init(spree, clique, cardlib); + if (archived) { + archiveobj := cardlib->unarchive(); + allow->unarchive(archiveobj); + + scores = cardlib->getarchiveobj("scores"); + deck = cardlib->getarchiveobj("deck"); + pile = cardlib->getarchiveobj("pile"); + hands = cardlib->getarchivearray("hands"); + taken = cardlib->getarchivearray("taken"); + + o := archiveobj.getattr("leader"); + if (o != nil) + leader = Cmember.index(int o); + o = archiveobj.getattr("turn"); + if (o != nil) + turn = Cmember.index(int o); + trick = Trick.unarchive(archiveobj, "trick"); + } else { + pset := None; + for (i := 0; i < len members; i++) { + Cmember.join(members[i], i); + pset = pset.add(members[i].id); + } + # member 0 layout visible to member 0 and everyone else but other member. + # could be All.del(members[1].id) but doing it this way extends to many-member cliques. + Cmember.index(0).layout.lay.setvisibility(All.X(A&~B, pset).add(members[0].id)); + deck = clique.newobject(nil, All, "stack"); + cardlib->makecards(deck, (0, 13), nil); + cardlib->shuffle(deck); + scores = clique.newobject(nil, All, "scoretable"); + startclique(); + n := cardlib->nmembers(); + leader = Cmember.index(rand(n)); + starthand(); + titles := ""; + for (i = 0; i < n; i++) + titles += members[i].name + " "; + clique.newobject(scores, All, "score").setattr("score", titles, All); + } +} + +command(p: ref Member, cmd: string): string +{ + (err, tag, toks) := allow->action(p, cmd); + if (err != nil) + return err; + cp := Cmember.find(p); + if (cp == nil) + return "you're only watching"; + case tag { + CLICK => + # click stackid index + stack := p.obj(int hd tl toks); + if (stack != trick.hands[cp.ord]) + return "not yours"; + err = trick.play(cp.ord, int hd tl tl toks); + if (err != nil) + return err; + + turn = turn.next(1); + if (turn == leader) { # come full circle + winner := Cmember.index(trick.winner); + remark(sys->sprint("%s won the trick", winner.p.name)); + cardlib->discard(pile, taken[winner.ord], 0); + nmembers := cardlib->nmembers(); + taken[winner.ord].setattr("title", + string (len taken[winner.ord].children / nmembers) + + " tricks", All); + o := winner.obj; + trick = nil; + s := ""; + for (i := 0; i < nmembers; i++) { + if (i == winner.ord) + s += "1 "; + else + s += "0 "; + } + clique.newobject(scores, All, "score").setattr("score", s, All); + if (len hands[winner.ord].children > 0) { + leader = turn = winner; + trick = Trick.new(pile, -1, hands, nil); + } else { + remark("one round down, some to go"); + leader = turn = nil; # XXX this round over + } + } + canplay(turn); + SAY => + clique.action("say member " + string p.id + ": '" + joinwords(tl toks) + "'", nil, nil, All); + } + return nil; +} + +startclique() +{ + entry := clique.newobject(nil, All, "widget entry"); + entry.setattr("command", "say", All); + cardlib->addlayobj("entry", nil, nil, dTOP|FILLX, entry); + cardlib->addlayframe("arena", nil, nil, dTOP|EXPAND|FILLX|FILLY, dTOP); + cardlib->maketable("arena"); + + pile = cardlib->newstack(nil, nil, Trickpilespec); + cardlib->addlayobj(nil, "public", nil, dTOP|oRIGHT, pile); + n := cardlib->nmembers(); + hands = array[n] of ref Object; + taken = array[n] of ref Object; + tt := clique.newobject(nil, All, "widget menu"); + tt.setattr("text", "hello", All); + for (ml := "one" :: "two" :: "three" :: nil; ml != nil; ml = tl ml) { + o := clique.newobject(tt, All, "menuentry"); + o.setattr("text", hd ml, All); + o.setattr("command", hd ml, All); + } + for (i := 0; i < n; i++) { + cp := Cmember.index(i); + hands[i] = cardlib->newstack(cp.obj, cp.p, Handspec); + taken[i] = cardlib->newstack(cp.obj, cp.p, Takenspec); + p := "p" + string i; + cardlib->addlayframe(p + ".f", p, nil, dLEFT|oRIGHT, dTOP); + cardlib->addlayobj(nil, p + ".f", cp.layout, dTOP, tt); + cardlib->addlayobj(nil, p + ".f", nil, dTOP, hands[i]); + cardlib->addlayobj(nil, "p" + string i, nil, dLEFT|oRIGHT, taken[i]); + } +} + +joinwords(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; +} + +suitrank := array[] of { + Cardlib->CLUBS => 0, + Cardlib->DIAMONDS => 1, + Cardlib->SPADES => 2, + Cardlib->HEARTS => 3 +}; + +starthand() +{ + cardlib->deal(deck, 13, hands, 0); + for (i := 0; i < len hands; i++) + cardlib->sort(hands[i], nil, suitrank); + trick = Trick.new(pile, -1, hands, nil); + turn = leader; + canplay(turn); +} + +canplay(cp: ref Cmember) +{ + allow->del(CLICK, nil); + for (i := 0; i < cardlib->nmembers(); i++) { + ccp := Cmember.index(i); + v := None.add(ccp.p.id); + ccp.obj.setattr("status", nil, v); + hands[i].setattr("actions", nil, v); + } + if (cp != nil && cp.ord != -1) { + allow->add(CLICK, cp.p, "click %d %d"); + v := None.add(cp.p.id); + cp.obj.setattr("status", "Your turn", v); + hands[cp.ord].setattr("actions", "click", v); + } +} + +remark(s: string) +{ + clique.action("remark " + s, nil, nil, All); +} diff --git a/appl/spree/gather.m b/appl/spree/gather.m new file mode 100644 index 00000000..eb7363a3 --- /dev/null +++ b/appl/spree/gather.m @@ -0,0 +1,10 @@ +Gatherengine: module { + init: fn(srvmod: Spree, clique: ref Spree->Clique, argv: list of string, archived: int): string; + propose: fn(members: array of string): string; + start: fn(members: array of ref Spree->Member, archived: int); + command: fn(member: ref Spree->Member, e: string): string; + readfile: fn(f: int, offset: big, n: int): array of byte; + archive: fn(); + clienttype: fn(): string; + maxmembers: fn(): int; +}; diff --git a/appl/spree/join.b b/appl/spree/join.b new file mode 100644 index 00000000..8d4d54fe --- /dev/null +++ b/appl/spree/join.b @@ -0,0 +1,115 @@ +implement Join; +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sh.m"; +include "arg.m"; +include "join.m"; + +usage() +{ + sys->fprint(stderr(), "usage: joinsession [-d mntdir] [-j joinrequest] name\n"); + raise "fail:usage"; +} + +CLIENTDIR: con "/dis/spree/clients"; + +init(ctxt: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + arg := load Arg Arg->PATH; + arg->init(argv); + mnt := "/n/remote"; + joinmsg := "join"; + while ((opt := arg->opt()) != 0) { + case opt { + 'd' => + if ((mnt = arg->arg()) == nil) + usage(); + 'j' => + joinmsg = arg->arg(); + * => + usage(); + } + } + argv = arg->argv(); + if (len argv != 1) + usage(); + arg = nil; + e := join(ctxt, mnt, hd argv, joinmsg); + if (e != nil) { + sys->fprint(stderr(), "startclient: %s\n", e); + raise "fail:error"; + } +} + +join(ctxt: ref Draw->Context, mnt: string, dir: string, joinmsg: string): string +{ + if (sys == nil) + sys = load Sys Sys->PATH; + + fd := sys->open(mnt + "/" + dir + "/ctl", Sys->ORDWR); + if (fd == nil) + return sys->sprint("cannot open %s: %r", mnt + "/" + dir + "/ctl"); + if (joinmsg != nil) + if (sys->fprint(fd, "%s", joinmsg) == -1) + return sys->sprint("cannot join: %r"); + + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(fd, buf, len buf)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) { + (nil, toks) := sys->tokenize(hd lines, " "); + if (len toks > 1 && hd toks == "clienttype") { + sync := chan of string; + spawn startclient(ctxt, hd tl toks :: mnt :: dir :: tl tl toks, fd, sync); + fd = nil; + return <-sync; + } + sys->fprint(stderr(), "startclient: unknown lobby message %s\n", hd lines); + } + } + return "premature EOF"; +} + +startclient(ctxt: ref Draw->Context, argv: list of string, fd: ref Sys->FD, sync: chan of string) +{ + sys->pctl(Sys->FORKNS|Sys->FORKFD|Sys->NEWPGRP, nil); + sys->dup(fd.fd, 0); + fd = nil; + sys->pctl(Sys->NEWFD, 0 :: 1 :: 2 :: nil); + + # XXX security: weed out slashes + path := CLIENTDIR + "/" + hd argv + ".dis"; + mod := load Command path; + if (mod == nil) { + sync <-= sys->sprint("cannot load %s: %r\n", path); + return; + } + spawn clientmod(mod, ctxt, argv); + sync <-= nil; +} + +clientmod(mod: Command, ctxt: ref Draw->Context, argv: list of string) +{ + wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD); + spawn mod->init(ctxt, argv); + buf := array[Sys->ATOMICIO] of byte; + n := sys->read(wfd, buf, len buf); + sys->print("client process (%s) exited: %s\n", concat(argv), string buf[0:n]); +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} + +stderr(): ref Sys->FD +{ + return sys->fildes(2); +} diff --git a/appl/spree/join.m b/appl/spree/join.m new file mode 100644 index 00000000..0660eb83 --- /dev/null +++ b/appl/spree/join.m @@ -0,0 +1,5 @@ +Join: module { + PATH: con "/dis/spree/join.dis"; + join: fn(ctxt: ref Draw->Context, mnt: string, dir: string, joinstr: string): string; + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; diff --git a/appl/spree/joinsession.b b/appl/spree/joinsession.b new file mode 100644 index 00000000..b953c317 --- /dev/null +++ b/appl/spree/joinsession.b @@ -0,0 +1,115 @@ +implement Joinsession; +include "sys.m"; + sys: Sys; +include "draw.m"; +include "sh.m"; +include "arg.m"; +include "joinsession.m"; + +usage() +{ + sys->fprint(stderr(), "usage: joinsession [-d mntdir] [-j joinrequest] name\n"); + raise "fail:usage"; +} + +CLIENTDIR: con "/dis/spree/clients"; + +init(ctxt: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + arg := load Arg Arg->PATH; + arg->init(argv); + mnt := "/n/remote"; + joinmsg := "join"; + while ((opt := arg->opt()) != 0) { + case opt { + 'd' => + if ((mnt = arg->arg()) == nil) + usage(); + 'j' => + joinmsg = arg->arg(); + * => + usage(); + } + } + argv = arg->argv(); + if (len argv != 1) + usage(); + arg = nil; + e := join(ctxt, mnt, hd argv, joinmsg); + if (e != nil) { + sys->fprint(stderr(), "startclient: %s\n", e); + raise "fail:error"; + } +} + +join(ctxt: ref Draw->Context, mnt: string, dir: string, joinmsg: string): string +{ + if (sys == nil) + sys = load Sys Sys->PATH; + + fd := sys->open(mnt + "/" + dir + "/ctl", Sys->ORDWR); + if (fd == nil) + return sys->sprint("cannot open %s: %r", mnt + "/" + dir + "/ctl"); + if (joinmsg != nil) + if (sys->fprint(fd, "%s", joinmsg) == -1) + return sys->sprint("cannot join: %r"); + + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(fd, buf, len buf)) > 0) { + (nil, lines) := sys->tokenize(string buf[0:n], "\n"); + for (; lines != nil; lines = tl lines) { + (nil, toks) := sys->tokenize(hd lines, " "); + if (len toks > 1 && hd toks == "clienttype") { + sync := chan of string; + spawn startclient(ctxt, hd tl toks :: mnt :: dir :: tl tl toks, fd, sync); + fd = nil; + return <-sync; + } + sys->fprint(stderr(), "startclient: unknown lobby message %s\n", hd lines); + } + } + return "premature EOF"; +} + +startclient(ctxt: ref Draw->Context, argv: list of string, fd: ref Sys->FD, sync: chan of string) +{ + sys->pctl(Sys->FORKNS|Sys->FORKFD|Sys->NEWPGRP, nil); + sys->dup(fd.fd, 0); + fd = nil; + sys->pctl(Sys->NEWFD, 0 :: 1 :: 2 :: nil); + + # XXX security: weed out slashes + path := CLIENTDIR + "/" + hd argv + ".dis"; + mod := load Command path; + if (mod == nil) { + sync <-= sys->sprint("cannot load %s: %r\n", path); + return; + } + spawn clientmod(mod, ctxt, argv); + sync <-= nil; +} + +clientmod(mod: Command, ctxt: ref Draw->Context, argv: list of string) +{ + wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD); + spawn mod->init(ctxt, argv); + buf := array[Sys->ATOMICIO] of byte; + n := sys->read(wfd, buf, len buf); + sys->print("client process (%s) exited: %s\n", concat(argv), string buf[0:n]); +} + +concat(l: list of string): string +{ + if (l == nil) + return nil; + s := hd l; + for (l = tl l; l != nil; l = tl l) + s += " " + hd l; + return s; +} + +stderr(): ref Sys->FD +{ + return sys->fildes(2); +} diff --git a/appl/spree/joinsession.m b/appl/spree/joinsession.m new file mode 100644 index 00000000..549d20dd --- /dev/null +++ b/appl/spree/joinsession.m @@ -0,0 +1,7 @@ + +Joinsession: module { + PATH: con "/dis/spree/joinsession.dis"; + join: fn(ctxt: ref Draw->Context, mnt: string, dir: string, join: string): string; + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; + 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; + }; + +}; diff --git a/appl/spree/man/gamesrv.man2 b/appl/spree/man/gamesrv.man2 new file mode 100644 index 00000000..fd910519 --- /dev/null +++ b/appl/spree/man/gamesrv.man2 @@ -0,0 +1,471 @@ +.TH GAMESRV 2 +.SH NAME +Gamesrv \- game server module +.SH SYNOPSIS +.EX +.ps -1 +.vs -1 +include "draw.m"; +include "gamesrv.m"; +gamesrv := load Gamesrv Gamesrv->PATH; +Range, Object, Game, Player: import gamesrv; + +Range: adt { + start: int; + end: int; +}; + +Object: adt { + transfer: fn(o: self ref Object, + r: Range, dst: ref Object, i: int); + setvisibility: fn(o: self ref Object, + visibility: int); + setattrvisibility: fn(o: self ref Object, + name: string, visibility: int); + setattr: fn(o: self ref Object, + name: string, val: string, vis: int); + getattr: fn(o: self ref Object, name: string): string; + delete: fn(o: self ref Object); + deletechildren: fn(o: self ref Object, r: Range); + + id: int; + parentid: int; + children: array of ref Object; + objtype: string; + visibility: int; + # ...private data + +}; + +Game: adt { + newobject: fn(game: self ref Game, parent: ref Object, + visibility: int, objtype: string): ref Object; + action: fn(game: self ref Game, cmd: string, + objs: list of int, rest: string, whoto: int); + player: fn(game: self ref Game, id: int): ref Player; + + objects: array of ref Object; + # ...private data +}; + +Player: adt { + name: fn(player: self ref Player): string; + hangup: fn(player: self ref Player); + obj: fn(player: self ref Player, id: int): ref Object; + + id: int; + # ...private data +}; + +Gamemodule: module { + clienttype: fn(): string; + init: fn(game: ref Gamesrv->Game, srvmod: Gamesrv): string; + command: fn(player: ref Gamesrv->Player, e: string): string; + join: fn(player: ref Gamesrv->Player): string; + leave: fn(player: ref Gamesrv->Player); +}; + +rand: fn(n: int): int; +.ps +1 +.vs +1 +.EE +.SH DESCRIPTION +.I Gamesrv +provides a general server interface that allows distributed +clients to interact in a controlled manner, with the +interaction mediated +by Limbo modules, known as +.IR "game engines" , +or just +.I engines +for short. +Each engine decides on the rules +of its particular game; the engine interface is described +at the end of this manual page, under +``Module Interface''. +.PP +This manual page describes the +interface as presented to an engine +once it has been loaded by +.IR gamesrv . +An engine is responsible for a particular +.IR game , +in which one or more +.I players +participate. Messages sent by players +are interpreted by the game engine, which +responds by making changes to the hierarchical +.I object +database held by the game. +Behind the scenes +.I gamesrv +distributes updates to this database to players +of the game as appropriate. +.SS "Objects and visibility" +Objects hold a game's visible state. An object +has a unique integer +.IR id , +which is an index into the array +.IB game .objects\fR;\fP +it also holds a set of attribute-value pairs, a type, and +zero or more child objects. Together, all the objects +in the game form a hierarchical tree, rooted at +the +.IR "root object" +(id 0), which always exists. +Each attribute and each object also has an associated +.IR "visibility set" , +the set of players that sees updates to the attribute or the children +of the object. A visibility set is an integer, a bitmask where each +bit represents one player, hence +.B ~0 +is visible to all players, and +.B 0 +is visible to no-one. +In general, each player has a unique +identifier +.IR id ; +in an integer +.I i +representing a set of players, +the +.IR id th +bit represents the presence of the player with +identifier +.IR id . +Thus, for a player +.IR p , +.BI "(1<<" p ".id)" +is the set containing only +.IR p , +.BI "(" i "&~(1<<" p ".id))" +excludes +.I p +from the set, and +.BI "(" i "|(1<<" p ".id))" +includes +.I p +in the set. +.PP +Note that the visibility set of an object does not alter the visibility +of that object's attributes, but only that of its children (and of +their children: in general an object is visible to a player if the +intersection of all its ancestors' visibility sets contains that +player). +.PP +Objects can be transferred inside the hierarchy from one parent to +another. If an object is moved to a parent whose visibility conceals it +from a player, then it will appear to that player to have been deleted; +if it is later made visible, then it will be recreated for that +player. +A game engine can almost always ignore this technicality, +except for one thing: the identifier used by a particular player to +identify an object is not necessarily the same as that used by the game +engine. Thus when an engine receives an object id in a player's +message, it should convert it using the +.IB player .obj() +function. +.SS \fBGame\fP +The +.B Game +type holds all the objects in a game. It allows the +creation of new objects, and provides way of communicating +with players outside the object hierarchy. +All data members of a +.B Game +should be treated as read-only. +.TP 10 +.IB game .objects +This array holds the objects in the game. An object with +identifier +.I id +is found at +.IB game .objects[ id ]\fR.\fP +.TP +.IB game .newobject(\fIparent\fP,\ \fIvisibility\fP,\ \fIobjtype\fP) +.B Newobject +creates a new object at the end +of +.IR parent 's +children; +If +.I parent +is nil, the new object is created under the root object. +The new object has visibility +.IR visibility , +and type +.IR objtype . +An object's type cannot be changed once +it has been created. +.TP +.IB game .action(\fIcmd\fP,\ \fIobjs\fP,\ \fIrest\fP,\ \fIwhoto\fP) +.B Action +sends a message to some players without affecting +the object hierarchy. It can be used to send transient +events that have no meaning when stored statically +(for example, network latency probes). +The message is sent to the set of players given by +.IR whoto . +.I Objs +is assumed to be a list of object ids, which are +converted appropriately for each player +receiving the message; the final +message is a string built by concatenating +.IR cmd , +the list of object ids, and +.IR rest , +separated by spaces. +.TP +.IB game .player(\fIid\fP) +.B Player +yields the player corresponding to identifier +.IR id , +or +.B nil +if there is none. +.SS Player +The +.B Player +type represents a player of a game. +.TP 10 +.IB player .id +The player's identifier, an integer between +0 and 31. This is unique across all current players, +but ids of players that have left the game will +be reused. +.TP +.IB player .obj(\fIid\fP) +.B Obj +converts from a player's external object +identifier to the game's local +.B Object +that it represents. It returns +.B nil +if there is no such object. +.TP +.IB player .hangup() +.B Hangup +hangs up a player's connection to the game; +no more requests from +.I player +will be received by the game engine. +.TP +.IB player .name() +.B Name +yields the authenticated name of the player. +This is not necessarily unique over the players +of a game. +.SS \fBObject\fP +The +.B Object +type is the basic unit of game engine state. +An object's children can be selectively concealed +from players; it holds a set of +.RI ( attribute ,\ value ) +pairs, each of which can be concealed likewise. +Where an argument +.IR r , +of +.B Range +type is used, it refers to a range of an object's +children starting at index +.IB r .start\fR,\fP +and finishing at +.IB r .end-1\fR.\fP +All the data members of an +.B Object +should be treated as read-only. +.TP 10 +.IB obj .setattr(\fIname\fP,\ \fIval\fP,\ \fIvis\fP) +.B Setattr +sets attribute +.I name +in +.I obj +to +.IR val. +If the attribute is being created for the +first time, then it will be given visibility +.IR vis . +.I Name +should be non-empty, and should not +contain any space characters. +Note that it is not possible for an attribute +to refer directly to an object by its identifier; +if this facility is needed, another identifying +scheme should be used. This also applies +to player identifiers, which will change +if the game is saved and loaded again (not +implemented yet). +.TP +.IB obj .getattr(\fIname\fP) +.B Getattr +yields the current value of the +attribute +.I name +in +.IR obj . +If an attribute is not set, it yields +.BR nil . +.TP +.IB obj .delete() +.B Delete +removes +.I obj +from the object +hierarchy. +.TP +.IB obj .deletechildren(\fIr\fP) +.B Deletechildren +deletes children in range +.I r +from +.IR obj . +.TP +.IB obj .transfer(\fIr\fP,\ \fIdst\fP,\ \fIi\fP) +.B Transfer +transfers the children in range +.I r +from +.I obj +to just before the object at index +.I i +in +.IR dst . +It is permissible for +.I obj +and +.I dst +to be the same object. +.TP +.IB obj .setvisibility(\fIvisibility\fP) +.B Setvisibility +allows the set of players +given in +.I visibility +to see the children of +.IR obj , +and denies access to all others. +Players are notified of the change. +.TP +.IB obj .setattrvisibility(\fIname\fP,\ \fIvisibility\fP) +.B Setattrvisibility +allows the set of players +given in +.I visibility +to see the value of +.IR obj 's +attribute +.IR name , +and denies access to all others. +Players are not notified of the change; +if there is a need to communicate +the fact of an attribute becoming invisible to +players, it should be done by using another +(visible) attribute to communicate the change. +.SS "Module Interface" +A game engine module, +.IR mod , +must implement the +following functions. Where a function returns a string, +it is interpreted as an error response to the player +responsible for the request; an empty string signifies +no error. +.TP +.IB mod .clienttype() +.B Clienttype +should return the type of client required +by the engine (e.g. +.B cards +for the card-game client). +Each client type has its own conventions +as to the meaning of object types and attribute +names and values. +This function may be called before +.BR init() . +.TP +.IB mod .init(\fIgame\fP,\ \fIsrvmod\fP) +.B Init +initialises the game engine. +.I Game +is the game that the engine is controlling, +and +.I srvmod +is the +.B Gamesrv +module holding its associated data. +An error response from this function +causes the game to be aborted. +.TP +.IB mod .join(\fIplayer\fP) +.I Player +has made a request to join the game; +an error response causes the request to be +refused, otherwise the player joins the +game. +.TP +.IB mod .leave(\fIplayer\fP) +.I Player +has left the game. +.TP +.IB mod .command(\fIplayer\fP,\ \fIe\fP) +.I Player +has sent the command +.IR e . +The command usually follows +the simple message conventions +used in +.IR gamesrv (4), +i.e. simple space-separated tokens. +.SH EXAMPLE +The following is a small, but working example +of a game engine that acts as a chat server +(parsing error checking omitted, and white-space +compressed to save paper): +.PP +.EX +.ps -1 +.vs -1 +implement Gamemodule; +include "sys.m"; + sys: Sys; +include "draw.m"; +include "../gamesrv.m"; + gamesrv: Gamesrv; + Game, Player: import gamesrv; +game: ref Game; +clienttype(): string +{ + return "chat"; +} +init(g: ref Game, srvmod: Gamesrv): string +{ + (sys, game, gamesrv) = (load Sys Sys->PATH, g, srvmod); + return nil; +} +join(nil: ref Player): string +{ + return nil; +} +leave(nil: ref Player) +{ +} +command(player: ref Player, cmd: string): string +{ + game.action("say " + string player.id + " " + cmd, nil, nil, ~0); + return nil; +} +.ps +1 +.vs +1 +.EE +.SH SOURCE +.B /appl/cmd/games/gamesrv.b +.SH "SEE ALSO" +.IR gamesrv (4) +.SH BUGS +The reuse of object ids can lead to +problems when objects are deleted and +recreated on the server before clients become +aware of the changes. +.PP +This interface is new and will change. diff --git a/appl/spree/man/gamesrv.man4 b/appl/spree/man/gamesrv.man4 new file mode 100644 index 00000000..5db352b3 --- /dev/null +++ b/appl/spree/man/gamesrv.man4 @@ -0,0 +1,296 @@ +.TH GAMESRV 4 +.SH NAME +gamesrv \- game server +.SH SYNOPSIS +.B games/gamesrv +[ +.B -l +] [ +.B -a +.I alg +]... +[ +.B -A +] [ +.IR addr | mntpoint +] +.PP +.IB mntpoint /players +.br +.IB mntpoint /new +.br +.IB mntpoint / n +.SH DESCRIPTION +.B Gamesrv +serves a file system that allows clients to interact +through various types of game engine. +Usually, it operates in network mode: +it listens for incoming connections on +.I addr +(default +.BR tcp!*!3242 ), +authenticates them, and serves files to them. +If the +.B -A +option is given, no authentication takes place, +otherwise each +.I alg +gives an additional possible +encryption or digest algorithm to use +on the connection (see +.IR ssl (3)). +If no +.I alg +is specified, +.B none +is assumed. +The +.B -l +option causes the game server to be mounted +locally on +.I mntpoint +\- this can be useful for single player games, +or debugging. +.PP +Once the name-space served by +.I gamesrv +is mounted, it serves the following files. +All identifiers referred to below are +small integers, expressed as decimal ASCII strings. +.TP +.B players +Reading this file provides updates on players +arriving and leaving, games being created +and destroyed, and chat messages outside +the scope of any game. +Reads will block until something of interest happens. +Each update holds space separated +tokens and is terminated with a newline. +A read will return as many updates as will fit +into the read buffer. Update messages are as follows: +.RS +.TP +.BI clientid " clientid name" +Identifies the name, +.IR name , +and the client identifier, +.IR clientid , +of the client +reading the players file. +.TP +.BI join " clientid name" +A client has authenticated as +.IR name , +and has been allocated identifier +.IR clientid . +.TP +.BI leave " clientid" +The client identified by +.I clientid +has terminated connection with the server. +.TP +.BI gametype " clienttype name" +The server announces the availability of a game +named +.I name +on the server. The game requires a client of +type +.I clienttype +to display the game. +.TP +.BI creategame " gameid name clienttype" +An instance of a game named +.IR name +has been created; it needs a client +of type +.IR clienttype , +and has been given identifier +.IR gameid . +.TP +.BI deletegame " gameid" +The game identified by +.I gameid +has been deleted. +.TP +.BI joingame " gameid clientid playerid name" +Client +.I clientid +(named +.IR name ) +has joined game +.I gameid , +and is allocated player id +.I playerid +in the game. +.TP +.BI leavegame " gameid playerid name" +Player +.I playerid +(named +.IR name ) +has left +.IR gameid . +.TP +.BI chat " clientid msg" +Client +.I clientid +has sent the chat message +.IR msg . +.PP +Writing to the +.B players +file causes a +.B chat +message to be sent to all other clients reading +the players file. All but the first line of the +write request is ignored. +.RE +.TP +.B new +Opening +.B new +prepares to create a new game. +The only message that can be written +to a newly opened game is +.BI \fR``\fPcreate " name"\fR'',\fP +to request a new game named +.IR name . +The write request draws an error +if +.I gamesrv +fails to find and load the requisite game +engine. +If the write succeeds, the game is created, +and game updates can be read in the same +manner as from the +.B players +file. The update messages are as follows: +.RS +.TP +.BI playerid " clientid playerid name" +Identifies the player identifier, +.IR playerid , +and name, +.IR name , +of the reader. +.TP +.BI create " objid parentid visibility objtype" +Create an object, identified by +.IR objid , +at the end of +.IR parentid 's +children +.RI ( parentid +is +.B -1 +for the root object). +.I Visibility +is the visibility set of the object (see +.IR gamesrv (2)), +and +.I objtype +is its type. +.TP +.BI tx " srcid dstid start end index" +Transfer objects from +.I srcid +to +.IR dstid. +Take the objects from the range +.RI [ start ,\ end ) +in the children of +.IR srcid , +and insert them just before +.I index +in +.IR dstid . +Note that when objects are transferred +to an object that conceals its children, +and the object is itself visible, +the objects will first be transferred to the +destination and then deleted; objects transferred +out of such an object will first be created and +.I then +transferred to their destination. +This enables a client to maintain some knowledge +of where an object has been transferred to, even +if the object is no longer visible. +.TP +.BI del " parentid start end" +Delete the range +.RI [ start ,\ end ) +of children from the object identified by +.IR parentid . +.I Gamesrv +guarantees that those objects will themselves +not have any children. +.TP +.BI set " objid attr val" +Set the attribute named +.I attr +on object +.I objid +to +.IR val . +.TP +.BI vis " objid visibility" +The visibility of object +.I objid +has changed to +.IR visibility . +.TP +.I action +Game engines can generate arbitrary messages +of their own devising; such messages are specific +to particular client types. +.PP +Note that a given client does not have to interpret +all the above messages \- different client types +have their own conventions. The +.B card +client type uses most of the above functionality, +for example, whereas a client for the +.B chat +engine listed in +.IR gamesrv (2) +can get away with interpreting only one message, the custom action +.BR chat . +.PP +Writes to the opened game file +are interpreted as game actions by +the game that has been loaded, and acted on accordingly. +Invalid actions will draw a write error. +.RE +.TP +.I n +Once a game has been created, it appears as +a numbered file, corresponding to the +.I gameid +of the game in question. +Opening this file joins the game; reads and writes +work as for the +.B new +file, above. +A single client cannot join a particular game +more than once. +.PP +A zero-length write to any file causes any reads +of that file from the same file descriptor to yield +EOF (no bytes). +This is necessary to force a hangup under +systems such as Windows, where it is not possible +to interrupt a kproc blocked on a network read. +.SH EXAMPLE +The simplest client! +.PP +.EX +mount tcp!somehost.com!3242 /n/remote +{ + echo create chat >[1=0] + cat & + cat >[1=0] < /dev/cons +} <> /n/remote/new +.SH SOURCE +.B /appl/cmd/games/gamesrv.b +.SH SEE ALSO +.IR gamesrv (2) diff --git a/appl/spree/man/styxservers-nametree.man2 b/appl/spree/man/styxservers-nametree.man2 new file mode 100644 index 00000000..f64e519a --- /dev/null +++ b/appl/spree/man/styxservers-nametree.man2 @@ -0,0 +1,180 @@ +.TH STYXSERVERS-NAMETREE 2 +.SH NAME +Styxservers: nametree \- +hierarchical name storage for use with Styxservers. +.SH SYNOPSIS +.EX +include "sys.m"; +include "styx.m"; +include "styxservers.m"; +nametree := load Nametree Nametree->PATH; + Tree: import nametree; + +Tree: adt { + create: fn(t: self ref Tree, parentpath: big, d: Sys->Dir): string; + remove: fn(t: self ref Tree, path: big): string; + wstat: fn(t: self ref Tree, path: big, d: Sys->Dir); + quit: fn(t: self ref Tree); +}; +init: fn(); +start: fn(): (ref Tree, chan of ref Styxservers->Navop); +.EE +.SH DESCRIPTION +.B Nametree +provides the storage for a hierarchical namespace +to be used by +.IR styxservers (2). +After the module is loaded, the +.B init +function should be called to +initialise the module's internal variables. +.B Start +spawns a new +.B nametree +process; it returns a tuple, say +.RI ( tree ,\ c ), +where c is a channel that can be used to create +an instance of +.BR Styxservers->Navigator , +to access files inside +.BR nametree , +and +.I tree +is an adt that allows creation and removal of those files. +On failure, these functions return a string describing +the error. +.PP +Note that the full set of operations on +.B Nametree +(i.e. stat, walk, readdir, wstate, create and remove), +is only available in conjunction with +.BR Styxserver 's +.B Navigator +interface. +Files in the name space are ultimately identified by a 64-bit +.I path +value, which forms the path component of the file's Qid. +(See +.IR intro (5) +for a description of the system's interpretation of Qids.) +.PP +The +.B Tree +operations +are: +.TP 10 +.IB t .create(\fIparentpath\fP,\ \fId\fP) +Create a new file or directory. +.I D +gives the directory information that will be stored +for the file, including its own path value, +given by +.IB d .qid.path . +If the file referenced by +.I parentpath +does not exist, creation will not be allowed, +other than in the special case when +.IB d .qid.path +is equal to +.IR parentpath , +in which case it is assumed to be a root directory +and may be created. This potentially allows a single +.B Nametree +instance to hold many distinct directory hierarchies. +Note that no attempt is made to ensure that +.I parentpath +refers to a directory; the check is assumed to have +been made previously. +When a hierarchy is traversed, +.B Nametree +interprets the name +.RB ` .. ' +itself as `parent directory', and that name should not be created explicitly. +.TP +.IB t .remove(\fIpath\fP) +Remove the file referred to by +.IR path , +and all its descendants. +.TP +.IB t .wstat(\fIpath\fP,\ \fId\fP) +Change the directory information held on file +.IR path . +The Qid path itself cannot be changed by +.IR d . +.TP +.IB t .quit() +Shut down the +.B nametree +process. +.SH EXAMPLE +Here is a complete example that uses +.B Nametree +in conjunction with +.B Styxservers +in order to serve two files +.B data +and +.BR ctl " ..." +and do nothing with them: +.EX +implement Tst; +include "sys.m"; + sys: Sys; +include "draw.m"; +include "styx.m"; +include "styxservers.m"; + styxservers: Styxservers; + Styxserver, Navigator: import styxservers; + nametree: Nametree; + Tree: import nametree; + +Tst: module +{ + init: fn(nil: ref Draw->Context, argv: list of string); +}; + +Qroot, Qctl, Qdata: con big iota; # paths +init(nil: ref Draw->Context, args: list of string) +{ + sys = load Sys Sys->PATH; + styx := load Styx Styx->PATH; + styx->init(); + styxservers = load Styxservers Styxservers->PATH; + styxservers->init(styx); + nametree = load Nametree Nametree->PATH; + nametree->init(); + sys->pctl(Sys->FORKNS, nil); + (tree, treeop) := nametree->start(); + tree.create(Qroot, dir(".", 8r555|Sys->DMDIR, Qroot)); + tree.create(Qroot, dir("ctl", 8r666, Qctl)); + tree.create(Qroot, dir("data", 8r444, Qdata)); + (tchan, srv) := Styxserver.new(sys->fildes(0), + Navigator.new(treeop), Qroot); + while((gm := <-tchan) != nil) { + # normally a pick on gm would act on + # Tmsg.Read and Tmsg.Write at least + srv.default(gm); + } + tree.quit(); +} + +dir(name: string, perm: int, qid: big): Sys->Dir +{ + d := sys->zerodir; + d.name = name; + d.uid = "me"; + d.gid = "me"; + d.qid.path = qid; + if (perm & Sys->DMDIR) + d.qid.qtype = Sys->QTDIR; + else + d.qid.qtype = Sys->QTFILE; + d.mode = perm; + return d; +} +.EE +.SH SOURCE +.B /appl/lib/nametree.b +.SH SEE ALSO +.IR styxservers (2), +.IR intro (5) diff --git a/appl/spree/man/styxservers.man2 b/appl/spree/man/styxservers.man2 new file mode 100644 index 00000000..fca2748a --- /dev/null +++ b/appl/spree/man/styxservers.man2 @@ -0,0 +1,902 @@ +.TH STYXSERVERS 2 +.SH NAME +styxservers \- +Styx server implementation assistance +.SH SYNOPSIS +.EX +include "sys.m"; +include "styx.m"; +Tmsg, Rmsg: import Styx; +include "styxservers.m"; +styxservers := load Styxservers Styxservers->PATH; +Styxserver, Fid, Navigator: import styxservers; + +Styxserver: adt { + fd: ref Sys->FD; # file server end of connection + t: ref Navigator; # name space navigator for this server + msize: int; # negotiated Styx message size + + new: fn(fd: ref Sys->FD, t: ref Navigator, rootpath: big) + :(chan of ref Tmsg, ref Styxserver); + reply: fn(srv: self ref Styxserver, m: ref Rmsg): int; + + # protocol operations + attach: fn(srv: self ref Styxserver, m: ref Tmsg.Attach): ref Fid; + clunk: fn(srv: self ref Styxserver, m: ref Tmsg.Clunk): ref Fid; + walk: fn(srv: self ref Styxserver, m: ref Tmsg.Walk): ref Fid; + open: fn(srv: self ref Styxserver, m: ref Tmsg.Open): ref Fid; + read: fn(srv: self ref Styxserver, m: ref Tmsg.Read): ref Fid; + remove: fn(srv: self ref Styxserver, m: ref Tmsg.Remove): ref Fid; + stat: fn(srv: self ref Styxserver, m: ref Tmsg.Stat); + default: fn(srv: self ref Styxserver, gm: ref Tmsg); + + # check validity + cancreate: fn(srv: self ref Styxserver, m: ref Tmsg.Create) + :(ref Fid, int, ref Sys->Dir, string); + canopen: fn(srv: self ref Styxserver, m: ref Tmsg.Open) + :(ref Fid, int, ref Sys->Dir, string); + canread: fn(srv: self ref Styxserver, m: ref Tmsg.Read) + :(ref Fid, string); + canwrite: fn(srv: self ref Styxserver, m: ref Tmsg.Write) + :(ref Fid, string); + + # fid management + getfid: fn(srv: self ref Styxserver, fid: int): ref Fid; + newfid: fn(srv: self ref Styxserver, fid: int): ref Fid; + delfid: fn(srv: self ref Styxserver, c: ref Fid); + allfids: fn(srv: self ref Styxserver): list of ref Fid; + + iounit: fn(srv: self ref Styxserver): int; +}; + +Fid: adt { + fid: int; # client's fid + path: big; # file's 64-bit unique path + qtype: int; # file's qid type (eg, Sys->QTDIR if directory) + isopen: int; # non-zero if file is open + mode: int; # if open, the open mode + uname: string; # user name from original attach + param: string; # attach aname from original attach + data: array of byte; # application data + + clone: fn(f: self ref Fid, nf: ref Fid): ref Fid; + open: fn(f: self ref Fid, mode: int, qid: Sys->Qid); + walk: fn(f: self ref Fid, qid: Sys->Qid); +}; + +Navop: adt { + reply: chan of (ref Sys->Dir, string); # channel for reply + path: big; # file or directory path + pick { + Stat => + Walk => + name: string; + Readdir => + offset: int; # index (origin 0) of first entry to return + count: int; # number of directory entries requested + } +}; + +Navigator: adt { + new: fn(c: chan of ref Navop): ref Navigator; + stat: fn(t: self ref Navigator, path: big): (ref Sys->Dir, string); + walk: fn(t: self ref Navigator, parent: big, name: string) + : (ref Sys->Dir, string); + readdir:fn(t: self ref Navigator, path: big, + offset, count: int): array of ref Sys->Dir; +}; + +init: fn(styx: Styx); +traceset: fn(on: int); + +readbytes: fn(m: ref Styx->Tmsg.Read, d: array of byte): + ref Styx->Rmsg.Read; +readstr: fn(m: ref Styx->Tmsg.Read, s: string): + ref Styx->Rmsg.Read; +openok: fn(uname: string, omode, + perm: int, funame, fgname: string): int; +openmode: fn(o: int): int; +.EE +.SH DESCRIPTION +When writing a Styx file server, there are some +commonly performed tasks that are +fiddly or tedious to implement each time. +.B Styxservers +provides a framework to automate some of these +routine tasks. +In particular, it helps manage the fid space, +implements common default processing for protocol messages, +and assists walking around the +directory hierarchy and reading of directories. Other +tasks, such as defining the structure of the +name space, and reading and writing files in it, are +left to the file server program itself. +Familiarity with Section 5 of the manual which defines the protocol +(see +.IR intro (5)), +and with the representation of Styx messages in Limbo +(see +.IR styx (2)), +is a prerequisite for use of this module. +.PP +.B Styxservers +does not define or store any of the directory hierarchy itself; +instead it queries an external process for information +when necessary, through a value of type +.BR Navigator , +which encapsulates communication with that process. +That process must be started up +independently of each +.BR Styxserver ; +a channel to such a process should be provided +when starting a new +.BR Styxserver . +The channel carries messages of type +.BR Navop . +.IR Styxservers-nametree (2) +provides a ready-made +implementation of such a process that is sufficient for many applications. +.PP +.B Styxserver +keeps tabs on the fids that are currently in use, and remembers +some associated information, such as the Qid path +of the file, whether it has been opened, etc. +It does this using values of type +.BR Fid . +.PP +Once the +.B Styxservers +module has been loaded, +the +.B init +function must be called before anything else, +to initialise its internal state. The +.I styx +argument should be an implementation of +the +.IR styx (2) +module, which will be used to translate messages. +Individual +.B Styxserver +instances do not share state, and are therefore +independently thread-safe. +.SS Fid representation +.B Styxservers +represents each active fid as a +.B Fid +value, +which has the following public members: +.TF param +.TP +.B fid +The integer +.I fid +value provided by the client to refer to an active instance of a file in the file server, +as described in +.IR intro (5). +.TP +.B path +The 64-bit qid path that uniquely identifies the file on the file server, +as described in +.IR intro (5). +It is set by +.IB f .walk +and +.IB f .open +(see below). +.TP +.B qtype +The file's qid type; it is +.B Sys->QTDIR +if and only if the fid refers to a directory. +The value is set by +.IB f .walk +and +.IB f .open +(see below). +.TP +.B isopen +Non-zero if and only if the fid has been opened by an +.IR open (5) +message. +It is initially zero, and set by +.IB f .open +(see below). +.TP +.B mode +Valid only if the fid has been opened. +It has one of the values +.BR Sys->OREAD , +.BR Sys->OWRITE , +.BR Sys->ORDWR , +possibly ORed with +.BR Sys->ORCLOSE , +corresponding to the mode with which the file was opened. +It is set by +.IB f .open +(see below). +.TP +.B uname +The name of the user that created the fid. +.TP +.B param +Set by +.B Styxservers +to the +.B aname +of the initial +.IR attach (5) +message, +and subsequently inherited by each new fid created by +.IR walk (5), +but not otherwise used by +.B Styxservers +itself, and may be changed by the application. +.TP +.B data +Unused by +.BR Styxservers ; +for application use. +It might be used, for instance, to implement a file that gives different +data to different clients. +.TP +.IB f .clone( nf ) +Copy the current state of all members of +.I f +except +.IB f .fid\f1,\fP +into +.IR nf , +and return +.IR nf . +Used by +.BR Styxserver.walk , +and is needed by an application only if it replaces that function. +.TP +.IB f .walk( qid ) +Make +.I f +refer to the file with the given +.IR qid : +set +.IB f .path +and +.IB f .qtype +from +.IB qid .path +and +.IB qid .qtype . +Used by +.IB Styxserver.walk +and is needed by an application only if it replaces that function. +.TP +.IB f .open( mode,\ qid ) +Mark +.I f +as `open', +set +.IR f .mode +to +.IR mode , +and set +.B path +and +.B qtype +to the path and type of +.IR qid . +Used by the +implementations of +.B open +and +.B create +messages. +The default implementation of +.IR open (5) +in +.B Styxserver +obtains the value of +.I mode +from +.B Styxserver.canopen +(below), +and +obtains the value of +.I qid +by querying the application's navigator. +.SS Styxserver and file server state +Each +.B Styxserver +value holds the state for a single file server, including its active fids, +the link to the external name space process, and other internal data. +Most of the state is manipulated through the member functions described below. +The exceptions are two read-only values: +the +.B Navigator +reference +.IB srv .t +which can be used to access that navigator; and +the file descriptor +.IB srv .fd +that is the file server's end of the connection to the Styx client. +Both values are initially provided by the file serving application, +but can be accessed through the +.B Styxserver +value for convenience. +The file descriptor value is normally used only through +.BR Styxserver.reply , +but will be needed directly if the caller needs the file descriptor value +as a parameter to +.IR sys-pctl (2) +when insulating the serving process's file descriptors from the surrounding environment. +.PP +The first set of functions in +.B Styxserver +provides common and default actions: +.TP +.B Styxserver.new(\fIfd\fP,\ \fIt\fP,\ \fIrootpath\fP) +Create a new +.BR Styxserver . +It returns a tuple, say +.RI ( c ", " srv ), +and spawns a new process, which uses +.IR styx (2) +to read and parse Styx messages read +from +.IR fd , +and send them down +.IR c ; +.I t +should be a +.B Navigator +adt which the +.B Styxserver +can use to answer queries +on the name space (see ``Navigating file trees'', below). +.I Rootpath +gives the Qid path of the root of the served name space. +.TP +.IB srv .reply(\fIm\fP) +Send a reply (R-message) to a client. The various utility methods, +listed below, call this function to make their response. +.TP +.IB srv .attach(\fIm\fP) +Respond to an +.IR attach (5) +message +.IR m , +creating a new fid in the process, and returning it. +Returns +.B nil +if +.IB m .fid +is a duplicate of an existing fid. +The value of the attach parameter +.IB m .aname +is copied into the new fid's +.B param +field, as is the attaching user name, +.IB m .uname . +.TP +.IB srv .clunk(\fIm\fP) +Respond to a +.IR clunk (5) +message +.IR m , +and return the old +.BR Fid . +Note that this does nothing about remove-on-close +files; that should be programmed explicitly if needed. +.TP +.IB srv .walk(\fIm\fP) +Respond to a +.IR walk (5) +message +.IR m , +querying +.IB srv . t +for information on existing files. +.TP +.IB srv .open(\fIm\fP) +Respond to an +.IR open (5) +message +.IR m . +This will allow a file to be opened if its permissions allow the +specified mode of access. +.TP +.IB srv .read(\fIm\fP) +Respond to a +.IR read (5) +message +.IR m . +If a directory is being read, the appropriate reply +is made; for files, an error is given. +.TP +.IB srv .remove(\fIm\fP) +Respond to a +.IR remove (5) +message +.IR m +with an error, clunking the fid as it does so, +and returning the old +.BR Fid . +.TP +.IB srv .stat(\fIm\fP) +Respond to a +.IR stat (5) +message +.IR m . +.TP +.IB srv .default(\fIgm\fP) +Respond to an arbitrary T-message, +.IR gm , +as appropriate (eg, by calling +.IB srv .walk +for a +.IR walk (5) +message). +It responds appropriately to +.IR version (5), +and replies to +.B Tauth +(see +.IR attach (5)) +stating that authentication is not required. +Other messages without an associated +.B Styxserver +function are generally responded to +with a ``permission denied'' error. +.PP +All the functions above check the validity of the fids, modes, counts and offsets +in the messages, and automatically reply to the client with a suitable +.IR error (5) +message on error. +.PP +The following further +.B Styxserver +operations are useful +in applications that override all or part of the default handling +(in particular, +to process read and write requests): +.TP +.IB srv .canopen( m ) +Check whether it is legal to open a file as requested by message +.IR m : +the fid is valid but not already open, the corresponding file exists and its +permissions allow access in the requested mode, and if +.B Sys->ORCLOSE +is requested, the parent directory is writable (to allow the file to be removed when closed). +.B Canopen +returns a tuple, say +.RI ( f ,\ mode ,\ d,\ err\ \fP). +If the open request was invalid, +.I f +will be nil, and the string +.I err +will diagnose the error (for return to the client in an +.B Rmsg.Error +message). +If the request was valid: +.I f +contains the +.B Fid +representing the file to be opened; +.I mode +is the access mode derived from +.IB m .mode , +.BR Sys->OREAD , +.BR Sys->OWRITE , +.BR Sys->ORDWR , +ORed with +.BR Sys->ORCLOSE ; +.I d +is a +.B Dir +value giving the file's attributes, obtained from the navigator; +and +.I err +is nil. +Once the application has done what it must to open the file, +it must call +.IB f .open +to mark it open. +.TP +.IB srv .cancreate( m ) +Checks whether the +creation of the file requested by +message +.I m +is legal: +the fid is valid but not open, refers to a directory, +the permissions returned by +.IR srv .t.stat +show that directory is writable by the requesting user, +the name does not already exist in that directory, +and the mode with which the new file would be opened is valid. +.B Cancreate +returns a tuple, say +.RI ( f ,\ mode,\ d,\ err\ \fP). +If the creation request was invalid, +.I f +will be nil, and the string +.I err +will diagnose the error, for use in an error reply to the client. +If the request was valid: +.I f +contains the +.B Fid +representing the parent directory; +.I mode +is the open mode as defined for +.B canopen +above; +.I d +is a +.B Dir +value containing some initial attributes for the new file or directory; +and +.I err +is nil. +The initial attributes set in +.I d +are: +.IB d .name +(the name of the file to be created); +.IB d .uid +and +.IB d .muid +(the user that did the initial attach); +.IB d .gid , +.IB d .dtype , +.IB d .dev +(taken from the parent directory's attributes); +and +.IB d .mode +holds the file mode that should be attributed to the new +file (taking into account the parent mode, as +described in +.IR open (5)). +The caller must supply +.IB d .qid +once the file has successfully been created, +and +.IB d .atime +and +.IB d .mtime ; +it must also call +.IB f .open +to mark +.I f +open and set its path to the file's path. +If the file cannot be created successfully, the application should reply with +an +.IR error (5) +message and leave +.I f +untouched. +The +.B Fid +.I f +will then continue to refer to the original directory, and remain unopened. +.TP +.IB srv .canread( m ) +Checks whether +.IR read (5) +message +.I m +refers to a valid fid that has been opened for reading, +and that the count and file offset are non-negative. +.B Canread +returns a tuple, say +.RI ( f ,\ err ); +if the attempted access is illegal, +.I f +will be nil, and +.I err +contains a description of the error, +otherwise +.I f +contains the +.B Fid +corresponding to the file in question. +It is typically called by an application's implementation of +.B Tmsg.Read +to obtain the +.B Fid +corresponding to the fid in the message, and check the access. +.TP +.IB srv .canwrite( m ) +Checks whether +message +.I m +refers to a valid fid that has been opened for writing, +and that the file offset is non-negative. +.B Canwrite +returns a tuple, say +.RI ( f ,\ err ); +if the attempted access is illegal, +.I f +will be nil, and +.I err +contains a description of the error, +otherwise +.I f +contains the +.B Fid +corresponding to the file in question. +It is typically called by an application's implementation of +.B Tmsg.Write +to obtain the +.B Fid +corresponding to the fid in the message, and check the access. +.TP +.IB srv .iounit() +Return an appropriate value for use as the +.I iounit +element in +.B Rmsg.Open +and +.B Rmsg.Create +replies, +as defined in +.IR open (5), +based on the message size negotiated by the initial +.IR version (5) +message. +.PP +The remaining functions are normally used only by servers that need to +override default actions. +They maintain and access the mapping between a client's fid values presented in +.B Tmsg +messages and the +.B Fid +values that represent the corresponding files internally. +.TP +.IB srv .newfid(\fIfid\fP) +Create a new +.B Fid +associated with number +.I fid +and return it. +Return nil if the +.I fid +is already in use (implies a client error if the server correctly clunks fids). +.TP +.IB srv .getfid(\fIfid\fP) +Get the +.B Fid +data associated with numeric id +.IR fid ; +return nil if there is none such (a malicious or erroneous client +can cause this). +.TP +.IB srv .delfid(\fIfid\fP) +Delete +.I fid +from the table of fids in the +.BR Styxserver . +(There is no error return.) +.TP +.IB srv .allfids() +Return a list of all current fids (ie, the files currently active on the client). +.PP +.B Newfid +is required when processing +.IR auth (5), +.IR attach (5) +and +.IR walk (5) +messages to create new fids. +.B Delfid +is used to clunk fids when processing +.IR clunk (5), +.IR remove (5), +and in a failed +.IR walk (5) +when it specified a new fid. +All other messages should refer only to already existing fids, and the associated +.B Fid +data is fetched by +.BR getfid . +.SS Navigating file trees +When a +.B Styxserver +instance needs to know about the namespace, +it queries an external process through a channel +by sending a +.B Navop +request; +each such request carries with it a +.B reply +channel through which the +reply should be made. +The reply tuple has a reference to a +.B Sys->Dir +value that is non-nil on success, and a diagnostic string +that is non-nil on error. +.PP +Files in the tree are referred to +by their Qid +.BR path . +The requests are: +.TF Walk +.TP +.BR Stat +.br +Find a file in the hierarchy by its +.BR path , +and reply with the corresponding +.B Dir +data if found (or a diagnostic on error). +.TP +.BR Walk +.br +Look for file +.B name +in the directory with the given +.BR path . +.TP +.BR Readdir +.br +Get information on selected files in the directory with the given +.BR path . +In this case, the reply channel is used to send +a sequence of values, one for each entry in the directory, finishing with a tuple value +.BR (nil,nil) . +The entries to return are those selected by an +.B offset +that is the index (origin 0) of the first directory entry to return, +and a +.B count +of a number of entries to return starting with that index. +Note that both values are expressed in units of directory entries, not as byte counts. +.PP +.B Styxserver +provides a +.B Navigator +adt to enable convenient access to this functionality; calls +into the +.B Navigator +adt are bundled up into requests on the channel, and the +reply returned. +The functions provided are: +.TP 10 +.BI Navigator.new( c ) +Create a new +.BR Navigator , +sending requests down +.IR c . +.TP +.IB t .stat(\fIpath\fP) +Find the file with the given +.IR path . +Return a tuple +.RI ( d ,\ err ), +where +.I d +holds directory information for the file +if found; otherwise +.I err +contains an error message. +.TP +.IB t .walk(\fIparent\fP,\ \fIname\fP) +Find the file with name +.I name +inside parent directory +.IR parent . +Return a tuple as for +.BR stat . +.TP +.IB t .readdir(\fIpath\fP,\ \fIoffset\fP,\ \fIcount\fP) +Return directory data read from directory +.IR path , +starting at entry +.I offset +for +.I count +entries. +.SS Other functions +The following functions provide some commonly used functionality: +.TP 10 +.BI readbytes( m ,\ d ) +Assuming that the file in question contains data +.IR d , +.B readbytes +returns an appropriate reply to +.IR read (5) +message +.IR m , +taking account of +.IB m .offset +and +.IB m.count +when extracting data from +.IR d . +.TP 10 +.BI readstr( m ,\ s ) +Assuming that the file in question contains string +.IR s , +.B readstr +returns an appropriate reply to +.IR read (5) +message +.IR m , +taking account of +.IB m .offset +and +.IB m.count +when extracting data from the UTF-8 representation of +.IR s . +.TP +.BI openok (\fIuname\fP,\ \fIomode\fP,\ \fIperm\fP,\ \fIfuid\fP,\ \fIfgid\fP) +Does standard permission checking, assuming user +.I uname +is trying to open a file with access mode +.IR omode , +where the file is owned by +.IR fuid , +has group +.IR fgid , +and permissions +.IR perm . +Returns true (non-zero) if permission would be granted, and false (zero) otherwise. +.TP +.BI openmode( o ) +Checks to see whether the open mode +.I o +is well-formed; if it is not, +.B openmode +returns -1; if it is, it returns the mode +with OTRUNC and ORCLOSE flags removed. +.TP +.BI traceset( on ) +If +.I on +is true (non-zero), +will trace Styx requests and replies, on standard error. +This option must be set before creating a +.BR Styxserver , +to ensure that it preserves its standard error descriptor. +.SS Constants +.B Styxservers +defines a number of constants applicable to the writing +of Styx servers, including: +.TP +.BR Einuse\fP,\fP\ Ebadfid\fP,\fP\ Eopen\fP,\fP\ Enotfound\fP,\fP\ Enotdir\fP,\fP\ Eperm\fP,\fP\ Ebadarg\fP,\fP\ Eexists +These provide standard strings for commonly used error conditions, +to be used in +.B Rmsg.Error +replies. +.SS Authentication +If authentication is required beyond that provided at the link level +(for instance by +.IR security-auth (2)), +the server application must handle +.B Tauth +itself, +remember the value of +.I afid +in that message, and generate an +.B Rauth +reply with a suitable Qid referring to a file with +.B Qid.qtype +of +.BR QTAUTH . +Following successful authentication by read and write on that file, +it must associate that status with the +.IR afid . +Then, on a subsequent +.B Tattach +message, before calling +.I srv .attach +it must check that the +.BR Tattach 's +.I afid +value corresponds to one previously authenticated, and +reply with an appropriate error if not. +.SH SOURCE +.B /appl/lib/styxservers.b +.SH SEE ALSO +.IR styxservers-nametree (2), +.IR sys-stat (2), +.IR intro (5) diff --git a/appl/spree/mkfile b/appl/spree/mkfile new file mode 100644 index 00000000..ca94b6c0 --- /dev/null +++ b/appl/spree/mkfile @@ -0,0 +1,66 @@ +<../../mkconfig + +ENGINES=\ + engines/afghan.dis \ + engines/bounce.dis \ + engines/canfield.dis \ + engines/freecell.dis \ + engines/gather.dis \ + engines/lobby.dis \ + engines/othello.dis \ + engines/racingdemon.dis \ + engines/spit.dis \ + engines/spider.dis \ + engines/whist.dis \ + +CLIENTS=\ + clients/cards.dis \ + clients/gather.dis \ + clients/lobby.dis \ + clients/othello.dis \ + +LIB=\ + lib/allow.dis \ + lib/cardlib.dis \ + lib/commandline.dis \ + lib/objstore.dis \ + lib/tricks.dis \ + +MAIN=\ + archives.dis \ + join.dis \ + spree.dis \ + +MODULES=\ + sys.m\ + draw.m\ + tk.m\ + tkclient.m\ + styx.m\ + styxservers.m\ + +DEST=$ROOT/dis/spree + +ALL= ${ENGINES:%=$DEST/%} \ + ${CLIENTS:%=$DEST/%} \ + ${LIB:%=$DEST/%} \ + ${MAIN:%=$DEST/%} + +all:V: $ENGINES $CLIENTS $LIB $MAIN + +install:V: $ALL + +$ROOT/dis/spree/%.dis: %.dis + cp $prereq $target + +%.dis: %.b + limbo -gw -I lib -o $stem.dis $stem.b + +$ENGINES $MAIN $LIB: spree.m gather.m lib/cardlib.m lib/allow.m lib/objstore.m +$ENGINES $MAIN $CLIENTS $LIB: ${MODULES:%=$ROOT/module/%} + +clean:V: + rm -f *.dis *.sbl */*.dis */*.sbl + +nuke:V: clean + rm -f $DEST/*.dis $DEST/*/*.dis diff --git a/appl/spree/other/tst.b b/appl/spree/other/tst.b new file mode 100644 index 00000000..3b35fefa --- /dev/null +++ b/appl/spree/other/tst.b @@ -0,0 +1,151 @@ +implement Tst; +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Point, Rect: import draw; +include "bufio.m"; + bufio: Bufio; + Iobuf: import bufio; + +Tst: module +{ + init: fn(ctxt: ref Draw->Context, argv: list of string); +}; + +File: adt { + name: string; + fd: ref Sys->FD; + pid: int; +}; + +files: list of ref File; + +stderr: ref Sys->FD; +outputch: chan of chan of string; +init(ctxt: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + bufio = load Bufio Bufio->PATH; + sys->print(":cardtst\n"); + stdin := bufio->fopen(sys->fildes(0), Sys->OREAD); + line := ""; + currfd: ref Sys->FD; + outputch = chan of chan of string; + spawn outputproc(); + while ((s := stdin.gets('\n')) != nil) { + if (len s > 1 && s[len s - 2] == '\\') + line += s[0:len s - 2] + "\n"; + else { + s = line + s; + line = nil; + if (s[0] == ':') { + (nil, toks) := sys->tokenize(s, " \n"); + case hd toks { + ":open" => + if (tl toks == nil) { + sys->fprint(stderr, "usage: open file\n"); + continue; + } + f := open(hd tl toks); + if (f != nil) { + currfd = f.fd; + sys->print("current file is now %s\n", f.name); + } + ":close" => + if (tl toks == nil) { + sys->fprint(stderr, "usage: close file\n"); + continue; + } + fl := files; + f: ref File; + for (files = nil; fl != nil; fl = tl fl) { + if ((hd fl).name == hd tl toks) + f = hd fl; + else + files = hd fl :: files; + } + if (f == nil) { + sys->fprint(stderr, "unknown file '%s'\n", hd tl toks); + continue; + } + sys->fprint(f.fd, ""); + f = nil; + ":files" => + for (fl := files; fl != nil; fl = tl fl) { + if ((hd fl).fd == currfd) + sys->print(":%s <--- current\n", (hd fl).name); + else + sys->print(":%s\n", (hd fl).name); + } + * => + for (fl := files; fl != nil; fl = tl fl) + if ((hd fl).name == (hd toks)[1:]) + break; + if (fl == nil) { + sys->fprint(stderr, "unknown file '%s'\n", (hd toks)[1:]); + continue; + } + currfd = (hd fl).fd; + } + } else if (currfd == nil) + sys->fprint(stderr, "no current file\n"); + else if (len s > 1 && sys->fprint(currfd, "%s", s[0:len s - 1]) == -1) + sys->fprint(stderr, "command failed: %r\n"); + } + } + for (fl := files; fl != nil; fl = tl fl) + kill((hd fl).pid); + outputch <-= nil; +} + +open(f: string): ref File +{ + fd := sys->open("/n/remote/" + f, Sys->ORDWR); + if (fd == nil) { + sys->fprint(stderr, "cannot open %s: %r\n", f); + return nil; + } + sync := chan of int; + spawn updateproc(f, fd, sync); + files = ref File(f, fd, <-sync) :: files; + sys->print("opened %s\n", f); + return hd files; +} + +updateproc(name: string, fd: ref Sys->FD, sync: chan of int) +{ + sync <-= sys->pctl(0, nil); + c := chan of string; + buf := array[Sys->ATOMICIO] of byte; + while ((n := sys->read(fd, buf, len buf)) > 0) { + (nt, toks) := sys->tokenize(string buf[0:n], "\n"); + outputch <-= c; + c <-= "++ " + name + ":\n"; + for (; toks != nil; toks = tl toks) + c <-= sys->sprint("+%s\n", hd toks); + c <-= nil; + } + if (n < 0) + sys->fprint(stderr, "cards: error reading %s: %r\n", name); + sys->fprint(stderr, "cards: updateproc (%s) exiting\n", name); +} + +outputproc() +{ + for (;;) { + c := <-outputch; + if (c == nil) + exit; + while ((s := <-c) != nil) + sys->print("%s", s); + } +} + +kill(pid: int) +{ + if ((fd := sys->open("/prog/"+string pid+"/ctl", Sys->OWRITE)) != nil) + sys->write(fd, array of byte "kill", 4); +} + diff --git a/appl/spree/other/tstboing.b b/appl/spree/other/tstboing.b new file mode 100644 index 00000000..a599a0ab --- /dev/null +++ b/appl/spree/other/tstboing.b @@ -0,0 +1,158 @@ +implement Tst; + +include "sys.m"; + sys: Sys; +include "draw.m"; + draw: Draw; + Point, Rect: import draw; +include "sh.m"; + sh: Sh; + Context: import Sh; +include "math.m"; + math: Math; +ZERO: con 1e-6; + +stderr: ref Sys->FD; + +Tst: module { + init: fn(nil: ref Draw->Context, argv: list of string); +}; +π: con Math->Pi; +Maxδ: con π / 4.0; + +init(nil: ref Draw->Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + math = load Math Math->PATH; + if (len argv != 9) { + sys->fprint(stderr, "args?\n"); + exit; + } + ar := argv2r(tl argv); + br := argv2r(tl tl tl tl tl argv); + + a := Line.new(ar.min, ar.max); # ball + b := Line.new(br.min, br.max); # bat + (hit, hitp, s, t) := b.intersection(a.p, a.v); + if (hit) { + nv := boing(a.v, b); + rl := ref Line(hitp, nv, 50.0); + ballθ := a.θ(); + batθ := b.θ(); + φ := ballθ - batθ; + δ: real; + if (math->sin(φ) > 0.0) + δ = (t / b.s) * Maxδ * 2.0 - Maxδ; + else + δ = (t / b.s) * -Maxδ * 2.0 + Maxδ; + nl := Line.newpolar(rl.p, rl.θ() + δ, rl.s); + sys->print("%s %s %s\n", p2s(rl.point(0.0)), p2s(rl.point(rl.s)), p2s(nl.point(nl.s))); + } else + sys->fprint(stderr, "no hit\n"); +} + +argv2r(v: list of string): Rect +{ + r: Rect; + (r.min.x, v) = (int hd v, tl v); + (r.min.y, v) = (int hd v, tl v); + (r.max.x, v) = (int hd v, tl v); + (r.max.y, v) = (int hd v, tl v); + return r; +} +Line: adt { + p, v: Realpoint; + s: real; + new: fn(p1, p2: Point): ref Line; + hittest: fn(l: self ref Line, p: Point): (Realpoint, real, real); + intersection: fn(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real); + point: fn(b: self ref Line, s: real): Point; + θ: fn(b: self ref Line): real; + newpolar: fn(p: Realpoint, θ: real, s: real): ref Line; +}; + +Realpoint: adt { + x, y: real; +}; + +Line.new(p1, p2: Point): ref Line +{ + ln := ref Line; + ln.p = (real p1.x, real p1.y); + v := Realpoint(real (p2.x - p1.x), real (p2.y - p1.y)); + ln.s = math->sqrt(v.x * v.x + v.y * v.y); + if (ln.s > ZERO) + ln.v = (v.x / ln.s, v.y / ln.s); + else + ln.v = (1.0, 0.0); + return ln; +} + +Line.newpolar(p: Realpoint, θ: real, s: real): ref Line +{ + l := ref Line; + l.p = p; + l.s = s; + l.v = (math->cos(θ), math->sin(θ)); + return l; +} + +Line.θ(l: self ref Line): real +{ + return math->atan2(l.v.y, l.v.x); +} + +# return normal from line, perpendicular distance from line and distance down line +Line.hittest(l: self ref Line, ip: Point): (Realpoint, real, real) +{ + p := Realpoint(real ip.x, real ip.y); + v := Realpoint(-l.v.y, l.v.x); + (nil, nil, perp, ldist) := l.intersection(p, v); + return (v, perp, ldist); +} + +Line.point(l: self ref Line, s: real): Point +{ + return (int (l.p.x + s * l.v.x), int (l.p.y + s * l.v.y)); +} + +# compute the intersection of lines a and b. +# b is assumed to be fixed, and a is indefinitely long +# but doesn't extend backwards from its starting point. +# a is defined by the starting point p and the unit vector v. +# return whether it hit, the point at which it hit if so, +# the distance of the intersection point from p, +# and the distance of the intersection point from b.p. +Line.intersection(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real) +{ + det := b.v.x * v.y - v.x * b.v.y; + if (det > -ZERO && det < ZERO) + return (0, (0.0, 0.0), 0.0, 0.0); + + y21 := b.p.y - p.y; + x21 := b.p.x - p.x; + s := (b.v.x * y21 - b.v.y * x21) / det; + t := (v.x * y21 - v.y * x21) / det; + if (s < 0.0) + return (0, (0.0, 0.0), s, t); + hit := t >= 0.0 && t <= b.s; + hp: Realpoint; + if (hit) + hp = (p.x+v.x*s, p.y+v.y*s); + return (hit, hp, s, t); +} + +# bounce ball travelling in direction av off line b. +# return the new unit vector. +boing(av: Realpoint, b: ref Line): Realpoint +{ + d := math->atan2(real b.v.y, real b.v.x) * 2.0 - math->atan2(av.y, av.x); + return (math->cos(d), math->sin(d)); +} + +p2s(p: Point): string +{ + return string p.x + " " + string p.y; +} + diff --git a/appl/spree/other/tstlines.sh b/appl/spree/other/tstlines.sh new file mode 100755 index 00000000..7e75b3a4 --- /dev/null +++ b/appl/spree/other/tstlines.sh @@ -0,0 +1,53 @@ +#!/dis/sh +load tk std +pctl newpgrp +wid=${tk window 'Test lines'} +fn x {tk $wid $*} +x canvas .c +x pack .c +x 'bind .c <ButtonRelease-1> {send b1 %x %y}' +x 'bind .c <ButtonRelease-2> {send b2 %x %y}' +x update +chan b1 b2 +tk namechan $wid b1 +tk namechan $wid b2 +while {} {tk winctl $wid ${recv $wid}} & +chan show +ifs=' +' +v1 := 0 0 1 1 +v2 := 1 1 2 2 +while {} { + args:=${split ${recv show}} + (t args) = $args + $t = $args + + tk 0 .c delete lines + echo $v1 $v2 + r := `{tstboing $v1 $v2} + (ap1x ap1y ap2x ap2y bp1x bp1y bp2x bp2y) := $v1 $v2 + tk 0 .c create line $ap1x $ap1y $ap2x $ap2y -tags lines -fill black -width 3 -arrow last + tk 0 .c create line $bp1x $bp1y $bp2x $bp2y -tags lines -fill red + and {~ $#r 6} { + (rp1x rp1y rp2x rp2y sp2x sp2y) := $r + tk 0 .c create line $ap2x $ap2y $rp1x $rp1y -tags lines -fill black + tk 0 .c create line $rp1x $rp1y $rp2x $rp2y -tags lines -fill green -arrow last + tk 0 .c create line $rp1x $rp1y $sp2x $sp2y -tags lines -fill blue -arrow last + } + tk 0 update +} & + +fn show { + a:=$* + if {~ $#a 8} {echo usage} { + send show ${join ' ' $a} + } +} + +for i in 1 2 { + while {} { + p1:=${recv b^$i} + p2:=${recv b^$i} + send show ${join ' ' v^$i $p1 $p2} + } & +} diff --git a/appl/spree/other/tstwin.b b/appl/spree/other/tstwin.b new file mode 100644 index 00000000..de7c7ab4 --- /dev/null +++ b/appl/spree/other/tstwin.b @@ -0,0 +1,351 @@ +implement Tstwin; + +include "sys.m"; + sys: Sys; + +include "draw.m"; + draw: Draw; + Context, Display, Point, Rect, Image, Screen: import draw; + +include "tk.m"; + tk: Tk; + Toplevel: import tk; + +include "tkclient.m"; + tkclient: Tkclient; + +include "math.m"; + math: Math; + +Tstwin: module +{ + init: fn(ctxt: ref Context, argv: list of string); +}; + +screen: ref Screen; +display: ref Display; +win: ref Toplevel; + +NC: con 6; + +task_cfg := array[] of { +"label .xy -text {0 0}", +"canvas .c -height 500 -width 500", +"pack .xy -side top -fill x", +"pack .c -side bottom -fill both -expand 1", +"bind .c <ButtonRelease-1> {send cmd 0 1 %x %y}", +"bind .c <ButtonRelease-2> {send cmd 0 2 %x %y}", +"bind .c <Button-1> {send cmd 1 1 %x %y}", +"bind .c <Button-2> {send cmd 1 2 %x %y}", +}; + +Obstacle: adt { + line: ref Line; + s1, s2: real; + id: int; + config: fn(b: self ref Obstacle); + new: fn(id: int): ref Obstacle; +}; + +Line: adt { + p, v: Realpoint; + s: real; + new: fn(p1, p2: Point): ref Line; + hittest: fn(l: self ref Line, p: Point): (Realpoint, real, real); + intersection: fn(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real); + point: fn(b: self ref Line, s: real): Point; +}; +bats: list of ref Obstacle; +init(ctxt: ref Context, argv: list of string) +{ + sys = load Sys Sys->PATH; + draw = load Draw Draw->PATH; + tk = load Tk Tk->PATH; + tkclient = load Tkclient Tkclient->PATH; + math = load Math Math->PATH; + + sys->pctl(Sys->NEWPGRP, nil); + + display = ctxt.display; + screen = ctxt.screen; + + tkclient->init(); + + menubut: chan of string; + (win, menubut) = tkclient->toplevel(screen, nil, "Window testing", 0); + + cmd := chan of string; + tk->namechan(win, cmd, "cmd"); + + tkclient->tkcmds(win, task_cfg); + + mch := chan of (int, Point); + spawn mouseproc(mch); + + bat := Obstacle.new(0); + bats = bat :: nil; + bat.line = Line.new((100, 0), (150, 500)); + bat.s1 = 10.0; + bat.s2 = 110.0; + bat.config(); + + tk->cmd(win, "update"); + buts := 0; + for(;;) alt { + menu := <-menubut => + tkclient->wmctl(win, menu); + + c := <-cmd => + (nil, toks) := sys->tokenize(c, " "); + if ((hd toks)[0] == '1') + buts |= int hd tl toks; + else + buts &= ~int hd tl toks; + mch <-= (buts, Point(int hd tl tl toks, int hd tl tl tl toks)); + } +} + +Realpoint: adt { + x, y: real; +}; + +cmd(top: ref Tk->Toplevel, s: string): string +{ + e := tk->cmd(top, s); + if (e != nil && e[0] == '!') + sys->print("tk error %s on '%s'\n", e, s); + return e; +} + +p2s(p: Point): string +{ + return string p.x + " " + string p.y; +} + +mouseproc(mch: chan of (int, Point)) +{ + for (;;) { + hitbat: ref Obstacle = nil; + minperp, hitdist: real; + (buts, p) := <-mch; + for (bl := bats; bl != nil; bl = tl bl) { + b := hd bl; + (normal, perp, dist) := b.line.hittest(p); + perp = abs(perp); + + if ((hitbat == nil || perp < minperp) && (dist >= b.s1 && dist <= b.s2)) + (hitbat, minperp, hitdist) = (b, perp, dist); + } + if (hitbat == nil || minperp > 30.0) { + while ((<-mch).t0) + ; + continue; + } + offset := hitdist - hitbat.s1; + if (buts & 2) + (buts, p) = aim(mch, hitbat, p); + if (buts & 1) + drag(mch, hitbat, offset); + } +} + + +drag(mch: chan of (int, Point), hitbat: ref Obstacle, offset: real) +{ + line := hitbat.line; + batlen := hitbat.s2 - hitbat.s1; + + cvsorigin := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty")); + +# cmd(win, "grab set .c"); +# cmd(win, "focus ."); +loop: for (;;) alt { + (buts, p) := <-mch => + if (buts & 2) + (buts, p) = aim(mch, hitbat, p); + (v, perp, dist) := line.hittest(p); + dist -= offset; + # constrain bat and mouse positions + if (dist < 0.0 || dist + batlen > line.s) { + if (dist < 0.0) { + p = line.point(offset); + dist = 1.0; + } else { + p = line.point(line.s - batlen + offset); + dist = line.s - batlen; + } + p.x -= int (v.x * perp); + p.y -= int (v.y * perp); + win.image.display.cursorset(p.add(cvsorigin)); + } + (hitbat.s1, hitbat.s2) = (dist, dist + batlen); + hitbat.config(); + cmd(win, "update"); + if (!buts) + break loop; + } +# cmd(win, "grab release .c"); +} + +CHARGETIME: con 1000.0; +MAXCHARGE: con 50.0; + +α: con 0.999; # decay in one millisecond +Max: con 60.0; +D: con 5; +ZERO: con 1e-6; +aim(mch: chan of (int, Point), hitbat: ref Obstacle, p: Point): (int, Point) +{ + cvsorigin := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty")); + startms := ms := sys->millisec(); + delta := Realpoint(0.0, 0.0); + line := hitbat.line; + charge := 0.0; + pivot := line.point((hitbat.s1 + hitbat.s2) / 2.0); + s1 := p2s(line.point(hitbat.s1)); + s2 := p2s(line.point(hitbat.s2)); + cmd(win, ".c create line 0 0 0 0 -tags wire"); + cmd(win, ".c create oval 0 0 1 1 -fill green -tags ball"); + p2: Point; + buts := 2; + for (;;) { + v := makeunit(delta); + bp := pivot.add((int (v.x * charge), int (v.y * charge))); + cmd(win, ".c coords wire "+s1+" "+p2s(bp)+" "+s2); + cmd(win, ".c coords ball "+string (bp.x - D) + " " + string (bp.y - D) + " " + + string (bp.x + D) + " " + string (bp.y + D)); + cmd(win, "update"); + if ((buts & 2) == 0) + break; + (buts, p2) = <-mch; + now := sys->millisec(); + fade := math->pow(α, real (now - ms)); + charge = real (now - startms) * (MAXCHARGE / CHARGETIME); + if (charge > MAXCHARGE) + charge = MAXCHARGE; + ms = now; + delta.x = delta.x * fade + real (p2.x - p.x); + delta.y = delta.y * fade + real (p2.y - p.y); + mag := delta.x * delta.x + delta.y * delta.y; + win.image.display.cursorset(p.add(cvsorigin)); + } + sys->print("pow\n"); + cmd(win, ".c delete wire ball"); + cmd(win, "update"); + return (buts, p2); +} + +makeunit(v: Realpoint): Realpoint +{ + mag := math->sqrt(v.x * v.x + v.y * v.y); + if (mag < ZERO) + return (1.0, 0.0); + return (v.x / mag, v.y / mag); +} + +#drag(mch: chan of (int, Point), p: Point) +#{ +# down := 1; +# cvsorigin := Point(int cmd(win, ".c cget -actx"), int cmd(win, ".c cget -acty")); +# ms := sys->millisec(); +# delta := Realpoint(0.0, 0.0); +# id := cmd(win, ".c create line " + p2s(p) + " " + p2s(p)); +# coords := ".c coords " + id + " " + p2s(p) + " "; +# do { +# p2: Point; +# (down, p2) = <-mch; +# now := sys->millisec(); +# fade := math->pow(α, real (now - ms)); +# ms = now; +# delta.x = delta.x * fade + real (p2.x - p.x); +# delta.y = delta.y * fade + real (p2.y - p.y); +# mag := delta.x * delta.x + delta.y * delta.y; +# d: Realpoint; +# if (mag > Max * Max) { +# fade = Max / math->sqrt(mag); +# d = (delta.x * fade, delta.y * fade); +# } else +# d = delta; +# +# cmd(win, coords + p2s(p.add((int d.x, int d.y)))); +# win.image.display.cursorset(p.add(cvsorigin)); +# cmd(win, "update"); +# } while (down); +#} +# +Line.new(p1, p2: Point): ref Line +{ + ln := ref Line; + ln.p = (real p1.x, real p1.y); + v := Realpoint(real (p2.x - p1.x), real (p2.y - p1.y)); + ln.s = math->sqrt(v.x * v.x + v.y * v.y); + if (ln.s > ZERO) + ln.v = (v.x / ln.s, v.y / ln.s); + else + ln.v = (1.0, 0.0); + return ln; +} + +# return normal from line, perpendicular distance from line and distance down line +Line.hittest(l: self ref Line, ip: Point): (Realpoint, real, real) +{ + p := Realpoint(real ip.x, real ip.y); + v := Realpoint(-l.v.y, l.v.x); + (nil, nil, perp, ldist) := l.intersection(p, v); + return (v, perp, ldist); +} + +Line.point(l: self ref Line, s: real): Point +{ + return (int (l.p.x + s * l.v.x), int (l.p.y + s * l.v.y)); +} + +# compute the intersection of lines a and b. +# b is assumed to be fixed, and a is indefinitely long +# but doesn't extend backwards from its starting point. +# a is defined by the starting point p and the unit vector v. +# return whether it hit, the point at which it hit if so, +# the distance of the intersection point from p, +# and the distance of the intersection point from b.p. +Line.intersection(b: self ref Line, p, v: Realpoint): (int, Realpoint, real, real) +{ + det := b.v.x * v.y - v.x * b.v.y; + if (det > -ZERO && det < ZERO) + return (0, (0.0, 0.0), 0.0, 0.0); + + y21 := b.p.y - p.y; + x21 := b.p.x - p.x; + s := (b.v.x * y21 - b.v.y * x21) / det; + t := (v.x * y21 - v.y * x21) / det; + if (s < 0.0) + return (0, (0.0, 0.0), s, t); + hit := t >= 0.0 && t <= b.s; + hp: Realpoint; + if (hit) + hp = (p.x+v.x*s, p.y+v.y*s); + return (hit, hp, s, t); +} + +blankobstacle: Obstacle; +Obstacle.new(id: int): ref Obstacle +{ + cmd(win, ".c create line 0 0 0 0 -width 3 -fill #aaaaaa" + " -tags l" + string id); + o := ref blankobstacle; + o.line = Line.new((0, 0), (0, 0)); + o.id = id; + return o; +} + +Obstacle.config(o: self ref Obstacle) +{ + cmd(win, ".c coords l" + string o.id + " " + + p2s(o.line.point(o.s1)) + " " + p2s(o.line.point(o.s2))); + cmd(win, ".c itemconfigure l" + string o.id + " -fill red"); +} + +abs(x: real): real +{ + if (x < 0.0) + return -x; + return x; +} diff --git a/appl/spree/spree.b b/appl/spree/spree.b new file mode 100644 index 00000000..bd6a0aed --- /dev/null +++ b/appl/spree/spree.b @@ -0,0 +1,1554 @@ +implement Spree; + +include "sys.m"; + sys: Sys; +include "readdir.m"; + readdir: Readdir; +include "styx.m"; + Rmsg, Tmsg: import Styx; +include "styxservers.m"; + styxservers: Styxservers; + Styxserver, Fid, Eperm, Navigator: import styxservers; + nametree: Nametree; +include "draw.m"; +include "arg.m"; +include "sets.m"; + sets: Sets; + Set, set, A, B, All, None: import sets; +include "spree.m"; + archives: Archives; + Archive: import archives; + +stderr: ref Sys->FD; +myself: Spree; + +Debug: con 0; +Update: adt { + pick { + Set => + o: ref Object; + objid: int; # member-specific id + attr: ref Attribute; + Transfer => + srcid: int; # parent object + from: Range; # range within src to transfer + dstid: int; # destination object + index: int; # insertion point + Create => + objid: int; + parentid: int; + visibility: Sets->Set; + objtype: string; + Delete => + parentid: int; + r: Range; + objs: array of int; + Setvisibility => + objid: int; + visibility: Sets->Set; # set of members that can see it + Action => + s: string; + objs: list of int; + rest: string; + Break => + # break in transmission + } +}; + +T: type ref Update; +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; +}; + +Openfid: adt { + fid: int; + uname: string; + fileid: int; + member: ref Member; # nil for non-clique files. + updateq: ref Queue; + readreq: ref Tmsg.Read; + hungup: int; + # alias: string; # could use this to allow a member to play themselves + + new: fn(fid: ref Fid, file: ref Qfile): ref Openfid; + find: fn(fid: int): ref Openfid; + close: fn(fid: self ref Openfid); +# cmd: fn(fid: self ref Openfid, cmd: string): string; +}; + +Qfile: adt { + id: int; # index into files array + owner: string; + qid: Sys->Qid; + ofids: list of ref Openfid; # list of all fids that are holding this open + needsupdate: int; # updates have been added since last updateall + + create: fn(parent: big, d: Sys->Dir): ref Qfile; + delete: fn(f: self ref Qfile); +}; + +# which updates do we send even though the clique isn't yet started? +alwayssend := array[] of { + tagof(Update.Set) => 0, + tagof(Update.Transfer) => 0, + tagof(Update.Create) => 0, + tagof(Update.Delete) => 0, + tagof(Update.Setvisibility) => 0, + tagof(Update.Action) => 1, + tagof(Update.Break) => 1, +}; + +srv: ref Styxserver; +tree: ref Nametree->Tree; +cliques: array of ref Clique; +qfiles: array of ref Qfile; +fids := array[47] of list of ref Openfid; # hash table +lobby: ref Clique; +Qroot: big; +sequence := 0; + +fROOT, +fGAME, +fNAME, +fGAMEDIR, +fGAMEDATA: con iota; + +GAMEDIR: con "/n/remote"; +ENGINES: con "/dis/spree/engines"; +ARCHIVEDIR: con "/lib/spreearchive"; + +badmod(p: string) +{ + sys->fprint(stderr, "spree: cannot load %s: %r\n", p); + raise "fail:bad module"; +} + +init(nil: ref Draw->Context, nil: list of string) +{ + sys = load Sys Sys->PATH; + stderr = sys->fildes(2); + myself = load Spree "$self"; + + styx := load Styx Styx->PATH; + if (styx == nil) + badmod(Styx->PATH); + styx->init(); + + styxservers = load Styxservers Styxservers->PATH; + if (styxservers == nil) + badmod(Styxservers->PATH); + styxservers->init(styx); + + nametree = load Nametree Nametree->PATH; + if (nametree == nil) + badmod(Nametree->PATH); + nametree->init(); + + sets = load Sets Sets->PATH; + if (sets == nil) + badmod(Sets->PATH); + sets->init(); + + readdir = load Readdir Readdir->PATH; + if (readdir == nil) + badmod(Readdir->PATH); + + archives = load Archives Archives->PATH; + if (archives == nil) + badmod(Archives->PATH); + archives->init(myself); + + initrand(); + + navop: chan of ref Styxservers->Navop; + (tree, navop) = nametree->start(); + tchan: chan of ref Tmsg; + Qroot = mkqid(fROOT, 0); + (tchan, srv) = Styxserver.new(sys->fildes(0), Navigator.new(navop), Qroot); + nametree->tree.create(Qroot, dir(Qroot, ".", 8r555|Sys->DMDIR, "spree")); + nametree->tree.create(Qroot, dir(mkqid(fNAME, 0), "name", 8r444, "spree")); + (lobbyid, nil, err) := lobby.new(ref Archive("lobby" :: nil, nil, nil, nil), "spree"); + if (lobbyid == -1) { + sys->fprint(stderr, "spree: couldn't start lobby: %s\n", err); + raise "fail:no lobby"; + } + sys->pctl(Sys->FORKNS, nil); + for (;;) { + gm := <-tchan; + if (gm == nil || tagof(gm) == tagof(Tmsg.Readerror)) { + if (gm != nil) { + pick m := gm { + Readerror => + sys->print("spree: read error: %s\n", m.error); + } + } + sys->print("spree: exiting\n"); + exit; + } else { + e := handletmsg(gm); + if (e != nil) + srv.reply(ref Rmsg.Error(gm.tag, e)); + } + } +} + + +dir(qidpath: big, name: string, perm: int, owner: string): Sys->Dir +{ + DM2QT: con 24; + d := Sys->zerodir; + d.name = name; + d.uid = owner; + d.gid = owner; + d.qid.path = qidpath; + d.qid.qtype = (perm >> DM2QT) & 16rff; + d.mode = perm; + # d.atime = now; + # d.mtime = now; + return d; +} + +handletmsg(tmsg: ref Tmsg): string +{ + pick m := tmsg { + Open => + (fid, omode, d, err) := srv.canopen(m); + if (fid == nil) + return err; + if (d.qid.qtype & Sys->QTDIR) { + srv.default(m); + return nil; + } + case qidkind(d.qid.path) { + fGAMEDATA => + fid.open(m.mode, Sys->Qid(fid.path, fid.qtype, 0)); + srv.reply(ref Rmsg.Open(m.tag, Sys->Qid(fid.path, fid.qtype, 0), 0)); + fGAME => + f := qid2file(d.qid.path); + if (f == nil) + return "cannot find qid"; + ofid := Openfid.new(fid, f); + err = openfile(ofid); + if (err != nil) { + ofid.close(); + return err; + } + fid.open(m.mode, f.qid); + srv.reply(ref Rmsg.Open(m.tag, Sys->Qid(fid.path, fid.qtype, 0), 0)); + * => + srv.default(m); + } + updateall(); + Read => + (fid, err) := srv.canread(m); + if (fid == nil) + return err; + if (fid.qtype & Sys->QTDIR) { + srv.default(m); + return nil; + } + case qidkind(fid.path) { + fGAMEDATA => + f := qidindex(fid.path); + id := f & 16rffff; + f = (f >> 16) & 16rffff; + data := cliques[id].mod->readfile(f, m.offset, m.count); + srv.reply(ref Rmsg.Read(m.tag, data)); + fGAME => + ff := Openfid.find(m.fid); + if (ff.readreq != nil) + return "duplicate read"; + ff.readreq = m; + sendupdate(ff); + fNAME => + srv.reply(styxservers->readstr(m, fid.uname)); + * => + return "darn rats!"; + } + Write => + (fid, err) := srv.canwrite(m); + if (fid == nil) + return err; + ff := Openfid.find(m.fid); + err = command(ff, string m.data); + if (err != nil) { + updateall(); + return err; + } + srv.reply(ref Rmsg.Write(m.tag, len m.data)); + updateall(); # XXX might we need to do this on error too? + Clunk => + fid := srv.clunk(m); + if (fid != nil) { + clunked(fid); + updateall(); + } + Flush => + for (i := 0; i < len qfiles; i++) { + if (qfiles[i] == nil) + continue; + for (ol := qfiles[i].ofids; ol != nil; ol = tl ol) { + ofid := hd ol; + if (ofid.readreq != nil && ofid.readreq.tag == m.oldtag) + ofid.readreq = nil; + } + } + srv.reply(ref Rmsg.Flush(m.tag)); +# Removed => clunked too. + * => + srv.default(tmsg); + } + return nil; +} + +clunked(fid: ref Fid) +{ + if (!fid.isopen || (fid.qtype & Sys->QTDIR)) + return; + ofid := Openfid.find(fid.fid); + if (ofid == nil) + return; + if (ofid.member != nil) + memberleaves(ofid.member); + ofid.close(); + f := qfiles[ofid.fileid]; + # if it's the last close, and clique is hung up, then remove clique from + # directory hierarchy. + if (f.ofids == nil && qidkind(f.qid.path) == fGAME) { + g := cliques[qidindex(f.qid.path)]; + if (g.hungup) { + stopclique(g); + nametree->tree.remove(mkqid(fGAMEDIR, g.id)); + f.delete(); + cliques[g.id] = nil; + } + } +} + +mkqid(kind, i: int): big +{ + return big kind | (big i << 4); +} + +qidkind(qid: big): int +{ + return int (qid & big 16rf); +} + +qidindex(qid: big): int +{ + return int (qid >> 4); +} + +qid2file(qid: big): ref Qfile +{ + for (i := 0; i < len qfiles; i++) { + f := qfiles[i]; + if (f != nil && f.qid.path == qid) + return f; + } + return nil; +} + +Qfile.create(parent: big, d: Sys->Dir): ref Qfile +{ + nametree->tree.create(parent, d); + for (i := 0; i < len qfiles; i++) + if (qfiles[i] == nil) + break; + if (i == len qfiles) + qfiles = (array[len qfiles + 1] of ref Qfile)[0:] = qfiles; + f := qfiles[i] = ref Qfile(i, d.uid, d.qid, nil, 0); + return f; +} + +Qfile.delete(f: self ref Qfile) +{ + nametree->tree.remove(f.qid.path); + qfiles[f.id] = nil; +} + +Openfid.new(fid: ref Fid, file: ref Qfile): ref Openfid +{ + i := fid.fid % len fids; + ofid := ref Openfid(fid.fid, fid.uname, file.id, nil, ref Queue, nil, 0); + fids[i] = ofid :: fids[i]; + file.ofids = ofid :: file.ofids; + return ofid; +} + +Openfid.find(fid: int): ref Openfid +{ + for (ol := fids[fid % len fids]; ol != nil; ol = tl ol) + if ((hd ol).fid == fid) + return hd ol; + return nil; +} + +Openfid.close(ofid: self ref Openfid) +{ + i := ofid.fid % len fids; + newol: list of ref Openfid; + for (ol := fids[i]; ol != nil; ol = tl ol) + if (hd ol != ofid) + newol = hd ol :: newol; + fids[i] = newol; + newol = nil; + for (ol = qfiles[ofid.fileid].ofids; ol != nil; ol = tl ol) + if (hd ol != ofid) + newol = hd ol :: newol; + qfiles[ofid.fileid].ofids = newol; +} + +openfile(ofid: ref Openfid): string +{ + name := ofid.uname; + f := qfiles[ofid.fileid]; + if (qidkind(f.qid.path) == fGAME) { + if (cliques[qidindex(f.qid.path)].hungup) + return "hungup"; + i := 0; + for (o := f.ofids; o != nil; o = tl o) { + if ((hd o) != ofid && (hd o).uname == name) + return "you cannot join a clique twice"; + i++; + } + if (i > MAXPLAYERS) + return "too many members"; + } + return nil; +} + +# process a client's command; return a non-nil string on error. +command(ofid: ref Openfid, cmd: string): string +{ + err: string; + f := qfiles[ofid.fileid]; + qid := f.qid.path; + if (ofid.hungup) + return "hung up"; + if (cmd == nil) { + ofid.hungup = 1; + sys->print("hanging up file %s for user %s, fid %d\n", nametree->tree.getpath(f.qid.path), ofid.uname, ofid.fid); + return nil; + } + case qidkind(qid) { + fGAME => + clique := cliques[qidindex(qid)]; + if (ofid.member == nil) + err = newmember(clique, ofid, cmd); + else + err = cliquerequest(clique, ref Rq.Command(ofid.member, cmd)); + * => + err = "invalid command " + string qid; # XXX dud error message + } + return err; +} + +Clique.notify(src: self ref Clique, dstid: int, cmd: string) +{ + if (cmd == nil) + return; # don't allow faking of clique exit. + if (dstid < 0 || dstid >= len cliques) { + if (dstid != -1) + sys->fprint(stderr, "%d cannot notify invalid %d: '%s'\n", src.id, dstid, cmd); + return; + } + dst := cliques[dstid]; + if (dst.parentid != src.id && dstid != src.parentid) { + sys->fprint(stderr, "%d cannot notify %d: '%s'\n", src.id, dstid, cmd); + return; + } + src.notes = (src.id, dstid, cmd) :: src.notes; +} + +# add a new member to a clique. +# it should already have been checked that the member's name +# isn't a duplicate of another in the same clique. +newmember(clique: ref Clique, ofid: ref Openfid, cmd: string): string +{ + name := ofid.uname; + + # check if member was suspended, and give them their old id back + # if so, otherwise find first free id. + for (s := clique.suspended; s != nil; s = tl s) + if ((hd s).name == name) + break; + id: int; + suspended := 0; + member: ref Member; + if (s != nil) { + member = hd s; + # remove from suspended list + q := tl s; + for (t := clique.suspended; t != s; t = tl t) + q = hd t :: q; + clique.suspended = q; + suspended = 1; + member.suspended = 0; + } else { + for (id = 0; clique.memberids.holds(id); id++) + ; + member = ref Member(id, clique.id, nil, nil, nil, name, 0, 0); + clique.memberids = clique.memberids.add(member.id); + } + + q := ofid.updateq; + ofid.member = member; + + started := clique.started; + err := cliquerequest(clique, ref Rq.Join(member, cmd, suspended)); + if (err != nil) { + member.del(0); + if (suspended) { + member.suspended = 1; + clique.suspended = member :: clique.suspended; + } + return err; + } + if (started) { + qrecreateobject(q, member, clique.objects[0], nil); + qfiles[ofid.fileid].needsupdate = 1; + } + member.updating = 1; + return nil; +} + +Clique.start(clique: self ref Clique) +{ + if (clique.started) + return; + + for (ol := qfiles[clique.fileid].ofids; ol != nil; ol = tl ol) + if ((hd ol).member != nil) + qrecreateobject((hd ol).updateq, (hd ol).member, clique.objects[0], nil); + clique.started = 1; +} + +Blankclique: Clique; +maxcliqueid := 0; +Clique.new(parent: self ref Clique, archive: ref Archive, owner: string): (int, string, string) +{ + for (id := 0; id < len cliques; id++) + if (cliques[id] == nil) + break; + if (id == len cliques) + cliques = (array[len cliques + 1] of ref Clique)[0:] = cliques; + + mod := load Engine ENGINES +"/" + hd archive.argv + ".dis"; + if (mod == nil) + return (-1, nil, sys->sprint("cannot load engine: %r")); + + dirq := mkqid(fGAMEDIR, id); + fname := string maxcliqueid++; + e := nametree->tree.create(Qroot, dir(dirq, fname, 8r555|Sys->DMDIR, owner)); + if (e != nil) + return (-1, nil, e); + f := Qfile.create(dirq, dir(mkqid(fGAME, id), "ctl", 8r666, owner)); + objs: array of ref Object; + if (archive.objects != nil) { + objs = archive.objects; + for (i := 0; i < len objs; i++) + objs[i].cliqueid = id; + } else + objs = array[] of {ref Object(0, Attributes.new(), All, -1, nil, id, nil)}; + + memberids := None; + suspended: list of ref Member; + for (i := 0; i < len archive.members; i++) { + suspended = ref Member(i, id, nil, nil, nil, archive.members[i], 0, 1) :: suspended; + memberids = memberids.add(i); + } + + archive = ref *archive; + archive.objects = nil; + + g := cliques[id] = ref Clique( + id, # id + f.id, # fileid + fname, # fname + objs, # objects + archive, # archive + nil, # freelist + mod, # mod + memberids, # memberids + suspended, + chan of ref Rq, # request + chan of string, # reply + 0, # hungup + 0, # started + -1, # parentid + nil # notes + ); + if (parent != nil) { + g.parentid = parent.id; + g.notes = parent.notes; + } + spawn cliqueproc(g); + e = cliquerequest1(g, ref Rq.Init); + if (e != nil) { + stopclique(g); + nametree->tree.remove(dirq); + f.delete(); + cliques[id] = nil; + return (-1, nil, e); + } + # only send notifications if the clique was successfully created, otherwise + # pretend it never existed. + if (parent != nil) { + parent.notes = g.notes; + g.notes = nil; + } + return (g.id, fname, nil); +} + +# as a special case, if parent is nil, we use the root object. +Clique.newobject(clique: self ref Clique, parent: ref Object, visibility: Set, objtype: string): ref Object +{ + if (clique.freelist == nil) + (clique.objects, clique.freelist) = + makespace(clique.objects, clique.freelist); + id := hd clique.freelist; + clique.freelist = tl clique.freelist; + + if (parent == nil) + parent = clique.objects[0]; + obj := ref Object(id, Attributes.new(), visibility, parent.id, nil, clique.id, objtype); + + n := len parent.children; + newchildren := array[n + 1] of ref Object; + newchildren[0:] = parent.children; + newchildren[n] = obj; + parent.children = newchildren; + clique.objects[id] = obj; + applycliqueupdate(clique, ref Update.Create(id, parent.id, visibility, objtype), All); + if (Debug) + sys->print("new %d, parent %d, visibility %s\n", obj.id, parent.id, visibility.str()); + return obj; +} + +Clique.hangup(clique: self ref Clique) +{ + if (clique.hungup) + return; +sys->print("clique.hangup(%s)\n", clique.fname); + f := qfiles[clique.fileid]; + for (ofids := f.ofids; ofids != nil; ofids = tl ofids) + (hd ofids).hungup = 1; + f.needsupdate = 1; + clique.hungup = 1; + if (clique.parentid != -1) { + clique.notes = (clique.id, clique.parentid, nil) :: clique.notes; + clique.parentid = -1; + } + # orphan children + # XXX could be more efficient for childless cliques by keeping child count + for(i := 0; i < len cliques; i++) + if (cliques[i] != nil && cliques[i].parentid == clique.id) + cliques[i].parentid = -1; +} + +stopclique(clique: ref Clique) +{ + clique.hangup(); + if (clique.request != nil) + clique.request <-= nil; +} + +Clique.breakmsg(clique: self ref Clique, whoto: Set) +{ + applycliqueupdate(clique, ref Update.Break, whoto); +} + +Clique.action(clique: self ref Clique, cmd: string, + objs: list of int, rest: string, whoto: Set) +{ + applycliqueupdate(clique, ref Update.Action(cmd, objs, rest), whoto); +} + +Clique.member(clique: self ref Clique, id: int): ref Member +{ + for (ol := qfiles[clique.fileid].ofids; ol != nil; ol = tl ol) + if ((hd ol).member != nil && (hd ol).member.id == id) + return (hd ol).member; + for (s := clique.suspended; s != nil; s = tl s) + if ((hd s).id == id) + return hd s; + return nil; +} + +Clique.membernamed(clique: self ref Clique, name: string): ref Member +{ + for (ol := qfiles[clique.fileid].ofids; ol != nil; ol = tl ol) + if ((hd ol).uname == name) + return (hd ol).member; + for (s := clique.suspended; s != nil; s = tl s) + if ((hd s).name == name) + return hd s; + return nil; +} + +Clique.owner(clique: self ref Clique): string +{ + return qfiles[clique.fileid].owner; +} + +Clique.fcreate(clique: self ref Clique, f: int, parent: int, d: Sys->Dir): string +{ + pq: big; + if (parent == -1) + pq = mkqid(fGAMEDIR, clique.id); + else + pq = mkqid(fGAMEDATA, clique.id | (parent<<16)); + d.qid.path = mkqid(fGAMEDATA, clique.id | (f<<16)); + d.mode &= ~8r222; + return nametree->tree.create(pq, d); +} + +Clique.fremove(clique: self ref Clique, f: int): string +{ + return nametree->tree.remove(mkqid(fGAMEDATA, clique.id | (f<<16))); +} + +# debugging... +Clique.show(nil: self ref Clique, nil: ref Member) +{ +# sys->print("**************** all objects:\n"); +# showobject(clique, clique.objects[0], p, 0, ~0); +# if (p == nil) { +# f := qfiles[clique.fileid]; +# for (ol := f.ofids; ol != nil; ol = tl ol) { +# p = (hd ol).member; +# if (p == nil) { +# sys->print("lurker (name '%s')\n", +# (hd ol).uname); +# continue; +# } +# sys->print("member %d, '%s': ext->obj ", p.id, p.name); +# for (j := 0; j < len p.ext2obj; j++) +# if (p.ext2obj[j] != nil) +# sys->print("%d->%d[%d] ", j, p.ext2obj[j].id, p.ext(p.ext2obj[j].id)); +# sys->print("\n"); +# } +# } +} + +cliquerequest(clique: ref Clique, rq: ref Rq): string +{ + e := cliquerequest1(clique, rq); + sendnotifications(clique); + return e; +} + +cliquerequest1(clique: ref Clique, rq: ref Rq): string +{ + if (clique.request == nil) + return "clique has exited"; + clique.request <-= rq; + err := <-clique.reply; + if (clique.hungup && clique.request != nil) { + clique.request <-= nil; + clique.request = nil; + } + return err; +} + +sendnotifications(clique: ref Clique) +{ + notes, pending: list of (int, int, string); + (pending, clique.notes) = (clique.notes, nil); + n := 0; + while (pending != nil) { + for (notes = nil; pending != nil; pending = tl pending) + notes = hd pending :: notes; + for (; notes != nil; notes = tl notes) { + (srcid, dstid, cmd) := hd notes; + dst := cliques[dstid]; + if (!dst.hungup) { + dst.notes = pending; + cliquerequest1(dst, ref Rq.Notify(srcid, cmd)); + (pending, dst.notes) = (dst.notes, nil); + } + } + if (n++ > 50) + panic("probable loop in clique notification"); # XXX probably shouldn't panic, but useful for debugging + } +} + +cliqueproc(clique: ref Clique) +{ + wfd := sys->open("/prog/" + string sys->pctl(0, nil) + "/wait", Sys->OREAD); + spawn cliqueproc1(clique); + buf := array[Sys->ATOMICIO] of byte; + n := sys->read(wfd, buf, len buf); + sys->print("spree: clique '%s' exited: %s\n", clique.fname, string buf[0:n]); + clique.hangup(); + clique.request = nil; + clique.reply <-= "clique exited"; +} + +cliqueproc1(clique: ref Clique) +{ + for (;;) { + rq := <-clique.request; + if (rq == nil) + break; + reply := ""; + pick r := rq { + Init => + reply = clique.mod->init(myself, clique, clique.archive.argv); + Join => + reply = clique.mod->join(r.member, r.cmd, r.suspended); + Command => + reply = clique.mod->command(r.member, r.cmd); + Leave => + if (clique.mod->leave(r.member) == 0) + reply = "suspended"; + Notify => + clique.mod->notify(r.srcid, r.cmd); + * => + panic("unknown engine request, tag " + string tagof(rq)); + } + clique.reply <-= reply; + } + sys->print("spree: clique '%s' exiting\n", clique.fname); +} + +Member.ext(member: self ref Member, id: int): int +{ + obj2ext := member.obj2ext; + if (id >= len obj2ext || id < 0) + return -1; + return obj2ext[id]; +} + +Member.obj(member: self ref Member, ext: int): ref Object +{ + if (ext < 0 || ext >= len member.ext2obj) + return nil; + return member.ext2obj[ext]; +} + +# allocate an object in a member's map. +memberaddobject(p: ref Member, o: ref Object) +{ + if (p.freelist == nil) + (p.ext2obj, p.freelist) = makespace(p.ext2obj, p.freelist); + ext := hd p.freelist; + p.freelist = tl p.freelist; + + if (o.id >= len p.obj2ext) { + oldmap := p.obj2ext; + newmap := array[o.id + 10] of int; + newmap[0:] = oldmap; + for (i := len oldmap; i < len newmap; i++) + newmap[i] = -1; + p.obj2ext = newmap; + } + p.obj2ext[o.id] = ext; + p.ext2obj[ext] = o; + if (Debug) + sys->print("addobject member %d, internal %d, external %d\n", p.id, o.id, ext); +} + +# delete an object from a member's map. +memberdelobject(member: ref Member, id: int) +{ + if (id >= len member.obj2ext) { + sys->fprint(stderr, "spree: bad delobject (member %d, id %d, len obj2ext %d)\n", + member.id, id, len member.obj2ext); + return; + } + ext := member.obj2ext[id]; + member.ext2obj[ext] = nil; + member.obj2ext[id] = -1; + member.freelist = ext :: member.freelist; + if (Debug) + sys->print("delobject member %d, internal %d, external %d\n", member.id, id, ext); +} + +memberleaves(member: ref Member) +{ + clique := cliques[member.cliqueid]; + sys->print("member %d leaving clique %d\n", member.id, member.cliqueid); + + suspend := 0; + if (!clique.hungup) + suspend = cliquerequest(clique, ref Rq.Leave(member)) != nil; + member.del(suspend); +} + +resetvisibilities(o: ref Object, id: int) +{ + o.visibility = setreset(o.visibility, id); + a := o.attrs.a; + for (i := 0; i < len a; i++) { + for (al := a[i]; al != nil; al = tl al) { + (hd al).visibility = setreset((hd al).visibility, id); + (hd al).needupdate = setreset((hd al).needupdate, id); + } + } + for (i = 0; i < len o.children; i++) + resetvisibilities(o.children[i], id); +} + +# remove a member from their clique. +# the client is still there, but won't get any clique updates. +Member.del(member: self ref Member, suspend: int) +{ + clique := cliques[member.cliqueid]; + if (!member.suspended) { + for (ofids := qfiles[clique.fileid].ofids; ofids != nil; ofids = tl ofids) + if ((hd ofids).member == member) { + (hd ofids).member = nil; + (hd ofids).hungup = 1; + # XXX purge update queue? + } + # go through all clique objects and attributes, resetting + # permissions for member id to their default values. + if (suspend) { + member.obj2ext = nil; + member.ext2obj = nil; + member.freelist = nil; + member.updating = 0; + member.suspended = 1; + clique.suspended = member :: clique.suspended; + } + } else if (!suspend) { + ns: list of ref Member; + for (s := clique.suspended; s != nil; s = tl s) + if (hd s != member) + ns = hd s :: ns; + clique.suspended = ns; + } + if (!suspend) { + resetvisibilities(clique.objects[0], member.id); + clique.memberids = clique.memberids.del(member.id); + } +} + +Clique.members(clique: self ref Clique): list of ref Member +{ + pl := clique.suspended; + for (ofids := qfiles[clique.fileid].ofids; ofids != nil; ofids = tl ofids) + if ((hd ofids).member != nil) + pl = (hd ofids).member :: pl; + return pl; +} + +Object.delete(o: self ref Object) +{ + clique := cliques[o.cliqueid]; + if (o.parentid != -1) { + parent := clique.objects[o.parentid]; + siblings := parent.children; + for (i := 0; i < len siblings; i++) + if (siblings[i] == o) + break; + if (i == len siblings) + panic("object " + string o.id + " not found in parent"); + parent.deletechildren((i, i+1)); + } else + sys->fprint(stderr, "spree: cannot delete root object\n"); +} + +Object.deletechildren(parent: self ref Object, r: Range) +{ + if (len parent.children == 0) + return; + clique := cliques[parent.cliqueid]; + n := r.end - r.start; + objs := array[r.end - r.start] of int; + children := parent.children; + for (i := r.start; i < r.end; i++) { + o := children[i]; + objs[i - r.start] = o.id; + o.deletechildren((0, len o.children)); + clique.objects[o.id] = nil; + clique.freelist = o.id :: clique.freelist; + o.id = -1; + o.parentid = -1; + } + children[r.start:] = children[r.end:]; + for (i = len children - n; i < len children; i++) + children[i] = nil; + if (n < len children) + parent.children = children[0:len children - n]; + else + parent.children = nil; + + if (Debug) { + sys->print("+del from %d, range [%d %d], objs: ", parent.id, r.start, r.end); + for (i = 0; i < len objs; i++) + sys->print("%d ", objs[i]); + sys->print("\n"); + } + applycliqueupdate(clique, ref Update.Delete(parent.id, r, objs), All); +} + +# move a range of objects from src and insert them at index in dst. +Object.transfer(src: self ref Object, r: Range, dst: ref Object, index: int) +{ + if (index == -1) + index = len dst.children; + if (src == dst && index >= r.start && index <= r.end) + return; + n := r.end - r.start; + objs := src.children[r.start:r.end]; + newchildren := array[len src.children - n] of ref Object; + newchildren[0:] = src.children[0:r.start]; + newchildren[r.start:] = src.children[r.end:]; + src.children = newchildren; + + if (Debug) { + sys->print("+transfer from %d[%d,%d] to %d[%d], objs: ", + src.id, r.start, r.end, dst.id, index); + for (x := 0; x < len objs; x++) + sys->print("%d ", objs[x].id); + sys->print("\n"); + } + + nindex := index; + + # if we've just removed some cards from the destination, + # then adjust the destination index accordingly. + if (src == dst && nindex > r.start) { + if (nindex < r.end) + nindex = r.start; + else + nindex -= n; + } + newchildren = array[len dst.children + n] of ref Object; + newchildren[0:] = dst.children[0:index]; + newchildren[nindex + n:] = dst.children[nindex:]; + newchildren[nindex:] = objs; + dst.children = newchildren; + + for (i := 0; i < len objs; i++) + objs[i].parentid = dst.id; + + clique := cliques[src.cliqueid]; + applycliqueupdate(clique, + ref Update.Transfer(src.id, r, dst.id, index), + All); +} + +# visibility is only set when the attribute is newly created. +Object.setattr(o: self ref Object, name, val: string, visibility: Set) +{ + (changed, attr) := o.attrs.set(name, val, visibility); + if (changed) { + attr.needupdate = All; + applycliqueupdate(cliques[o.cliqueid], ref Update.Set(o, o.id, attr), objvisibility(o)); + } +} + +Object.getattr(o: self ref Object, name: string): string +{ + attr := o.attrs.get(name); + if (attr == nil) + return nil; + return attr.val; +} + +# set visibility of an object - reveal any uncovered descendents +# if necessary. +Object.setvisibility(o: self ref Object, visibility: Set) +{ + if (o.visibility.eq(visibility)) + return; + o.visibility = visibility; + applycliqueupdate(cliques[o.cliqueid], ref Update.Setvisibility(o.id, visibility), objvisibility(o)); +} + +Object.setattrvisibility(o: self ref Object, name: string, visibility: Set) +{ + attr := o.attrs.get(name); + if (attr == nil) { + sys->fprint(stderr, "spree: setattrvisibility, no attribute '%s', id %d\n", name, o.id); + return; + } + if (attr.visibility.eq(visibility)) + return; + # send updates to anyone that has needs updating, + # is in the new visibility list, but not in the old one. + ovisibility := objvisibility(o); + before := ovisibility.X(A&B, attr.visibility); + after := ovisibility.X(A&B, visibility); + attr.visibility = visibility; + applycliqueupdate(cliques[o.cliqueid], ref Update.Set(o, o.id, attr), before.X(~A&B, after)); +} + +# an object's visibility is the intersection +# of the visibility of all its parents. +objvisibility(o: ref Object): Set +{ + clique := cliques[o.cliqueid]; + visibility := All; + for (id := o.parentid; id != -1; id = o.parentid) { + o = clique.objects[id]; + visibility = visibility.X(A&B, o.visibility); + } + return visibility; +} + +makespace(objects: array of ref Object, + freelist: list of int): (array of ref Object, list of int) +{ + if (freelist == nil) { + na := array[len objects + 10] of ref Object; + na[0:] = objects; + for (j := len na - 1; j >= len objects; j--) + freelist = j :: freelist; + objects = na; + } + return (objects, freelist); +} + +updateall() +{ + for (i := 0; i < len qfiles; i++) { + f := qfiles[i]; + if (f != nil && f.needsupdate) { + for (ol := f.ofids; ol != nil; ol = tl ol) + sendupdate(hd ol); + f.needsupdate = 0; + } + } +} + +applyupdate(f: ref Qfile, upd: ref Update) +{ + for (ol := f.ofids; ol != nil; ol = tl ol) + (hd ol).updateq.put(upd); + f.needsupdate = 1; +} + +# send update to members in the clique in the needupdate set. +applycliqueupdate(clique: ref Clique, upd: ref Update, needupdate: Set) +{ + always := alwayssend[tagof(upd)]; + if (needupdate.isempty() || (!clique.started && !always)) + return; + f := qfiles[clique.fileid]; + for (ol := f.ofids; ol != nil; ol = tl ol) { + ofid := hd ol; + member := ofid.member; + if (member != nil && needupdate.holds(member.id) && (member.updating || always)) + queueupdate(ofid.updateq, member, upd); + } + f.needsupdate = 1; +} + +# transform an outgoing update according to the visibility +# of the object(s) concerned. +# the update concerned has already occurred. +queueupdate(q: ref Queue, p: ref Member, upd: ref Update) +{ + clique := cliques[p.cliqueid]; + pick u := upd { + Set => + if (p.ext(u.o.id) != -1 && u.attr.needupdate.holds(p.id)) { + q.put(ref Update.Set(u.o, p.ext(u.o.id), u.attr)); + u.attr.needupdate = u.attr.needupdate.del(p.id); + } else + u.attr.needupdate = u.attr.needupdate.add(p.id); + + Transfer => + # if moving from an invisible object, create the objects + # temporarily in the source object, and then transfer from that. + # if moving to an invisible object, delete the objects. + # if moving from invisible to invisible, do nothing. + src := clique.objects[u.srcid]; + dst := clique.objects[u.dstid]; + fromvisible := objvisibility(src).X(A&B, src.visibility).holds(p.id); + tovisible := objvisibility(dst).X(A&B, dst.visibility).holds(p.id); + if (fromvisible || tovisible) { + # N.B. objects are already in destination object at this point. + (r, index, srcid) := (u.from, u.index, u.srcid); + + # XXX this scheme is all very well when the parent of src + # or dst is visible, but not when it's not... in that case + # we should revert to the old scheme of deleting objects in src + # or recreating them in dst as appropriate. + if (!tovisible) { + # transfer objects to destination, then delete them, + # so client knows where they've gone. + q.put(ref Update.Transfer(p.ext(srcid), r, p.ext(u.dstid), 0)); + qdelobjects(q, p, dst, (u.index, u.index + r.end - r.start), 0); + break; + } + if (!fromvisible) { + # create at the end of source object, + # then transfer into correct place in destination. + n := r.end - r.start; + for (i := 0; i < n; i++) { + o := dst.children[index + i]; + qrecreateobject(q, p, o, src); + } + r = (0, n); + } + if (p.ext(srcid) == -1 || p.ext(u.dstid) == -1) + panic("external objects do not exist"); + q.put(ref Update.Transfer(p.ext(srcid), r, p.ext(u.dstid), index)); + } + Create => + dst := clique.objects[u.parentid]; + if (objvisibility(dst).X(A&B, dst.visibility).holds(p.id)) { + memberaddobject(p, clique.objects[u.objid]); + q.put(ref Update.Create(p.ext(u.objid), p.ext(u.parentid), u.visibility, u.objtype)); + } + Delete => + # we can only get this update when all the children are + # leaf nodes. + o := clique.objects[u.parentid]; + if (objvisibility(o).X(A&B, o.visibility).holds(p.id)) { + r := u.r; + extobjs := array[len u.objs] of int; + for (i := 0; i < len u.objs; i++) { + extobjs[i] = p.ext(u.objs[i]); + memberdelobject(p, u.objs[i]); + } + q.put(ref Update.Delete(p.ext(o.id), u.r, extobjs)); + } + Setvisibility => + # if the object doesn't exist for this member, don't do anything. + # else if there are children, check whether they exist, and + # create or delete them as necessary. + if (p.ext(u.objid) != -1) { + o := clique.objects[u.objid]; + if (len o.children > 0) { + visible := u.visibility.holds(p.id); + made := p.ext(o.children[0].id) != -1; + if (!visible && made) + qdelobjects(q, p, o, (0, len o.children), 0); + else if (visible && !made) + for (i := 0; i < len o.children; i++) + qrecreateobject(q, p, o.children[i], nil); + } + q.put(ref Update.Setvisibility(p.ext(u.objid), u.visibility)); + } + Action => + s := u.s; + for (ol := u.objs; ol != nil; ol = tl ol) + s += " " + string p.ext(hd ol); + s += " " + u.rest; + q.put(ref Update.Action(s, nil, nil)); + * => + q.put(upd); + } +} + +# queue deletions for o; we pretend to the client that +# the deletions are at index. +qdelobjects(q: ref Queue, p: ref Member, o: ref Object, r: Range, index: int) +{ + if (r.start >= r.end) + return; + children := o.children; + extobjs := array[r.end - r.start] of int; + for (i := r.start; i < r.end; i++) { + c := children[i]; + qdelobjects(q, p, c, (0, len c.children), 0); + extobjs[i - r.start] = p.ext(c.id); + memberdelobject(p, c.id); + } + q.put(ref Update.Delete(p.ext(o.id), (index, index + (r.end - r.start)), extobjs)); +} + +# parent visibility now allows o to be seen, so recreate +# it for the member. (if parent is non-nil, pretend we're creating it there) +qrecreateobject(q: ref Queue, p: ref Member, o: ref Object, parent: ref Object) +{ + memberaddobject(p, o); + parentid := o.parentid; + if (parent != nil) + parentid = parent.id; + q.put(ref Update.Create(p.ext(o.id), p.ext(parentid), o.visibility, o.objtype)); + recreateattrs(q, p, o); + if (o.visibility.holds(p.id)) { + a := o.children; + for (i := 0; i < len a; i++) + qrecreateobject(q, p, a[i], nil); + } +} + +recreateattrs(q: ref Queue, p: ref Member, o: ref Object) +{ + a := o.attrs.a; + for (i := 0; i < len a; i++) { + for (al := a[i]; al != nil; al = tl al) { + attr := hd al; + q.put(ref Update.Set(o, p.ext(o.id), attr)); + } + } +} + +CONTINUATION := array[] of {byte '\n', byte '*'}; + +# send the client as many updates as we can fit in their read request +# (if there are some updates to send and there's an outstanding read request) +sendupdate(ofid: ref Openfid) +{ + clique: ref Clique; + if (ofid.readreq == nil || (ofid.updateq.isempty() && !ofid.hungup)) + return; + m := ofid.readreq; + q := ofid.updateq; + if (ofid.hungup) { + srv.reply(ref Rmsg.Read(m.tag, nil)); + q.h = q.t = nil; + return; + } + data := array[m.count] of byte; + nb := 0; + plid := -1; + if (ofid.member != nil) { + plid = ofid.member.id; + clique = cliques[ofid.member.cliqueid]; + } + avail := len data - len CONTINUATION; +Putdata: + for (; !q.isempty(); q.get()) { + upd := q.peek(); + pick u := upd { + Set => + if (plid != -1 && !objvisibility(u.o).X(A&B, u.attr.visibility).holds(plid)) { + u.attr.needupdate = u.attr.needupdate.add(plid); + continue Putdata; + } + Break => + if (nb > 0) { + q.get(); + break Putdata; + } + continue Putdata; + } + d := array of byte update2s(upd, plid); + if (len d + nb > avail) + break; + data[nb:] = d; + nb += len d; + } + err := ""; + if (nb == 0) { + if (q.isempty()) + return; + err = "short read"; + } else if (!q.isempty()) { + data[nb:] = CONTINUATION; + nb += len CONTINUATION; + } + data = data[0:nb]; + + if (err != nil) + srv.reply(ref Rmsg.Error(m.tag, err)); + else + srv.reply(ref Rmsg.Read(m.tag, data)); + ofid.readreq = nil; +} + +# convert an Update adt to a string. +update2s(upd: ref Update, plid: int): string +{ + s: string; + pick u := upd { + Create => + objtype := u.objtype; + if (objtype == nil) + objtype = "nil"; + s = sys->sprint("create %d %d %d %s\n", u.objid, u.parentid, u.visibility.holds(plid) != 0, objtype); + Transfer => + # tx src dst dstindex start end + if (u.srcid == -1 || u.dstid == -1) + panic("src or dst object is -1"); + s = sys->sprint("tx %d %d %d %d %d\n", + u.srcid, u.dstid, u.from.start, u.from.end, u.index); + Delete => + s = sys->sprint("del %d %d %d", u.parentid, u.r.start, u.r.end); + for (i := 0; i < len u.objs; i++) + s += " " + string u.objs[i]; + s[len s] = '\n'; + Set => + s = sys->sprint("set %d %s %s\n", u.objid, u.attr.name, u.attr.val); + Setvisibility => + s = sys->sprint("vis %d %d\n", u.objid, u.visibility.holds(plid) != 0); + Action => + s = u.s + "\n"; + * => + sys->fprint(stderr, "unknown update tag %d\n", tagof(upd)); + } + return s; +} + +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; +} + +Attributes.new(): ref Attributes +{ + return ref Attributes(array[7] of list of ref Attribute); +} + +Attributes.get(attrs: self ref Attributes, name: string): ref Attribute +{ + for (al := attrs.a[strhash(name, len attrs.a)]; al != nil; al = tl al) + if ((hd al).name == name) + return hd al; + return nil; +} + +# return (haschanged, attr) +Attributes.set(attrs: self ref Attributes, name, val: string, visibility: Set): (int, ref Attribute) +{ + h := strhash(name, len attrs.a); + for (al := attrs.a[h]; al != nil; al = tl al) { + attr := hd al; + if (attr.name == name) { + if (attr.val == val) + return (0, attr); + attr.val = val; + return (1, attr); + } + } + attr := ref Attribute(name, val, visibility, All); + attrs.a[h] = attr :: attrs.a[h]; + return (1, attr); +} + +setreset(set: Set, i: int): Set +{ + if (set.msb()) + return set.add(i); + return set.del(i); +} + +# 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; +} + +panic(s: string) +{ + cliques[0].show(nil); + sys->fprint(stderr, "panic: %s\n", s); + raise "panic"; +} + +randbits: chan of int; + +initrand() +{ + randbits = chan of int; + spawn randproc(); +} + +randproc() +{ + fd := sys->open("/dev/notquiterandom", Sys->OREAD); + if (fd == nil) { + sys->print("cannot open /dev/random: %r\n"); + exit; + } + randbits <-= sys->pctl(0, nil); + buf := array[1] of byte; + while ((n := sys->read(fd, buf, len buf)) > 0) { + b := buf[0]; + for (i := byte 1; i != byte 0; i <<= 1) + randbits <-= (b & i) != byte 0; + } +} + +rand(n: int): int +{ + x: int; + for (nbits := 0; (1 << nbits) < n; nbits++) + x ^= <-randbits << nbits; + x ^= <-randbits << nbits; + x &= (1 << nbits) - 1; + i := 0; + while (x >= n) { + x ^= <-randbits << i; + i = (i + 1) % nbits; + } + return x; +} + +archivenum := -1; + +newarchivename(): string +{ + if (archivenum == -1) { + (d, nil) := readdir->init(ARCHIVEDIR, Readdir->MTIME|Readdir->COMPACT); + for (i := 0; i < len d; i++) { + name := d[i].name; + if (name != nil && name[0] == 'a') { + for (j := 1; j < len name; j++) + if (name[j] < '0' || name[j] > '9') + break; + if (j == len name && int name[1:] > archivenum) + archivenum = int name[1:]; + } + } + archivenum++; + } + return ARCHIVEDIR + "/a" + string archivenum++; +} + +archivenames(): list of string +{ + names: list of string; + (d, nil) := readdir->init(ARCHIVEDIR, Readdir->MTIME|Readdir->COMPACT); + for (i := 0; i < len d; i++) + if (len d[i].name < 4 || d[i].name[len d[i].name - 4:] != ".old") + names = ARCHIVEDIR + "/" + d[i].name :: names; + return names; +} diff --git a/appl/spree/spree.m b/appl/spree/spree.m new file mode 100644 index 00000000..c4178a6d --- /dev/null +++ b/appl/spree/spree.m @@ -0,0 +1,140 @@ +Spree: module +{ + MAXPLAYERS: con 100; + Attribute: adt { + name: string; + val: string; + visibility: Sets->Set; # set of members that can see attr + needupdate: Sets->Set; # set of members that have not got an update queued + }; + + Attributes: adt { + a: array of list of ref Attribute; + set: fn(attr: self ref Attributes, name, val: string, vis: Sets->Set): (int, ref Attribute); + get: fn(attr: self ref Attributes, name: string): ref Attribute; + new: fn(): ref Attributes; + }; + + Range: adt { + start: int; + end: int; + }; + + Object: adt { + id: int; + attrs: ref Attributes; + visibility: Sets->Set; + parentid: int; + children: cyclic array of ref Object; # not actually cyclic + cliqueid: int; + objtype: string; + + transfer: fn(o: self ref Object, r: Range, dst: ref Object, i: int); + setvisibility: fn(o: self ref Object, visibility: Sets->Set); + setattrvisibility: fn(o: self ref Object, name: string, visibility: Sets->Set); + setattr: fn(o: self ref Object, name: string, val: string, vis: Sets->Set); + getattr: fn(o: self ref Object, name: string): string; + delete: fn(o: self ref Object); + deletechildren: fn(o: self ref Object, r: Range); + }; + + Rq: adt { + pick { + Init => + opts: string; + Command => + member: ref Member; + cmd: string; + Join => + member: ref Member; + cmd: string; + suspended: int; + Leave => + member: ref Member; + Notify => + srcid: int; + cmd: string; + } + }; + + # this might also be known as a "group", as there's nothing + # inherently clique-like about it; it's just a group of members + # mutually creating and manipulating objects. + Clique: adt { + id: int; + fileid: int; + fname: string; + objects: array of ref Object; + archive: ref Archives->Archive; + freelist: list of int; + mod: Engine; + memberids: Sets->Set; # set of allocated member ids + suspended: list of ref Member; + request: chan of ref Rq; + reply: chan of string; + hungup: int; + started: int; + parentid: int; + notes: list of (int, int, string); # (src, dest, note) + + new: fn(parent: self ref Clique, archive: ref Archives->Archive, owner: string): (int, string, string); # returns (cliqueid, filename, error) + newobject: fn(clique: self ref Clique, parent: ref Object, visibility: Sets->Set, objtype: string): ref Object; + start: fn(clique: self ref Clique); + action: fn(clique: self ref Clique, cmd: string, + objs: list of int, rest: string, whoto: Sets->Set); + breakmsg: fn(clique: self ref Clique, whoto: Sets->Set); + show: fn(clique: self ref Clique, member: ref Member); + member: fn(clique: self ref Clique, id: int): ref Member; + membernamed: fn(clique: self ref Clique, name: string): ref Member; + members: fn(clique: self ref Clique): list of ref Member; + owner: fn(clique: self ref Clique): string; + hangup: fn(clique: self ref Clique); + fcreate: fn(clique: self ref Clique, i: int, pq: int, d: Sys->Dir): string; + fremove: fn(clique: self ref Clique, i: int): string; + notify: fn(clique: self ref Clique, cliqueid: int, msg: string); + }; + + # a Member is involved in one clique only + Member: adt { + id: int; + cliqueid: int; + obj2ext: array of int; + ext2obj: array of ref Object; + freelist: list of int; + name: string; + updating: int; + suspended: int; + + ext: fn(member: self ref Member, id: int): int; + obj: fn(member: self ref Member, id: int): ref Object; + del: fn(member: self ref Member, suspend: int); + }; + + init: fn(ctxt: ref Draw->Context, argv: list of string); + archivenames: fn(): list of string; + newarchivename: fn(): string; + rand: fn(n: int): int; +}; + +Engine: module { + init: fn(srvmod: Spree, clique: ref Spree->Clique, argv: list of string): string; + command: fn(member: ref Spree->Member, e: string): string; + join: fn(member: ref Spree->Member , e: string, suspended: int): string; + leave: fn(member: ref Spree->Member): int; + notify: fn(fromid: int, s: string); + readfile: fn(f: int, offset: big, count: int): array of byte; +}; + +Archives: module { + PATH: con "/dis/spree/archives.dis"; + Archive: adt { + argv: list of string; # how to restart the session. + members: array of string; # members involved. + info: list of (string, string); # any other information. + objects: array of ref Spree->Object; + }; + init: fn(mod: Spree); + write: fn(clique: ref Spree->Clique, info: list of (string, string), file: string, members: Sets->Set): string; + read: fn(file: string): (ref Archive, string); + readheader: fn(file: string): (ref Archive, string); +}; |