ref: 1018d7a7091fd5e0433f501a3474cdc3fec322cc
dir: /appl/wm/bounce.b/
implement Bounce; # 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; Point, Rect: import draw; include "tk.m"; tk: Tk; include "tkclient.m"; tkclient: Tkclient; include "math.m"; math: Math; include "rand.m"; Bounce: module { init: fn(ctxt: ref Draw->Context, argv: list of string); }; BALLSIZE: con 4; ZERO: con 1e-6; π: con Math->Pi; Line: adt { p1, p2: Point; }; Realpoint: adt { x, y: real; }; gamecmds := array[] of { "canvas .c", "bind .c <ButtonRelease-1> {send cmd 0 %x %y}", "bind .c <ButtonRelease-2> {send cmd 0 %x %y}", "bind .c <Button-1> {send cmd 1 %x %y}", "bind .c <Button-2> {send cmd 2 %x %y}", "frame .f", "button .f.left -bitmap small_color_left.bit -bd 0 -command {send cmd k -1}", "button .f.right -bitmap small_color_right.bit -bd 0 -command {send cmd k 1}", "label .f.l -text {8 balls}", "pack .f.left .f.right -side left", "pack .f.l -side left", "pack .f -fill x", "pack .c -fill both -expand 1", }; randch: chan of int; lines: list of (int, Line); lineid := 0; lineversion := 0; addline(win: ref Tk->Toplevel, v: Line) { lines = (++lineid, v) :: lines; cmd(win, ".c create line " + pt2s(v.p1) + " " + pt2s(v.p2) + " -width 3 -fill black" + " -tags l" + string lineid); lineversion++; } nomod(s: string) { sys->fprint(sys->fildes(2), "bounce: cannot load %s: %r\n", s); raise "fail:bad module"; } init(ctxt: ref Draw->Context, argv: list of string) { sys = load Sys Sys->PATH; 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(); nballs := 8; if (argv != nil && tl argv != nil) nballs = int hd tl argv; if (nballs < 0) { sys->fprint(sys->fildes(2), "usage: bounce [nballs]\n"); raise "fail:usage"; } sys->pctl(Sys->NEWPGRP, nil); if(ctxt == nil) ctxt = tkclient->makedrawcontext(); (win, wmctl) := tkclient->toplevel(ctxt, nil, "Bounce", 0); cmdch := chan of string; tk->namechan(win, cmdch, "cmd"); for (i := 0; i < len gamecmds; i++) cmd(win, gamecmds[i]); cmd(win, ".c configure -width 400 -height 400"); cmd(win, "pack propagate . 0"); cmd(win, ".f.l configure -text '" + string nballs + " balls"); tkclient->onscreen(win, nil); tkclient->startinput(win, "kbd"::"ptr"::nil); mch := chan of (int, Point); randch = chan of int; spawn randgenproc(randch); csz := Point(int cmd(win, ".c cget -actwidth"), int cmd(win, ".c cget -actheight")); # add edges of window addline(win, ((-1, -1), (csz.x, -1))); addline(win, ((csz.x, -1), csz)); addline(win, (csz, (-1, csz.y))); addline(win, ((-1, csz.y), (-1, -1))); spawn makelinesproc(win, mch); mkball := chan of (int, Realpoint, Realpoint); spawn monitor(win, mkball); for (i = 0; i < nballs; i++) mkball <-= (1, randpoint(csz), makeunit(randpoint(csz))); 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 = <-wmctl => tkclient->wmctl(win, s); c := <-cmdch => (nil, toks) := sys->tokenize(c, " "); if (hd toks != "k") { mch <-= (int hd toks, Point(int hd tl toks, int hd tl tl toks)); continue; } n := nballs + int hd tl toks; if (n < 0) n = 0; dn := 1; if (n < nballs) dn = -1; for (; nballs != n; nballs += dn) mkball <-= (dn, randpoint(csz), makeunit(randpoint(csz))); cmd(win, ".f.l configure -text '" + string nballs + " balls"); cmd(win, "update"); } } randpoint(size: Point): Realpoint { return (randreal(size.x), randreal(size.y)); } # return randomish real number between 1 and x-1 randreal(x: int): real { return real (<-randch % ((x - 1) * 100)) / 100.0 + 1.0; } # 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 can be created and destroyed by # sending on mkball. processes are arranged in a stack-like # order: new processes are added to the top of the stack, and # processes are destroyed from the top of the stack downwards. monitor(win: ref Tk->Toplevel, mkball: chan of (int, Realpoint, Realpoint)) { procl := proc := chan of int :: nil; spawn nullproc(hd proc); # always there to avoid deadlock when no balls. hd proc <-= 1; # hand token to dummy proc for (;;) { procc := hd proc; alt { (n, p, v) := <-mkball => if (n > 0) { # start new ball proc going. procl = chan of int :: procl; spawn animproc(hd procl, win, p, v); } else if (tl procl != nil) { # stop a ball proc. <-hd proc; # get token. hd procl <-= 0; # stop proc. proc = procl = tl procl; # remove proc. hd proc <-= 1; # hand out token. } <-procc => # got token. if ((proc = tl proc) == nil) proc = procl; hd proc <-= 1; # hand token to next process. } } } nullproc(c: chan of int) { for (;;) c <-= <-c; } # animate one ball. initial position and unit-velocity are # given by p and v. animproc(c: chan of int, win: ref Tk->Toplevel, p, v: Realpoint) { speed := 0.1 + real (<-randch % 40) / 100.0; ballid := cmd(win, sys->sprint(".c create oval 0 0 1 1 -fill #%.6x", <-randch & 16rffffff)); hitlineid := -1; smallcount := 0; version := lineversion; loop: for (;;) { hitline: Line; hitp: Realpoint; dist := 1000000.0; oldid := hitlineid; for (l := lines; l != nil; l = tl l) { (id, line) := hd l; (ok, hp, hdist) := intersect(p, v, line); if (ok && hdist < dist && id != oldid && (smallcount < 10 || hdist > 1.5)) { (hitp, hitline, hitlineid, dist) = (hp, line, id, hdist); } } if (dist > 10000.0) { sys->print("no intersection!\n"); # sys->print("p: [%f, %f], v: [%f, %f]\n", p.x, p.y, v.x, v.y); # for (l := lines; l != nil; l = tl l) { # (id, line) := hd l; # (ok, hp, hdist) := intersect(p, v, line); # sys->print("line: [%d %d]->[%d %d] -> %d, [%f, %f], %f\n", line.p1.x, line.p1.y, line.p2.x, line.p2.y, # ok, hp.x, hp.y, hdist); # } cmd(win, ".c delete " + ballid + ";update"); while (c <-= <-c) ; exit; } if (dist < 0.0001) smallcount++; else smallcount = 0; bouncev := boing(v, hitline); t0 := sys->millisec(); dt := int (dist / speed); t := 0; do { s := real t * speed; currp := Realpoint(p.x + s * v.x, p.y + s * v.y); bp := Point(int currp.x, int currp.y); cmd(win, ".c coords " + ballid + " " + string (bp.x-BALLSIZE)+" "+string (bp.y-BALLSIZE)+" "+ string (bp.x+BALLSIZE)+" "+string (bp.y+BALLSIZE)); cmd(win, "update"); if (lineversion > version) { (p, hitlineid, version) = (currp, oldid, lineversion); continue loop; } # pass the token back to the monitor. if (<-c == 0) { cmd(win, ".c delete " + ballid + ";update"); exit; } c <-= 1; t = sys->millisec() - t0; } while (t < dt); p = hitp; v = bouncev; } } # thread-safe access to the Rand module randgenproc(ch: chan of int) { rand := load Rand Rand->PATH; for (;;) ch <-= rand->rand(16r7fffffff); } makelinesproc(win: ref Tk->Toplevel, mch: chan of (int, Point)) { for (;;) { (down, p1) := <-mch; addline(win, (p1, p1)); (id, nil) := hd lines; p2 := p1; do { (down, p2) = <-mch; cmd(win, ".c coords l" + string id + " " + pt2s(p1) + " " + pt2s(p2)); cmd(win, "update"); lines = (id, (p1, p2)) :: tl lines; lineversion++; if (down > 1) { dp := p2.sub(p1); if (dp.x*dp.x + dp.y*dp.y > 5) { p1 = p2; addline(win, (p2, p2)); (id, nil) = hd lines; } } } while (down); } } # make a vector of unit-length, parallel to v. makeunit(v: Realpoint): Realpoint { mag := math->sqrt(v.x * v.x + v.y * v.y); return (v.x / mag, v.y / mag); } # bounce ball travelling in direction av off line b. # return the new unit vector. boing(av: Realpoint, b: Line): Realpoint { f := b.p2.sub(b.p1); d := math->atan2(real f.y, real f.x) * 2.0 - math->atan2(av.y, av.x); return (math->cos(d), math->sin(d)); } # 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. intersect(p, v: Realpoint, b: Line): (int, Realpoint, real) { w := Realpoint(real (b.p2.x - b.p1.x), real (b.p2.y - b.p1.y)); det := w.x * v.y - v.x * w.y; if (det > -ZERO && det < ZERO) return (0, (0.0, 0.0), 0.0); y21 := real b.p1.y - p.y; x21 := real b.p1.x - p.x; s := (w.x * y21 - w.y * x21) / det; if (s < 0.0) return (0, (0.0, 0.0), 0.0); hp := Realpoint(p.x+v.x*s, p.y+v.y*s); if (b.p1.x > b.p2.x) (b.p1.x, b.p2.x) = (b.p2.x, b.p1.x); if (b.p1.y > b.p2.y) (b.p1.y, b.p2.y) = (b.p2.y, b.p1.y); return (int hp.x >= b.p1.x && int hp.x <= b.p2.x && int hp.y >= b.p1.y && int hp.y <= int b.p2.y, hp, s); } 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; } pt2s(p: Point): string { return string p.x + " " + string p.y; }