summaryrefslogtreecommitdiff
path: root/appl/wm/bounce.b
diff options
context:
space:
mode:
Diffstat (limited to 'appl/wm/bounce.b')
-rw-r--r--appl/wm/bounce.b356
1 files changed, 356 insertions, 0 deletions
diff --git a/appl/wm/bounce.b b/appl/wm/bounce.b
new file mode 100644
index 00000000..7d6cdd1b
--- /dev/null
+++ b/appl/wm/bounce.b
@@ -0,0 +1,356 @@
+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;
+}
generated by cgit v1.2.3 (git 2.46.0) at 2025-12-10 21:48:06 +0000