home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / demos / rott.mod (.txt) < prev    next >
Oberon Text  |  2012-04-20  |  10KB  |  241 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10i.Scn.Fnt
  3. MODULE Rott;    (* bh '90; V2.2 shml 22 Mar 93 *) 
  4.     IMPORT Oberon, Display, Display1, Texts, MenuViewers, Viewers, TextFrames, Input, Math;
  5.     CONST P = 4; Q = 1; G = 0.001; F = 0.00000001; invert = Display.invert; delay = 50; (* ms *)
  6.     TYPE
  7.         Frame = POINTER TO FrameDesc;
  8.         FrameDesc = RECORD(Display.FrameDesc);
  9.             a, b, da, db: REAL;
  10.             n, t: LONGINT
  11.         END;
  12.         StepMsg = RECORD(Display.FrameMsg) END;
  13.         W: Texts.Writer;
  14.         T: Oberon.Task;
  15.     PROCEDURE Line(F: Display.Frame; col, X0, Y0, X1, Y1, mode: INTEGER);
  16.     (* Draws a line from (X0, Y0) to (X1, Y1) inclusive, clipped against F. For all line points (x, y) the following holds
  17.         always: (min(X0, X1) <= x) & (x <= max(X0, X1) & (min(Y0, Y0) <= y) & (y <= max(Y0, Y1). *)
  18.         VAR x, y, dx, dy, d, inc, L, B, R, T, Xmin, Xmax, Ymin, Ymax: INTEGER;
  19.     BEGIN
  20.         L := F.X; B := F.Y; R := F.X + F.W; T := F.Y + F.H;
  21.         IF X0 < X1 THEN Xmin := X0; Xmax := X1 ELSE Xmin := X1; Xmax := X0 END;
  22.         IF Y0 < Y1 THEN Ymin := Y0; Ymax := Y1 ELSE Ymin := Y1; Ymax := Y0 END;
  23.         IF (L <= Xmax) & (Xmin < R) & (B <= Ymax) & (Ymin < T) THEN (* line may be visible *)
  24.             IF Xmin = Xmax THEN Display.ReplConstC(F, col, Xmin, Ymin, 1, Ymax-Ymin+1, mode)
  25.             ELSIF Ymin = Ymax THEN Display.ReplConstC(F, col, Xmin, Ymin, Xmax-Xmin+1, 1, mode)
  26.             ELSE
  27.                 IF (Y1-Y0) < (X0-X1) THEN x := X0; X0 := X1; X1 := x; y := Y0; Y0 := Y1; Y1 := y END;
  28.                 dx := 2*(X1-X0); dy := 2*(Y1-Y0); x := X0; y := Y0; inc := 1;
  29.                 IF (L <= Xmin) & (Xmax < R) & (B <= Ymin) & (Ymax < T) THEN (* no clipping *)
  30.                     IF dy > dx THEN d := dy DIV 2;
  31.                         IF dx < 0 THEN inc := -1; dx := -dx END;
  32.                         WHILE y <= Y1 DO
  33.                             Display.Dot(col, x, y, mode);
  34.                             INC(y); DEC(d, dx);
  35.                             IF d < 0 THEN INC(d, dy); INC(x, inc) END
  36.                         END
  37.                     ELSE d := dx DIV 2;
  38.                         IF dy < 0 THEN inc := -1; dy := -dy END;
  39.                         WHILE x <= X1 DO
  40.                             Display.Dot(col, x, y, mode);
  41.                             INC(x); DEC(d, dy);
  42.                             IF d < 0 THEN INC(d, dx); INC(y, inc) END
  43.                         END
  44.                     END
  45.                 ELSE (* dot-wise clipping *)
  46.                     IF dy > dx THEN d := dy DIV 2;
  47.                         IF dx < 0 THEN inc := -1; dx := -dx END;
  48.                         WHILE y <= Y1 DO
  49.                             IF (L <= x) & (x < R) & (B <= y) & (y < T) THEN Display.Dot(col, x, y, mode) END;
  50.                             INC(y); DEC(d, dx);
  51.                             IF d < 0 THEN INC(d, dy); INC(x, inc) END
  52.                         END
  53.                     ELSE d := dx DIV 2;
  54.                         IF dy < 0 THEN inc := -1; dy := -dy END;
  55.                         WHILE x <= X1 DO
  56.                             IF (L <= x) & (x < R) & (B <= y) & (y < T) THEN Display.Dot(col, x, y, mode) END;
  57.                             INC(x); DEC(d, dy);
  58.                             IF d < 0 THEN INC(d, dx); INC(y, inc) END
  59.                         END
  60.                     END
  61.                 END
  62.             END
  63.         END
  64.     END Line;
  65.     PROCEDURE Circle(F: Display.Frame; col, X, Y, R, mode: INTEGER);
  66.     (* Draws a circle with center (X, Y) and radius R, clipped against F. For all circle points (x, y)  the following holds always:
  67.         (X-R <= x) & (x < X+R) & (Y-R <= y) & (y < Y+R). *)
  68.         VAR x, y, dx, dy, d, L, B, Rt, T: INTEGER;
  69.         PROCEDURE Dot4 (x1, x2, y1, y2: INTEGER);
  70.         BEGIN
  71.             Display.Dot(col, x1, y1, mode);
  72.             Display.Dot(col, x1, y2, mode);
  73.             Display.Dot(col, x2, y1, mode);
  74.             Display.Dot(col, x2, y2, mode)
  75.         END Dot4;
  76.         PROCEDURE Dot4c (x1, x2, y1, y2: INTEGER);
  77.         BEGIN
  78.             IF (L <= x1) & (x1 < Rt) THEN
  79.                 IF (B <= y1) & (y1 < T) THEN Display.Dot(col, x1, y1, mode) END;
  80.                 IF (B <= y2) & (y2 < T) THEN Display.Dot(col, x1, y2, mode) END;
  81.             END;
  82.             IF (L <= x2) & (x2 < Rt) THEN
  83.                 IF (B <= y1) & (y1 < T) THEN Display.Dot(col, x2, y1, mode) END;
  84.                 IF (B <= y2) & (y2 < T) THEN Display.Dot(col, x2, y2, mode) END;
  85.             END
  86.         END Dot4c;
  87.     BEGIN
  88.         L := F.X; B := F.Y; Rt := F.X + F.W; T := F.Y + F.H;
  89.         IF (L < X+R) & (X-R < Rt) & (B < Y+R) & (Y-R < T) THEN (* circle may be visible *)
  90.             x := R-1; y := 0; dx := 8*(x-1); dy := 8*y+4; d := 3 - 4*R;
  91.             IF (L <= X-R) & (X+R <= Rt) & (B <= Y-R) & (Y+R <= T) THEN (* no clipping *)
  92.                 WHILE x > y DO
  93.                     Dot4(X-x-1, X+x, Y-y-1, Y+y);
  94.                     Dot4(X-y-1, X+y, Y-x-1, Y+x);
  95.                     INC(d, dy); INC(dy, 8); INC(y);
  96.                     IF d >= 0 THEN DEC(d, dx); DEC(dx, 8); DEC(x) END
  97.                 END;
  98.                 IF x = y THEN Dot4(X-x-1, X+x, Y-y-1, Y+y) END
  99.             ELSE (* dot-wise clipping *)
  100.                 WHILE x > y DO
  101.                     Dot4c(X-x-1, X+x, Y-y-1, Y+y);
  102.                     Dot4c(X-y-1, X+y, Y-x-1, Y+x);
  103.                     INC(d, dy); INC(dy, 8); INC(y);
  104.                     IF d >= 0 THEN DEC(d, dx); DEC(dx, 8); DEC(x) END
  105.                 END;
  106.                 IF x = y THEN Dot4c(X-x-1, X+x, Y-y-1, Y+y) END
  107.             END
  108.         END
  109.     END Circle;
  110.     PROCEDURE Draw(F: Frame);
  111.         CONST c1 = 1; c2 = 3; c3 = 15;
  112.         VAR xla, yla, xha, yha, xhb, yhb, xda, yda, xdb, ydb, x0, y0: INTEGER;  l ,d, h, r: REAL;
  113.     BEGIN
  114.         x0 := F.X + F.W DIV 2; y0 := F.Y + F.H DIV 2;
  115.         IF F.W > F.H THEN l := F.H ELSE l := F.W END;
  116.         l := l / 6; h := 1.558 * l; d := l / 8;
  117.         r := Math.cos(F.a);
  118.         xla := SHORT(ENTIER(l * r + 0.5));
  119.         xha := SHORT(ENTIER(h * r + 0.5));
  120.         xda := SHORT(ENTIER(d * r + 0.5));
  121.         r := Math.sin(F.a);
  122.         yla := SHORT(ENTIER(l * r + 0.5));
  123.         yha := SHORT(ENTIER(h * r + 0.5));
  124.         yda := SHORT(ENTIER(d * r + 0.5));
  125.         r := Math.cos(F.b);
  126.         xhb := SHORT(ENTIER(h * r + 0.5));
  127.         xdb := SHORT(ENTIER(d * r + 0.5));
  128.         r := Math.sin(F.b);
  129.         yhb := SHORT(ENTIER(h * r + 0.5));
  130.         ydb := SHORT(ENTIER(d * r + 0.5));
  131.         Display1.Line(F, c1, x0-xla-xda-yda, y0-yla-yda+xda, x0+xla+xda-yda, y0+yla+yda+xda, invert);
  132.         Display1.Line(F, c1, x0-xla-xda+yda, y0-yla-yda-xda, x0+xla-xda+yda, y0+yla-yda-xda, invert);
  133.         Display1.Line(F, c1, x0-xla-xda-yda, y0-yla-yda+xda, x0-xla-xda+yda, y0-yla-yda-xda, invert);
  134.         Display1.Line(F, c1, x0+xla+xda-yda, y0+yla+yda+xda, x0+xla+xda+yha, y0+yla+yda-xha, invert);
  135.         Display1.Line(F, c1, x0+xla-xda+yda, y0+yla-yda-xda, x0+xla-xda+yha, y0+yla-yda-xha, invert);
  136.         Display1.Line(F, c1, x0+xla+xda+yha, y0+yla+yda-xha, x0+xla-xda+yha, y0+yla-yda-xha, invert);
  137.         Display1.Line(F, c2, x0-xla+xdb-ydb, y0-yla+ydb+xdb, x0-xla+xdb+yhb, y0-yla+ydb-xhb, invert);
  138.         Display1.Line(F, c2, x0-xla-xdb-ydb, y0-yla-ydb+xdb, x0-xla-xdb+yhb, y0-yla-ydb-xhb, invert);
  139.         Display1.Line(F, c2, x0-xla+xdb-ydb, y0-yla+ydb+xdb, x0-xla-xdb-ydb, y0-yla-ydb+xdb, invert);
  140.         Display1.Line(F, c2, x0-xla+xdb+yhb, y0-yla+ydb-xhb, x0-xla-xdb+yhb, y0-yla-ydb-xhb, invert);
  141.         Display1.Circle(F, c3, x0-xla, y0-yla, SHORT(ENTIER(d)), invert);
  142.         Display1.Circle(F, c3, x0, y0, SHORT(ENTIER(d)), invert);
  143.     END Draw;
  144.     PROCEDURE Der(a, b, da, db: REAL; VAR Da, Db, Dda, Ddb: REAL);
  145.         VAR x, y, det, sind, cosd, f: REAL;
  146.     BEGIN
  147.         Da := da; Db := db;
  148.         sind := Math.sin(a - b);
  149.         cosd := Math.cos(a - b);
  150.         x := G * Math.sin(a) - db * db * cosd;
  151.         y := G * Math.sin(b) + da * da * cosd;
  152.         det := P * Q - sind * sind;
  153.         IF da > 10*F THEN f := F ELSIF da < -10*F THEN f := -F ELSE f := 0 END;
  154.         Dda := (sind * y - Q * x) / det - f;
  155.         IF db > 10*F THEN f := F ELSIF db < -10*F THEN f := -F ELSE f := 0 END;
  156.         Ddb := (sind * x - P * y) / det - f
  157.     END Der;
  158.     PROCEDURE Step(F: Frame);
  159.         VAR dda1, ddb1, dda2, ddb2, dda3, ddb3, dda4, ddb4, da1, db1, da2, db2, da3, db3, da4, db4: REAL;
  160.     BEGIN
  161.         Der(F.a, F.b, F.da, F.db, da1, db1, dda1, ddb1);
  162.         Der(F.a+3*da1, F.b+3*db1, F.da+3*dda1, F.db+3*ddb1, da2, db2, dda2, ddb2);
  163.         Der(F.a+3*da2, F.b+3*db2, F.da+3*dda2, F.db+3*ddb2, da3, db3, dda3, ddb3);
  164.         Der(F.a+6*da3, F.b+6*db3, F.da+6*dda3, F.db+6*ddb3, da4, db4, dda4, ddb4);
  165.         Draw(F);
  166.         F.a := F.a + da1 + 2 * da2 + 2 * da3 + da4;
  167.         F.b := F.b + db1 + 2 * db2 + 2 * db3 + db4;
  168.         F.da := F.da + dda1 + 2 * dda2 + 2 * dda3 + dda4;
  169.         F.db := F.db + ddb1 + 2 * ddb2 + 2 * ddb3 + ddb4;
  170.         Draw(F);
  171.         INC(F.n)
  172.     END Step;
  173.     PROCEDURE Edit(F: Frame; X, Y: INTEGER; Keys: SET);
  174.         VAR x0, y0: INTEGER;
  175.     BEGIN
  176.         IF 2 IN Keys THEN
  177.             F.da := 0; F.db := 0; x0 := X; y0 := Y;
  178.             REPEAT
  179.                 Input.Mouse(Keys, X, Y);
  180.                 Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, X, Y);
  181.                 IF (X # x0) OR (Y # y0) THEN
  182.                     Draw(F);
  183.                     F.a := F.a + (Y - y0) / 100; F.b := F.b + (X - x0) / 100;
  184.                     Draw(F);
  185.                     x0 := X; y0 := Y
  186.                 END
  187.             UNTIL Keys = {};
  188.         ELSE
  189.             REPEAT
  190.                 Input.Mouse(Keys, X, Y);
  191.                 Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, X, Y);
  192.             UNTIL Keys = {}
  193.         END
  194.     END Edit;
  195.     PROCEDURE* Handle(F: Display.Frame; VAR M: Display.FrameMsg);
  196.         VAR F1: Frame;
  197.     BEGIN
  198.          WITH F: Frame DO
  199.             IF M IS Oberon.InputMsg THEN
  200.                 WITH M: Oberon.InputMsg DO
  201.                     IF M.id = Oberon.track THEN Edit(F, M.X, M.Y, M.keys) END
  202.                 END
  203.             ELSIF M IS MenuViewers.ModifyMsg THEN
  204.                 WITH M: MenuViewers.ModifyMsg DO
  205.                     IF M.id = MenuViewers.extend THEN F.H := F.H + F.Y - M.Y + M.dY
  206.                     ELSIF M.id = MenuViewers.reduce THEN F.H := F.H + F.Y - M.Y - M.dY
  207.                     END;
  208.                     F.Y := M.Y;
  209.                     Display.ReplConst(0, F.X, F.Y, F.W, F.H, Display.replace);
  210.                     Draw(F)
  211.                 END
  212.             ELSIF M IS Oberon.CopyMsg THEN NEW(F1); F1^ := F^; M(Oberon.CopyMsg).F := F1
  213.             ELSIF M IS StepMsg THEN Step(F)
  214.             END
  215.         END
  216.     END Handle;
  217.     PROCEDURE Open*;
  218.         VAR F: Frame; x, y: INTEGER; v: MenuViewers.Viewer;
  219.     BEGIN
  220.         NEW(F); F.a := Math.pi; F.b := 3.14; F.da := 0.0; F.db := 0.0; F.n := 0; F.t := 0; F.handle := Handle;
  221.         Oberon.AllocateUserViewer(Oberon.Par.vwr.X, x, y);
  222.         v := MenuViewers.New(
  223.             TextFrames.NewMenu("Rott.Open ", " System.Close System.Copy System.Grow"),
  224.             F, TextFrames.menuH, x, y)
  225.     END Open;
  226.     PROCEDURE Start*;
  227.     BEGIN Oberon.Install(T)
  228.     END Start;
  229.     PROCEDURE Stop*;
  230.     BEGIN Oberon.Remove(T);
  231.     END Stop;
  232.     PROCEDURE* Handler;
  233.         VAR m: StepMsg;
  234.     BEGIN Viewers.Broadcast(m); T.time := Input.Time() + Input.TimeUnit * delay DIV 1000
  235.     END Handler;
  236. BEGIN Texts.OpenWriter(W); NEW(T); T.handle := Handler; T.time := 0; Start
  237. END Rott.
  238. Rott.Open
  239. Rott.Start
  240. Rott.Stop
  241.