ref: 44ce0097b612a1fefd754065bdf8d9d2e5ef60c8
dir: /appl/demo/whiteboard/whiteboard.b/
implement Whiteboard;
include "sys.m";
sys: Sys;
include "draw.m";
draw: Draw;
Screen, Display, Image, Rect, Point, Font: import draw;
include "tk.m";
tk: Tk;
include "tkclient.m";
tkclient: Tkclient;
Whiteboard: module {
init: fn(ctxt: ref Draw->Context, args: list of string);
};
ERASEWIDTH: con 6;
stderr: ref Sys->FD;
srvfd: ref Sys->FD;
disp: ref Display;
font: ref Draw->Font;
drawctxt: ref Draw->Context;
tksetup := array[] of {
"frame .f -bd 2",
"frame .c -bg white -width 600 -height 400",
"menu .penmenu",
".penmenu add command -command {send cmd pen 0} -image pen0",
".penmenu add command -command {send cmd pen 1} -image pen1",
".penmenu add command -command {send cmd pen 2} -image pen2",
".penmenu add command -command {send cmd pen erase} -image erase",
"menubutton .pen -menu .penmenu -image pen1",
"button .colour -bg black -activebackground black -command {send cmd getcolour}",
"pack .c -in .f",
"pack .f -side top -anchor center",
"pack .pen -side left",
"pack .colour -side left -fill both -expand 1",
"update",
};
tkconnected := array[] of {
"bind .c <Button-1> {send cmd down %x %y}",
"bind .c <ButtonRelease-1> {send cmd up %x %y}",
"update",
};
init(ctxt: ref Draw->Context, args: list of string)
{
sys = load Sys Sys->PATH;
sys->pctl(Sys->NEWPGRP, nil);
stderr = sys->fildes(2);
draw = load Draw Draw->PATH;
tk = load Tk Tk->PATH;
tkclient = load Tkclient Tkclient->PATH;
if (tkclient == nil)
badmod(Tkclient->PATH);
args = tl args;
servicedir := ".";
if(args != nil)
(servicedir, args) = (hd args, tl args);
disp = ctxt.display;
if (disp == nil) {
sys->fprint(stderr, "bad Draw->Context\n");
raise "fail:init";
}
drawctxt = ctxt;
tkclient->init();
(win, winctl) := tkclient->toplevel(ctxt, nil, "Whiteboard", 0);
font = Font.open(disp, tkcmd(win, ". cget -font"));
if(font == nil)
font = Font.open(disp, "*default*");
cmd := chan of string;
tk->namechan(win, cmd, "cmd");
mkpenimgs(win);
tkcmds(win, tksetup);
tkclient->onscreen(win, nil);
tkclient->startinput(win, "kbd" :: "ptr" :: nil);
cimage := makeimage(win);
sc := chan of array of (Point, Point);
cc := chan of (string, ref Image, ref Sys->FD);
connected := 0;
sfd: ref Sys->FD;
showtext(cimage, "connecting...");
spawn connect(servicedir, cc);
err: string;
strokeimg: ref Image;
Connect:
for (;;) alt {
(err, strokeimg, sfd) = <-cc =>
if (err == nil)
break Connect;
else
showtext(cimage, "Error: " + err);
s := <-winctl or
s = <-win.wreq or
s = <-win.ctxt.ctl =>
oldimg := win.image;
err = tkclient->wmctl(win, s);
if(s[0] == '!' && err == nil && win.image != oldimg){
cimage = makeimage(win);
showtext(cimage, "connecting...");
}
p := <-win.ctxt.ptr =>
tk->pointer(win, *p);
c := <-win.ctxt.kbd =>
tk->keyboard(win, c);
}
tkcmd(win, ".c configure -width " + string strokeimg.r.dx());
tkcmd(win, ".c configure -height " + string strokeimg.r.dy());
tkcmds(win, tkconnected);
tkcmd(win, "update");
cimage.draw(cimage.r, strokeimg, nil, strokeimg.r.min);
strokesin := chan of (int, int, array of Point);
strokesout := chan of (int, int, Point, Point);
spawn reader(sfd, strokesin);
spawn writer(sfd, strokesout);
pendown := 0;
p0, p1: Point;
getcolour := 0;
white := disp.white;
whitepen := disp.newimage(Rect(Point(0,0), Point(1,1)), Draw->CMAP8, 1, Draw->White);
pencolour := Draw->Black;
penwidth := 1;
erase := 0;
drawpen := disp.newimage(Rect(Point(0,0), Point(1,1)), Draw->CMAP8, 1, pencolour);
for (;;) alt {
s := <-winctl or
s = <-win.ctxt.ctl or
s = <-win.wreq =>
oldimg := win.image;
err = tkclient->wmctl(win, s);
if(s[0] == '!' && err == nil && win.image != oldimg){
cimage = makeimage(win);
cimage.draw(cimage.r, strokeimg, nil, strokeimg.r.min);
}
p := <-win.ctxt.ptr =>
tk->pointer(win, *p);
c := <-win.ctxt.kbd =>
tk->keyboard(win, c);
(colour, width, strokes) := <-strokesin =>
if (strokes == nil)
tkclient->settitle(win, "Whiteboard (Disconnected)");
else {
pen := disp.newimage(Rect(Point(0,0), Point(1,1)), Draw->CMAP8, 1, colour);
drawstrokes(cimage, cimage.r.min, pen, width, strokes);
drawstrokes(strokeimg, strokeimg.r.min, pen, width, strokes);
}
c := <-cmd =>
(nil, toks) := sys->tokenize(c, " ");
action := hd toks;
case action {
"up" or
"down" =>
toks = tl toks;
x := int hd toks;
y := int hd tl toks;
if (action == "down") {
if (!pendown) {
pendown = 1;
p0 = Point(x, y);
continue;
}
} else
pendown = 0;
p1 = Point(x, y);
if (pendown && p1.x == p0.x && p1.y == p0.y)
continue;
pen := drawpen;
colour := pencolour;
width := penwidth;
if (erase) {
pen = whitepen;
colour = Draw->White;
width = ERASEWIDTH;
}
drawstroke(cimage, cimage.r.min, p0, p1, pen, width);
drawstroke(strokeimg, strokeimg.r.min, p0, p1, pen, width);
strokesout <-= (colour, width, p0, p1);
p0 = p1;
"getcolour" =>
pendown = 0;
if (!getcolour)
spawn colourmenu(cmd);
"colour" =>
pendown = 0;
getcolour = 0;
toks = tl toks;
if (toks == nil)
# colourmenu was dismissed
continue;
erase = 0;
tkcmd(win, ".pen configure -image pen" + string penwidth);
tkcmd(win, "update");
pencolour = int hd toks;
toks = tl toks;
tkcolour := hd toks;
drawpen = disp.newimage(Rect(Point(0,0), Point(1,1)), Draw->CMAP8, 1, pencolour);
tkcmd(win, ".colour configure -bg " + tkcolour + " -activebackground " + tkcolour);
tkcmd(win, "update");
"pen" =>
pendown = 0;
p := hd tl toks;
i := "";
if (p == "erase") {
erase = 1;
i = "erase";
} else {
erase = 0;
penwidth = int p;
i = "pen"+p;
}
tkcmd(win, ".pen configure -image " + i);
tkcmd(win, "update");
}
}
}
makeimage(win: ref Tk->Toplevel): ref Draw->Image
{
if(win.image == nil)
return nil;
scr := Screen.allocate(win.image, win.image.display.white, 0);
w := scr.newwindow(tk->rect(win, ".c", Tk->Local), Draw->Refnone, Draw->Nofill);
return w;
}
showtext(img: ref Image, s: string)
{
r := img.r;
r.max.y = img.r.min.y + font.height;
img.draw(r, disp.white, nil, (0, 0));
img.text(r.min, disp.black, (0, 0), font, s);
}
penmenu(t: ref Tk->Toplevel, p: Point)
{
topy := int tkcmd(t, ".penmenu yposition 0");
boty := int tkcmd(t, ".penmenu yposition end");
dy := boty - topy;
p.y -= dy;
tkcmd(t, ".penmenu post " + string p.x + " " + string p.y);
}
colourcmds := array[] of {
"label .l -height 10",
"frame .c -height 224 -width 224",
"pack .l -fill x -expand 1",
"pack .c -side bottom -fill both -expand 1",
"pack propagate . 0",
"bind .c <Button-1> {send cmd push %x %y}",
"bind .c <ButtonRelease-1> {send cmd release}",
};
lastcolour := "255";
lasttkcolour := "#000000";
colourmenu(c: chan of string)
{
(t, winctl) := tkclient->toplevel(drawctxt, nil, "Whiteboard", Tkclient->OK);
cmd := chan of string;
tk->namechan(t, cmd, "cmd");
tkcmds(t, colourcmds);
tkcmd(t, ".l configure -bg " + lasttkcolour);
tkcmd(t, "update");
tkclient->onscreen(t, "onscreen");
tkclient->startinput(t, "kbd" :: "ptr" :: nil);
drawcolours(t.image, tk->rect(t, ".c", Tk->Local));
for(;;) alt {
p := <-t.ctxt.ptr =>
tk->pointer(t, *p);
s := <-t.ctxt.kbd =>
tk->keyboard(t, s);
s := <-winctl or
s = <-t.ctxt.ctl or
s = <-t.wreq =>
case s{
"ok" =>
c <-= "colour " + lastcolour + " " + lasttkcolour;
return;
"exit" =>
c <-= "colour";
return;
* =>
oldimage := t.image;
e := tkclient->wmctl(t, s);
if(s[0] == '!' && e == nil && oldimage != t.image)
drawcolours(t.image, tk->rect(t, ".c", Tk->Local));
}
press := <-cmd =>
(n, word) := sys->tokenize(press, " ");
case hd word {
"push" =>
(lastcolour, lasttkcolour) = color(int hd tl word, int hd tl tl word, tk->rect(t, ".c", 0).size());
tkcmd(t, ".l configure -bg " + lasttkcolour);
}
}
}
drawcolours(img: ref Image, cr: Rect)
{
# use writepixels because it's much faster than allocating all those colors.
tmp := disp.newimage(((0,0),(cr.dx(),cr.dy()/16+1)), Draw->CMAP8, 0, 0);
if(tmp == nil)
return;
buf := array[tmp.r.dx()*tmp.r.dy()] of byte;
dx := cr.dx();
dy := cr.dy();
for(y:=0; y<16; y++){
for(i:=tmp.r.dx()-1; i>=0; --i)
buf[i] = byte (16*y+(16*i)/dx);
for(k:=tmp.r.dy()-1; k>=1; --k)
buf[dx*k:] = buf[0:dx];
tmp.writepixels(tmp.r, buf);
r: Rect;
r.min.x = cr.min.x;
r.max.x = cr.max.x;
r.min.y = cr.min.y+(dy*y)/16;
r.max.y = cr.min.y+(dy*(y+1))/16;
img.draw(r, tmp, nil, tmp.r.min);
}
}
color(x, y: int, size: Point): (string, string)
{
x = (16*x)/size.x;
y = (16*y)/size.y;
col := 16*y+x;
(r, g, b) := disp.cmap2rgb(col);
tks := sys->sprint("#%.2x%.2x%.2x", r, g, b);
return (string disp.cmap2rgba(col), tks);
}
opensvc(dir: string, svc: string, name: string): (ref Sys->FD, string, string)
{
ctlfd := sys->open(dir+"/ctl", Sys->ORDWR);
if(ctlfd == nil)
return (nil, nil, sys->sprint("can't open %s/ctl: %r", dir));
if(sys->fprint(ctlfd, "%s %s", svc, name) <= 0)
return (nil, nil, sys->sprint("can't access %s service %s: %r", svc, name));
buf := array [32] of byte;
sys->seek(ctlfd, big 0, Sys->SEEKSTART);
n := sys->read(ctlfd, buf, len buf);
if (n <= 0)
return (nil, nil, sys->sprint("%s/ctl: protocol error: %r", dir));
return (ctlfd, dir+"/"+string buf[0:n], nil);
}
connect(dir: string, res: chan of (string, ref Image, ref Sys->FD))
{
bitpath := dir + "/wb.bit";
strokepath := dir + "/strokes";
sfd := sys->open(strokepath, Sys->ORDWR);
if (sfd == nil) {
err := sys->sprint("cannot open whiteboard data: %r");
res <-= (err, nil, nil);
srvfd = nil;
return;
}
bfd := sys->open(bitpath, Sys->OREAD);
if (bfd == nil) {
err := sys->sprint("cannot open whiteboard image: %r");
res <-= (err, nil, nil);
srvfd = nil;
return;
}
img := disp.readimage(bfd);
if (img == nil) {
err := sys->sprint("cannot read whiteboard image: %r");
res <-= (err, nil, nil);
srvfd = nil;
return;
}
# make sure image is depth 8 (because of image.line() bug)
if (img.depth != 8) {
nimg := disp.newimage(img.r, Draw->CMAP8, 0, 0);
if (nimg == nil) {
res <-= ("cannot allocate local image", nil, nil);
srvfd = nil;
return;
}
nimg.draw(nimg.r, img, nil, img.r.min);
img = nimg;
}
res <-= (nil, img, sfd);
}
mkpenimgs(win: ref Tk->Toplevel)
{
ZP := Point(0,0);
pr := Rect((0,0), (13,14));
ir := pr.inset(2);
midx := ir.dx()/2 + ir.min.x;
start := Point(midx, ir.min.y);
end := Point(midx, ir.max.y-1);
i0 := disp.newimage(pr, Draw->GREY1, 0, Draw->White);
i1 := disp.newimage(pr, Draw->GREY1, 0, Draw->Black);
i2 := disp.newimage(pr, Draw->GREY1, 0, Draw->Black);
i3 := disp.newimage(pr, Draw->GREY1, 0, Draw->Black);
i0.draw(ir, disp.black, nil, ZP);
i1.line(start, end, Draw->Endsquare, Draw->Endsquare, 0, disp.white, ZP);
i2.line(start, end, Draw->Endsquare, Draw->Endsquare, 1, disp.white, ZP);
i3.line(start, end, Draw->Endsquare, Draw->Endsquare, 2, disp.white, ZP);
tk->cmd(win, "image create bitmap erase");
tk->cmd(win, "image create bitmap pen0");
tk->cmd(win, "image create bitmap pen1");
tk->cmd(win, "image create bitmap pen2");
tk->putimage(win, "erase", i0, nil);
tk->putimage(win, "pen0", i1, nil);
tk->putimage(win, "pen1", i2, nil);
tk->putimage(win, "pen2", i3, nil);
}
reader(fd: ref Sys->FD, sc: chan of (int, int, array of Point))
{
buf := array [Sys->ATOMICIO] of byte;
for (;;) {
n := sys->read(fd, buf, len buf);
if (n <= 0) {
sc <-= (0, 0, nil);
return;
}
s := string buf[0:n];
(npts, toks) := sys->tokenize(s, " ");
if (npts & 1)
# something wrong
npts--;
if (npts < 6)
# ignore
continue;
colour, width: int;
(colour, toks) = (int hd toks, tl toks);
(width, toks) = (int hd toks, tl toks);
pts := array [(npts - 2)/ 2] of Point;
for (i := 0; toks != nil; i++) {
x, y: int;
(x, toks) = (int hd toks, tl toks);
(y, toks) = (int hd toks, tl toks);
pts[i] = Point(x, y);
}
sc <-= (colour, width, pts);
pts = nil;
}
}
Wmsg: adt {
data: array of byte;
datalen: int;
next: cyclic ref Wmsg;
};
writer(fd: ref Sys->FD, sc: chan of (int, int, Point, Point))
{
lastcol := -1;
lastw := -1;
lastpt := Point(-1, -1);
curmsg: ref Wmsg;
nextmsg: ref Wmsg;
eofc := chan of int;
wc := chan of ref Wmsg;
wseof := 0;
spawn wslave(fd, wc, eofc);
for (;;) {
colour := -1;
width := 0;
p0, p1: Point;
if (curmsg == nil || wseof)
(colour, width, p0, p1) = <-sc;
else alt {
wseof = <-eofc =>
;
(colour, width, p0, p1) = <-sc =>
;
wc <-= curmsg =>
curmsg = curmsg.next;
continue;
}
newseq := 0;
if (curmsg == nil) {
curmsg = ref Wmsg(array [Sys->ATOMICIO] of byte, 0, nil);
nextmsg = curmsg;
newseq = 1;
}
if (colour != lastcol || width != lastw || p0.x != lastpt.x || p0.y != lastpt.y)
newseq = 1;
d: array of byte = nil;
if (!newseq) {
d = sys->aprint(" %d %d", p1.x, p1.y);
if (nextmsg.datalen + len d >= Sys->ATOMICIO) {
nextmsg.next = ref Wmsg(array [Sys->ATOMICIO] of byte, 0, nil);
nextmsg = nextmsg.next;
newseq = 1;
}
}
if (newseq) {
d = sys->aprint(" %d %d %d %d %d %d", colour, width, p0.x, p0.y, p1.x, p1.y);
if (nextmsg.datalen != 0) {
nextmsg.next = ref Wmsg(array [Sys->ATOMICIO] of byte, 0, nil);
nextmsg = nextmsg.next;
}
}
nextmsg.data[nextmsg.datalen:] = d;
nextmsg.datalen += len d;
lastcol = colour;
lastw = width;
lastpt = p1;
}
}
wslave(fd: ref Sys->FD, wc: chan of ref Wmsg, eof: chan of int)
{
for (;;) {
wm := <-wc;
n := sys->write(fd, wm.data, wm.datalen);
if (n != wm.datalen)
break;
}
eof <-= 1;
}
drawstroke(img: ref Image, offset, p0, p1: Point, pen: ref Image, width: int)
{
p0 = p0.add(offset);
p1 = p1.add(offset);
img.line(p0, p1, Draw->Enddisc, Draw->Enddisc, width, pen, p0);
}
drawstrokes(img: ref Image, offset: Point, pen: ref Image, width: int, pts: array of Point)
{
if (len pts < 2)
return;
p0, p1: Point;
p0 = pts[0].add(offset);
for (i := 1; i < len pts; i++) {
p1 = pts[i].add(offset);
img.line(p0, p1, Draw->Enddisc, Draw->Enddisc, width, pen, p0);
p0 = p1;
}
}
badmod(mod: string)
{
sys->fprint(stderr, "cannot load %s: %r\n", mod);
raise "fail:bad module";
}
tkcmd(t: ref Tk->Toplevel, cmd: string): string
{
s := tk->cmd(t, cmd);
if (s != nil && s[0] == '!') {
sys->fprint(stderr, "%s\n", cmd);
sys->fprint(stderr, "tk error: %s\n", s);
}
return s;
}
tkcmds(t: ref Tk->Toplevel, cmds: array of string)
{
for (i := 0; i < len cmds; i++)
tkcmd(t, cmds[i]);
}