diff options
Diffstat (limited to 'appl/spree/clients')
| -rw-r--r-- | appl/spree/clients/bounce.b | 958 | ||||
| -rw-r--r-- | appl/spree/clients/cards.b | 2220 | ||||
| -rw-r--r-- | appl/spree/clients/chat.b | 194 | ||||
| -rw-r--r-- | appl/spree/clients/gather.b | 178 | ||||
| -rw-r--r-- | appl/spree/clients/lobby.b | 562 | ||||
| -rw-r--r-- | appl/spree/clients/othello.b | 270 |
6 files changed, 4382 insertions, 0 deletions
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]; +} + |