home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / oberon / demos / sortdemo.mod (.txt) < prev    next >
Oberon Text  |  1977-12-31  |  20KB  |  487 lines
  1. Syntax10.Scn.Fnt
  2. FoldElems
  3. Syntax10.Scn.Fnt
  4.   PROCEDURE Bubble*;
  5.     VAR swapped: BOOLEAN; i, n: INTEGER; data: Data;
  6.   BEGIN data := ParameterData();
  7.     IF data # NIL THEN Start;
  8.        n := data.len;
  9.        REPEAT swapped := FALSE; i := 1;
  10.          WHILE i < n DO
  11.            IF Less(data, i, i - 1) THEN Swap(data, i, i - 1); swapped := TRUE END;
  12.            INC(i)
  13.          END
  14.        UNTIL ~swapped;
  15.       Stop("SortDemo.Bubble")
  16.     END
  17.   END Bubble;
  18. Syntax10.Scn.Fnt
  19.   PROCEDURE Select*;
  20.     VAR i, j, min, len: INTEGER; data: Data;
  21.   BEGIN data := ParameterData();
  22.     IF data # NIL THEN len := data.len; Start;
  23.       i := 0;
  24.       WHILE i < len DO min := i; j := i + 1;
  25.         WHILE j < len DO
  26.           IF Less(data, j, min) THEN min := j END;
  27.           INC(j)
  28.         END;
  29.         IF i # min THEN Swap(data, i, min) END;
  30.         INC(i)
  31.       END;
  32.       Stop("SortDemo.MinSearch")
  33.     END
  34.   END Select;
  35. Syntax10.Scn.Fnt
  36.   PROCEDURE Insert*;
  37.     VAR i, lo, hi, m: INTEGER; data: Data;
  38.   BEGIN data := ParameterData();
  39.     IF data # NIL THEN Start;
  40.       i := 1;
  41.       WHILE i < data.len DO lo := 0; hi := i;
  42.         WHILE lo # hi DO m := (lo + hi) DIV 2;
  43.           IF ~Less(data, i, m) THEN lo := m + 1 ELSE hi := m END
  44.         END;
  45.         m := i;
  46.         WHILE m > hi DO Swap(data, m - 1, m); DEC(m) END;
  47.         INC(i)
  48.       END;
  49.       Stop("SortDemo.Insert")
  50.     END
  51.   END Insert;
  52. Syntax10.Scn.Fnt
  53.   PROCEDURE Shell*;
  54.     VAR i, j, h, len: INTEGER; data: Data;
  55.   BEGIN data := ParameterData();
  56.     IF data # NIL THEN len := data.len; Start;
  57.       i := 4; h := 1;
  58.       WHILE i < len DO i := i * 2; h := 2 * h + 1 END;
  59.       WHILE h # 0 DO i := h;
  60.         WHILE i < len DO j := i - h;
  61.           WHILE (j >= 0) & Less(data, j + h, j) DO Swap(data, j, j + h); j := j - h END;
  62.           INC(i)
  63.         END;
  64.         h := (h - 1) DIV 2
  65.       END;
  66.       Stop("SortDemo.Shell")
  67.     END
  68.   END Shell;
  69. Syntax10.Scn.Fnt
  70.   PROCEDURE Quick*;
  71.     VAR data: Data;
  72.     PROCEDURE Sort(lo, hi: INTEGER);
  73.       VAR i, j, m: INTEGER;
  74.     BEGIN
  75.       IF lo < hi THEN i := lo; j := hi; m := (lo + hi) DIV 2;
  76.         REPEAT
  77.           WHILE Less(data, i, m) DO INC(i) END;
  78.           WHILE Less(data, m, j) DO DEC(j) END;
  79.           IF i <= j THEN
  80.             IF m = i THEN m := j ELSIF m = j THEN m := i END;
  81.             Swap(data, i, j); INC(i); DEC(j)
  82.           END
  83.         UNTIL i > j;
  84.         Sort(lo, j); Sort(i, hi)
  85.       END
  86.     END Sort;
  87.   BEGIN data := ParameterData();
  88.     IF data # NIL THEN Start; Sort(0, data.len - 1); Stop("SortDemo.Quick") END
  89.   END Quick;
  90. Syntax10.Scn.Fnt
  91.   PROCEDURE Heap*;
  92.     VAR l, r: INTEGER; data: Data;
  93.     PROCEDURE Sift(l, r: INTEGER);
  94.       VAR i, j: INTEGER;
  95.     BEGIN i := l; j := 2 * l + 1;
  96.       IF (j + 1 < r) & Less(data, j, j + 1) THEN INC(j) END;
  97.       WHILE (j < r) & ~Less(data, j, i) DO Swap(data, i, j); i := j; j := 2 * j + 1;
  98.         IF (j + 1 < r) & Less(data, j, j + 1) THEN INC(j) END
  99.       END
  100.     END Sift;
  101.   BEGIN data := ParameterData();
  102.     IF data # NIL THEN Start;
  103.       r := data.len; l := r DIV 2;
  104.       WHILE l > 0 DO DEC(l); Sift(l, r) END;
  105.       WHILE r > 0 DO DEC(r); Swap(data, 0, r); Sift(0, r) END;
  106.       Stop("SortDemo.Heap")
  107.     END
  108.   END Heap;
  109. Syntax10.Scn.Fnt
  110. FoldElems
  111. Syntax10.Scn.Fnt
  112.     PROCEDURE Up(VAR b, c: INTEGER);
  113.       VAR b1: INTEGER;
  114.     BEGIN b1 := b; b := b + c + 1; c := b1
  115.     END Up;
  116. Syntax10.Scn.Fnt
  117.     PROCEDURE Down(VAR b, c: INTEGER);
  118.       VAR c1: INTEGER;
  119.     BEGIN c1 := c; c := b - c - 1; b := c1
  120.     END Down;
  121. Syntax10.Scn.Fnt
  122.     PROCEDURE Sift(r, b, c: INTEGER);
  123.       VAR r1: INTEGER;
  124.     BEGIN
  125.       WHILE b >= 3 DO r1 := r - b + c;
  126.         IF Less(data, r1, r - 1) THEN r1 := r - 1; Down(b, c) END;
  127.         IF Less(data, r, r1) THEN Swap(data, r, r1); r := r1; Down(b, c)
  128.         ELSE b := 1
  129.         END
  130.       END
  131.     END Sift;
  132. Syntax10.Scn.Fnt
  133.     PROCEDURE Trinkle(r, p, b, c: INTEGER);
  134.       VAR r1, r2: INTEGER;
  135.     BEGIN
  136.       WHILE p > 0 DO
  137.         WHILE ~ODD(p) DO p := p DIV 2; Up(b, c) END;
  138.         r2 := r - b;
  139.         IF (p = 1) OR ~Less(data, r, r2) THEN p := 0
  140.         ELSE p := p - 1;
  141.           IF b = 1 THEN Swap(data, r, r2); r := r2
  142.           ELSE r1 := r - b + c;
  143.             IF Less(data, r1, r - 1) THEN r1 := r - 1; Down(b, c); p := p * 2 END;
  144.             IF ~Less(data, r2, r1) THEN Swap(data, r, r2); r := r2
  145.             ELSE Swap(data, r, r1); r := r1; Down(b, c); p := 0
  146.             END
  147.           END
  148.         END
  149.       END;
  150.       Sift(r, b, c)
  151.     END Trinkle;
  152. Syntax10.Scn.Fnt
  153.     PROCEDURE SemiTrinkle(r, p, b, c: INTEGER);
  154.       VAR r1: INTEGER;
  155.     BEGIN r1 := r - c;
  156.       IF Less(data, r, r1) THEN Swap(data, r, r1); Trinkle(r1, p, b, c) END
  157.     END SemiTrinkle;
  158.   PROCEDURE Smooth*;
  159.     VAR q, r, p, b, c, len: INTEGER; data: Data;
  160.   BEGIN data := ParameterData();
  161.     IF data # NIL THEN len := data.len; Start;
  162.       q := 1; r := 0; p := 1; b := 1; c := 1;
  163.       WHILE q # len DO
  164.         IF p MOD 8 = 3 (* p = ... 011 *) THEN Sift(r, b, c);
  165.           p := (p + 1) DIV 4; Up(b, c); Up(b, c) (* b >= 3 *)
  166.         ELSE (* p = ... 01 *)
  167.           IF (q + c) < len THEN Sift(r, b, c) ELSE Trinkle(r, p, b, c) END;
  168.           Down(b, c); p := p * 2;
  169.           WHILE b # 1 DO Down(b, c); p := p * 2 END;
  170.           p := p + 1
  171.         END;
  172.         q := q + 1; r := r + 1 
  173.       END;
  174.       Trinkle(r, p, b, c);
  175.       WHILE q # 1 DO q := q - 1; p := p - 1;
  176.         IF b = 1 THEN r := r - 1;
  177.           WHILE ~ODD(p) DO p := p DIV 2; Up(b, c) END
  178.         ELSE (* b >= 3 *) r := r - b + c;
  179.           IF p > 0 THEN SemiTrinkle(r, p, b, c) END;
  180.           Down(b, c); p := p * 2 + 1; r := r + c;
  181.           SemiTrinkle(r, p, b, c); Down(b, c); p := p * 2 + 1
  182.         END
  183.       END;
  184.       Stop("SortDemo.Smooth")
  185.     END
  186.   END Smooth;
  187. MODULE SortDemo; (* W.Weck 21 Jan 93, SmoothSort due to E.W.Dijkstra, J.Gutknecht *)
  188.   IMPORT Oberon, MenuViewers, Viewers, TextFrames, Texts, Display, Input;
  189.   CONST
  190.     MinLeft = 20; PerSec = Input.TimeUnit; WaitCnt = 2; MousePollFreq = 64;
  191.     N = 300; Size = 1; DotN = N DIV 2; DotSize = Size * 2;
  192.     Menu = "System.Close  System.Grow ";
  193.   TYPE
  194.     Data = POINTER TO DataDesc;
  195.     DataDesc = RECORD
  196.       len: INTEGER;
  197.       list, lastRandom: ARRAY N OF INTEGER
  198.     END;
  199.     Frame = POINTER TO FrameDesc;
  200.     FrameDesc = RECORD(Display.FrameDesc)
  201.       data: Data;
  202.       updateReorder: PROCEDURE (f: Frame);
  203.       updateSwap: PROCEDURE (f: Frame; i, j: INTEGER);
  204.       modify: PROCEDURE (f: Frame; id, dy, y, h: INTEGER)
  205.     END;
  206.   ReorderMsg = RECORD(Display.FrameMsg)
  207.     data: Data
  208.   END;
  209.   SwapMsg = RECORD(Display.FrameMsg)
  210.     data: Data;
  211.     i, j: INTEGER
  212.   END;
  213.   VAR
  214.     seed, delay, comparisons, swaps, time: LONGINT;
  215.     w: Texts.Writer;
  216. (* Frames *)
  217.   PROCEDURE ReplConst(f: Display.FrameDesc; col, x, y, w, h, mode: INTEGER);
  218.     VAR a: INTEGER;
  219.   BEGIN
  220.     a := f.X - x; IF a > 0 THEN x := f.X; w := w - a END;
  221.     a := f.X + f.W - x; IF a < w THEN w := a END;
  222.     a := f.Y - y; IF a > 0 THEN y := f.Y; h := h - a END;
  223.     a := f.Y + f.H - y; IF a < h THEN h := a END;
  224.     IF (w > 0) & (h > 0) THEN Display.ReplConst(col, x, y, w, h, mode) END
  225.   END ReplConst;
  226.   PROCEDURE* UpdateReorder(f: Frame);
  227.     VAR left, x0, y0, i: INTEGER; data: Data;
  228.   BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H);
  229.     left := (f.W - N * Size - 2) DIV 2;
  230.     IF left < MinLeft THEN left := MinLeft END;
  231.     x0 := f.X + left; y0 := f.Y + f.H - MinLeft - N * Size + 1;
  232.     ReplConst(f^, Display.black, x0, y0, N * Size, N * Size, Display.replace);
  233.     i := N; data := f.data;
  234.     REPEAT DEC(i);
  235.       ReplConst(f^, Display.white, x0 + i * Size, y0, Size, (data.list[i] + 1) * Size, Display.replace)
  236.     UNTIL i = 0
  237.   END UpdateReorder;
  238.   PROCEDURE* UpdateSwap(f: Frame; i, j: INTEGER);
  239.     VAR left, x0, y0, hi, hj, h: INTEGER;
  240.   BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H);
  241.     left := (f.W - N * Size - 2) DIV 2;
  242.     IF left < MinLeft THEN left := MinLeft END;
  243.     x0 := f.X + left; y0 := f.Y + f.H - MinLeft - N * Size + 1;
  244.     hi := (f.data.list[i] + 1) * Size; hj := (f.data.list[j] + 1) * Size;
  245.     IF hi < hj THEN y0 := y0 + hi; h := hj - hi ELSE y0 := y0 + hj; h := hi - hj END;
  246.     ReplConst(f^, Display.white, x0 + i * Size, y0, Size, h, Display.invert);
  247.     ReplConst(f^, Display.white, x0 + j * Size, y0, Size, h, Display.invert)
  248.   END UpdateSwap;
  249.   PROCEDURE* Modify(f: Frame; id, dy, y, h: INTEGER);
  250.     VAR x0, y0, i, left: INTEGER; data: Data; clip: Display.FrameDesc;
  251.   BEGIN
  252.     IF id = MenuViewers.reduce THEN
  253.       IF dy # 0 THEN Display.CopyBlock(f.X, f.Y + dy, f.W, h, f.X, y, Display.replace) END;
  254.       f.Y := y; f.H := h
  255.     ELSE
  256.       IF dy # 0 THEN Display.CopyBlock(f.X, f.Y, f.W, f.H, f.X, f.Y + dy, Display.replace) END;
  257.       clip.X := f.X; clip.W := f.W; clip.Y := y; clip.H := h - f.H;
  258.       f.Y := y; f.H := h;
  259.       left := (f.W - N * Size - 2) DIV 2;
  260.       IF left < MinLeft THEN left := MinLeft END;
  261.       x0 := f.X + left; y0 := f.Y + f.H - MinLeft - N * Size + 1;
  262.       ReplConst(clip, Display.black, f.X, f.Y, f.W, f.H, Display.replace);
  263.       ReplConst(clip, Display.white, x0 - 1, y0 - 1, N * Size + 2, 1, Display.replace);
  264.       ReplConst(clip, Display.white, x0 - 1, y0 + N * Size, N * Size + 2, 1, Display.replace);
  265.       ReplConst(clip, Display.white, x0 - 1, y0, 1, N * Size + 1, Display.replace);
  266.       ReplConst(clip, Display.white, x0 + N * Size, y0, 1, N * Size + 1, Display.replace);
  267.       i := N; data := f.data;
  268.       REPEAT DEC(i);
  269.         ReplConst(clip, Display.white, x0 + i * Size, y0, Size, (data.list[i] + 1) * Size, Display.replace)
  270.       UNTIL i = 0
  271.     END
  272.   END Modify;
  273.   PROCEDURE* UpdateReorderDotView(f: Frame);
  274.     VAR left, x0, y0, i: INTEGER; data: Data;
  275.   BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H);
  276.     left := (f.W - DotN * DotSize - 2) DIV 2;
  277.     IF left < MinLeft THEN left := MinLeft END;
  278.     x0 := f.X + left; y0 := f.Y + f.H - MinLeft - DotN * DotSize + 1;
  279.     ReplConst(f^, Display.black, x0, y0, DotN * DotSize, DotN * DotSize, Display.replace);
  280.     i := DotN; data := f.data;
  281.     REPEAT DEC(i);
  282.       ReplConst(f^, Display.white, x0 + i * DotSize, y0 + data.list[i] * DotSize, DotSize, DotSize, Display.replace)
  283.     UNTIL i = 0
  284.   END UpdateReorderDotView;
  285.   PROCEDURE* UpdateSwapDotView(f: Frame; i, j: INTEGER);
  286.     VAR left, x0, y0, xi, yi, xj, yj: INTEGER;
  287.   BEGIN Oberon.RemoveMarks(f.X, f.Y, f.W, f.H);
  288.     left := (f.W - DotN * DotSize - 2) DIV 2;
  289.     IF left < MinLeft THEN left := MinLeft END;
  290.     x0 := f.X + left; y0 := f.Y + f.H - MinLeft - DotN * DotSize + 1;
  291.     xi := x0 + i * DotSize; yi := y0 + f.data.list[i] * DotSize;
  292.     xj := x0 + j * DotSize; yj := y0 + f.data.list[j] * DotSize;
  293.     ReplConst(f^, Display.white, xi, yj, DotSize, DotSize, Display.invert);
  294.     ReplConst(f^, Display.white, xj, yi, DotSize, DotSize, Display.invert);
  295.     ReplConst(f^, Display.white, xi, yi, DotSize, DotSize, Display.invert);
  296.     ReplConst(f^, Display.white, xj, yj, DotSize, DotSize, Display.invert)
  297.   END UpdateSwapDotView;
  298.   PROCEDURE* ModifyDotView(f: Frame; id, dy, y, h: INTEGER);
  299.     VAR x0, y0, i, left: INTEGER; data: Data; clip: Display.FrameDesc;
  300.   BEGIN
  301.     IF id = MenuViewers.reduce THEN
  302.       IF dy # 0 THEN Display.CopyBlock(f.X, f.Y + dy, f.W, h, f.X, y, Display.replace) END;
  303.       f.Y := y; f.H := h
  304.     ELSE
  305.       IF dy # 0 THEN Display.CopyBlock(f.X, f.Y, f.W, f.H, f.X, f.Y + dy, Display.replace) END;
  306.       clip.X := f.X; clip.W := f.W; clip.Y := y; clip.H := h - f.H;
  307.       f.Y := y; f.H := h;
  308.       left := (f.W - DotN * DotSize - 2) DIV 2;
  309.       IF left < MinLeft THEN left := MinLeft END;
  310.       x0 := f.X + left; y0 := f.Y + f.H - MinLeft - DotN * DotSize + 1;
  311.       ReplConst(clip, Display.black, f.X, f.Y, f.W, f.H, Display.replace);
  312.       ReplConst(clip, Display.white, x0 - 1, y0 - 1, DotN * DotSize + 2, 1, Display.replace);
  313.       ReplConst(clip, Display.white, x0 - 1, y0 + DotN * DotSize, DotN * DotSize + 2, 1, Display.replace);
  314.       ReplConst(clip, Display.white, x0 - 1, y0, 1, DotN * DotSize + 1, Display.replace);
  315.       ReplConst(clip, Display.white, x0 + DotN * DotSize, y0, 1, DotN * DotSize + 1, Display.replace);
  316.       i := DotN; data := f.data;
  317.       REPEAT DEC(i);
  318.         ReplConst(clip, Display.white, x0 + i * DotSize, y0 + data.list[i] * DotSize, DotSize, DotSize, Display.replace)
  319.       UNTIL i = 0
  320.     END
  321.   END ModifyDotView;
  322.   PROCEDURE CopyOf(f: Frame): Frame;
  323.     VAR c: Frame;
  324.   BEGIN NEW(c); c.data := f.data;
  325.     c.handle := f.handle;
  326.     c.updateReorder := f.updateReorder; c.updateSwap := f.updateSwap; c.modify := f.modify;
  327.     RETURN c
  328.   END CopyOf;
  329.   PROCEDURE* Handler(f: Display.Frame; VAR m: Display.FrameMsg);
  330.     VAR self: Frame;
  331.   BEGIN self := f(Frame);
  332.     IF m IS ReorderMsg THEN
  333.       IF m(ReorderMsg).data = self.data THEN self.updateReorder(self) END
  334.     ELSIF m IS SwapMsg THEN
  335.       WITH m: SwapMsg DO
  336.         IF m.data = self.data THEN self.updateSwap(self, m.i, m.j) END
  337.       END
  338.     ELSIF m IS MenuViewers.ModifyMsg THEN
  339.       WITH m: MenuViewers.ModifyMsg DO self.modify(self, m.id, m.dY, m.Y, m.H) END
  340.     ELSIF m IS Oberon.CopyMsg THEN m(Oberon.CopyMsg).F := CopyOf(self)
  341.     ELSIF m IS Oberon.InputMsg THEN
  342.       WITH m: Oberon.InputMsg DO
  343.         IF m.id = Oberon.track THEN Oberon.DrawCursor(Oberon.Mouse, Oberon.Arrow, m.X, m.Y) END
  344.       END
  345.     END
  346.   END Handler;
  347. (* Data manipulations *)
  348.   PROCEDURE Less(data: Data; i, j: INTEGER): BOOLEAN;
  349.     VAR x, y: INTEGER; keys: SET;
  350.   BEGIN x := SHORT(delay);
  351.     WHILE x # 0 DO DEC(x); y := WaitCnt * N DIV data.len;
  352.       REPEAT DEC(y) UNTIL y = 0
  353.     END;
  354.     IF comparisons MOD MousePollFreq = 0 THEN
  355.       REPEAT Input.Mouse(keys, x, y) UNTIL keys = {}
  356.     END;
  357.     INC(comparisons);
  358.     RETURN data.list[i] < data.list[j]
  359.   END Less;
  360.   PROCEDURE Swap(data: Data; i, j: INTEGER);
  361.     VAR x: INTEGER; msg: SwapMsg;
  362.   BEGIN x := data.list[i]; data.list[i] := data.list[j]; data.list[j] := x;
  363.     INC(swaps);
  364.     msg.data := data; msg.i := i; msg.j := j; Viewers.Broadcast(msg);
  365.   END Swap;
  366. (* auxiliary *)
  367.   PROCEDURE ParameterData(): Data;
  368.     VAR l: Data; v: Viewers.Viewer;
  369.   BEGIN
  370.     IF Oberon.Par.vwr.dsc = Oberon.Par.frame THEN
  371.       IF (Oberon.Par.frame # NIL) & (Oberon.Par.frame.next # NIL) & (Oberon.Par.frame.next IS Frame) THEN
  372.         l := Oberon.Par.frame.next(Frame).data
  373.       END
  374.     ELSE v := Oberon.MarkedViewer();
  375.       IF (v.dsc # NIL) & (v.dsc.next # NIL) & (v.dsc.next IS Frame) THEN l := v.dsc.next(Frame).data END
  376.     END;
  377.     RETURN l
  378.   END ParameterData;
  379.   PROCEDURE ParInteger(): LONGINT;
  380.     VAR text: Texts.Text; beg, end, time: LONGINT; s: Texts.Scanner;
  381.   BEGIN Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
  382.     IF (s.line = 0) & (s.class = Texts.Char) & (s.c = "^") THEN Oberon.GetSelection(text, beg, end, time);
  383.       IF time >= 0 THEN Texts.OpenScanner(s, text, beg); Texts.Scan(s) END
  384.     END;
  385.     IF (s.line = 0) & (s.class = Texts.Int) THEN RETURN s.i ELSE RETURN -1 END
  386.   END ParInteger;
  387.   PROCEDURE Start;
  388.   BEGIN comparisons := 0; swaps := 0; time := Oberon.Time()
  389.   END Start;
  390.   PROCEDURE Stop(name: ARRAY OF CHAR);
  391.     VAR t: LONGINT;
  392.   BEGIN t := Oberon.Time();
  393.     Texts.WriteString(w, name); Texts.WriteString(w, ": ");
  394.     Texts.WriteInt(w, comparisons, 0); Texts.WriteString(w, " comparisons, ");
  395.     Texts.WriteInt(w, swaps , 0); Texts.WriteString(w, " swaps, ");
  396.     t := (t - time) * 100 DIV PerSec;
  397.     Texts.WriteInt(w, t DIV 100, 0); Texts.Write(w, "."); Texts.WriteInt(w, t DIV 10 MOD 10, 0);
  398.     Texts.WriteInt(w, t MOD 10, 0); Texts.WriteString(w, " sec");
  399.     Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
  400.   END Stop;
  401. (* commands *)
  402.   PROCEDURE NewData(size: INTEGER): Data;
  403.     VAR i: INTEGER; data: Data;
  404.   BEGIN NEW(data); data.len := size; i := size;
  405.     REPEAT DEC(i); data.list[i] := i UNTIL i = 0;
  406.     data.lastRandom := data.list;
  407.     RETURN data
  408.   END NewData;
  409.   PROCEDURE Open*;
  410.     VAR x, y: INTEGER; f: Frame; v: MenuViewers.Viewer;
  411.   BEGIN NEW(f); f.handle := Handler; f.data := NewData(N);
  412.     f.updateReorder := UpdateReorder; f.updateSwap := UpdateSwap; f.modify := Modify;
  413.     Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  414.     v := MenuViewers.New(TextFrames.NewMenu("SortDemo", Menu), f, TextFrames.menuH, x, y)
  415.   END Open;
  416.   PROCEDURE OpenDotView*;
  417.     VAR x, y: INTEGER; f: Frame; v: MenuViewers.Viewer;
  418.   BEGIN NEW(f); f.handle := Handler; f.data := NewData(DotN);
  419.     f.updateReorder := UpdateReorderDotView; f.updateSwap := UpdateSwapDotView; f.modify := ModifyDotView;
  420.     Oberon.AllocateUserViewer(Oberon.Mouse.X, x, y);
  421.     v := MenuViewers.New(TextFrames.NewMenu("SortDemo", Menu), f, TextFrames.menuH, x, y)
  422.   END OpenDotView;
  423.   PROCEDURE SetCompareCost*;
  424.     VAR x: LONGINT;
  425.   BEGIN x := ParInteger();
  426.     IF x >= 0 THEN delay := x END;
  427.     Texts.WriteString(w, "SortDemo.SetCompareCost "); Texts.WriteInt(w, delay, 0); Texts.WriteLn(w);
  428.     Texts.Append(Oberon.Log, w.buf)
  429.   END SetCompareCost;
  430. (* pre ordering *)
  431.   PROCEDURE Randomize*;
  432.     CONST a = 16807; m = 2147483647; q = m DIV a; r = m MOD a;
  433.     VAR i, n: LONGINT; k, l, x, len: INTEGER; data: Data; msg: SwapMsg;
  434.   BEGIN data := ParameterData();
  435.     IF data # NIL THEN len := data.len; n := ParInteger();
  436.       IF n > 0 THEN
  437.         REPEAT DEC(n);
  438.           i := a * (seed MOD q) - r * (seed DIV q);
  439.           IF i > 0 THEN seed := i ELSE seed := i + m END;
  440.           k := SHORT(seed MOD len); l := SHORT((seed DIV len) MOD len);
  441.           x := data.list[k]; data.list[k] := data.list[l]; data.list[l] := x;
  442.           msg.data := data; msg.i := k; msg.j := l; Viewers.Broadcast(msg)
  443.         UNTIL n = 0;
  444.         data.lastRandom := data.list
  445.       END
  446.     END
  447.   END Randomize;
  448.   PROCEDURE Recall*;
  449.     VAR data: Data; msg: ReorderMsg;
  450.   BEGIN data := ParameterData();
  451.     IF data # NIL THEN data.list := data.lastRandom;
  452.       msg.data := data; Viewers.Broadcast(msg)
  453.     END
  454.   END Recall;
  455.   PROCEDURE ReverseOrder*;
  456.     VAR i, len: INTEGER; data: Data; msg: ReorderMsg;
  457.   BEGIN data := ParameterData();
  458.     IF data # NIL THEN len := data.len; i := len;
  459.       REPEAT DEC(i); data.list[i] := len - 1 - i UNTIL i = 0;
  460.       msg.data := data; Viewers.Broadcast(msg)
  461.     END
  462.   END ReverseOrder;
  463.   PROCEDURE QuickWorstOrder*;
  464.     VAR i, j, m, x, len: INTEGER; data: Data; msg: ReorderMsg;
  465.   BEGIN data := ParameterData();
  466.     IF data # NIL THEN len := data.len; i := len;
  467.       REPEAT DEC(i); data.list[i] := i UNTIL i = 0;
  468.       i := (len - 1) DIV 2; j := i;
  469.       WHILE j < len - 1 DO INC(j); m := (i + j) DIV 2;
  470.         x := data.list[j]; data.list[j] := data.list[m]; data.list[m] := x;
  471.         IF i > 0 THEN DEC(i); m := (i + j) DIV 2;
  472.           x := data.list[i]; data.list[i] := data.list[m]; data.list[m] := x
  473.         END
  474.       END;
  475.       msg.data := data; Viewers.Broadcast(msg)
  476.     END
  477.   END QuickWorstOrder;
  478. (* sorters *)
  479. Bubble
  480. Select
  481. Insert
  482. Shell
  483. Quick
  484. Smooth
  485. BEGIN seed := Oberon.Time(); Texts.OpenWriter(w); delay := 100
  486. END SortDemo.
  487.