# Oberon/A2/Oberon.Sort.Mod

(* ETH Oberon, Copyright 2001 ETH Zuerich Institut fuer Computersysteme, ETH Zentrum, CH-8092 Zuerich. Refer to the "General ETH Oberon System Source License" contract available at: http://www.oberon.ethz.ch/ *)
MODULE Sort IN Oberon; (** portable *) (*SHML 13.11.91 / mf 13.10.94 / tk adapted for System3 1.6.95*)
    IMPORT Oberon, Texts, Objects, Gadgets, TextGadgets, Desktops, Documents,
       TextFrames, Viewers, MenuViewers;
    CONST NofLines = 4000;
       suffix = ".Srt";
       Menu = "System.Close System.Copy System.Grow ET.Move ET.Search ET.Replace ET.StoreAscii ";
    TYPE
       Integer = LONGINT; (* LONGINT in S3 context, INTEGER in V5 context. *)
       String = ARRAY 256 OF CHAR;
       Array = POINTER TO ARRAY NofLines OF String;
    VAR W: Texts.Writer;
       suffixArray: ARRAY 32 OF CHAR;
    (* Add suffix to name without overrunning the new array. *)
    PROCEDURE AddSuffix(VAR name, suffix, new: ARRAY OF CHAR);
       VAR i, si: Integer;
    BEGIN
       (* Locate upper bound of the first character of suffix. *)
       i := 0; si := LEN(new) - 1;
       WHILE (suffix[i] # 0X) & (0 < si) DO INC(i); DEC(si) END;
       IF suffix[i] # 0X THEN
          Texts.WriteString(W, "Long suffix truncated to fit in new array."); Texts.WriteLn(W);
          Texts.Append(Oberon.Log, W.buf)
       END;
       (* Retain or copy as much of the original name as suffix allows. *)
       i := 0; IF name = new THEN
          WHILE (i < si) & (name[i] # 0X) DO INC(i) END
       ELSE
          WHILE (i < si) & (name[i] # 0X) DO new[i] := name[i]; INC(i) END
       END;
       IF name[i] # 0X THEN
          Texts.WriteString(W, "Name truncated to fit suffix."); Texts.WriteLn(W);
             Texts.Append(Oberon.Log, W.buf)
       END;
       (* Add suffix. *)
       si := 0;
       WHILE (suffix[si] # 0X) & (i +1 < LEN(new)) DO
          new[i] := suffix[si]; INC(i); INC(si)
       END;
       new[i] := 0X
    END AddSuffix;
    PROCEDURE WriteMsg(n: (* LONGINT *) Integer; str: ARRAY OF CHAR);
    (* Write number n followed by str followed by a newline to the Log *)
    BEGIN
       Texts.WriteInt(W, n, 0);
       IF n=1 THEN Texts.WriteString(W, " line ")
       ELSE Texts.WriteString(W, " lines ")
       END;
       Texts.WriteString(W, str); Texts.WriteLn(W); Texts.Append(Oberon.Log, W.buf)
    END WriteMsg;
    (* Sort n elements of array in ascending order, HeapSort *)
    PROCEDURE HSortArray(array: Array; n: (* INTEGER *) Integer);
       VAR left, right: (* INTEGER *) Integer; a: String;
       PROCEDURE Sift(left, right: (* INTEGER *) Integer);
          VAR i, j: (* INTEGER *) Integer; a: String;
       BEGIN i:=left; j:=2*left; a:=array[left];
          IF (j < right) & (array[j] < array[j+1]) THEN INC(j) END;
          WHILE (j <= right) & (a < array[j]) DO
             array[i]:=array[j]; i:=j; j:=2*j;
             IF (j < right) & (array[j] < array[j+1]) THEN INC(j) END
          END;
          array[i]:=a
       END Sift;
    BEGIN left:=n DIV 2+1; right:=n-1;
       WHILE left > 0 DO DEC(left); Sift(left, right) END;
       WHILE right > 0 DO
          a:=array[0]; array[0]:=array[right]; array[right]:=a;
          DEC(right); Sift(left, right)
       END
    END HSortArray;
    PROCEDURE FillArray(array: Array; VAR n: (* INTEGER *) Integer; text: Texts.Text; emptyLines: BOOLEAN);
    (* Fill array with lines from text (including empty lines if requested); return number of lines in n *)
       VAR j: (* INTEGER *) Integer; len, pos: (* LONGINT *) Integer; R: Texts.Reader; ch: CHAR; white: BOOLEAN;
    BEGIN
       len:=text.len;
       (* IF len=0 THEN RETURN END; *)
       IF len#0 THEN
          Texts.OpenReader(R, text, len-1); Texts.Read(R, ch);
          IF ch # 0DX THEN Texts.Write(W, 0DX); Texts.Append(text, W.buf) END; (* terminate text with a CR *)
          Texts.OpenReader(R, text, 0);
          n:=0; pos:=0; len:=text.len;
          IF emptyLines THEN (* include empty lines *)
             REPEAT j:=0;
                REPEAT Texts.Read(R, ch); array[n, j]:=ch; INC(j) UNTIL ch=0DX;
                array[n, j]:=0X; INC(pos, (* LONG(j) *) j);
                INC(n)
             UNTIL pos=len
          ELSE (* exclude empty lines *)
             REPEAT j:=0; white:=TRUE;
                REPEAT Texts.Read(R, ch);
                   IF white & (ch > " ") THEN white:=FALSE END;
                   array[n, j]:=ch; INC(j)
                UNTIL ch=0DX;
                array[n, j]:=0X; INC(pos, (* LONG(j) *) j);
                IF ~white THEN INC(n) END (* keep line if not only white-space *)
             UNTIL pos=len
          END
       END
    END FillArray;
    PROCEDURE FillText(text: Texts.Text; array: Array; n: (* INTEGER *) Integer; reverse, unique: BOOLEAN);
    (* Fill text with n lines from array; in reverse order if requested *)
       VAR i, j, delta: (* INTEGER *) Integer; ch: CHAR; last: String;
    BEGIN
       IF reverse THEN i:=n-1; delta:=-1 ELSE i:=0; delta:=1 END;
       IF unique THEN last[0]:=0X;
          WHILE n > 0 DO
             IF array[i] # last THEN last:=array[i];
                ch:=last[0]; j:=0;
                WHILE ch # 0X DO Texts.Write(W, ch); INC(j); ch:=last[j] END;
             END;
             INC(i, delta); DEC(n)
          END
       ELSE
          WHILE n > 0 DO ch:=array[i, 0]; j:=0;
             WHILE ch # 0X DO Texts.Write(W, ch); INC(j); ch:=array[i, j] END;
             INC(i, delta); DEC(n)
          END
       END;
       Texts.Append(text, W.buf)
    END FillText;
    PROCEDURE Sort*; (** ("^" | "*" | <name>) ["/" {c}] where c IN {"r", "e", "u"} **)
    (** Sort a marked viewer, a selection, or a file. Option /r means in reverse order; /e keep empty lines **)
       VAR
          S, nameS: Texts.Scanner;
          n: Integer;
          text, sel: Texts.Text;
          beg, end, time: (* LONGINT *) Integer;
          buf: Texts.Buffer;
          array: Array;
          reverse, empty, unique: BOOLEAN;
          TF: TextGadgets.Frame;
          D: Objects.Object;
          V: Viewers.Viewer;
          name: ARRAY 16 OF CHAR;
          X, Y: INTEGER;
    BEGIN
       Texts.OpenScanner(S, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(S);
       IF S.class=Texts.Char THEN
          IF S.c="*" THEN
             text:=Oberon.MarkedText;
             (* Also get the name of the viewer. *)
             D := Documents.MarkedDoc;
             IF D = NIL THEN (* Plain old Text viewer. *)
                Texts.OpenScanner(nameS, Oberon.MarkedViewer.dsc(TextFrames.Frame).text, 0);
                Texts.Scan(nameS);
                AddSuffix(nameS.s, suffixArray, name)
             ELSE
                AddSuffix(Documents.MarkedDoc.name, suffixArray, name)
             END
          ELSIF S.c="^" THEN Oberon.GetSelection(sel, beg, end, time);
             IF time >= 0 THEN NEW(buf); Texts.OpenBuf(buf); Texts.Save(sel, beg, end, buf);
                NEW(text); Texts.Open(text, ""); Texts.Append(text, buf)
             END
          END
       ELSIF S.class=Texts.Name THEN NEW(text); Texts.Open(text, S.s)
       END;
       Texts.Scan(S);
       reverse:=FALSE; empty:=FALSE; unique:=FALSE;
       IF (S.class=Texts.Char) & (S.c=Oberon.OptionChar) THEN Texts.Scan(S);
          IF S.class=Texts.Name THEN
             reverse:=(CAP(S.s[0])="R") OR (CAP(S.s[1])="R") OR (CAP(S.s[2])="R");
             empty:=(CAP(S.s[0])="E") OR (CAP(S.s[1])="E") OR (CAP(S.s[2])="E");
             unique:=(CAP(S.s[0])="U") OR (CAP(S.s[1])="U") OR (CAP(S.s[2])="U");
          END
       END;
       NEW(array);
       FillArray(array, n, text, empty); HSortArray(array, n);
       NEW(text); Texts.Open(text, "");
       FillText(text, array, n, reverse, unique); WriteMsg(n, "sorted.");
       IF D = NIL THEN (* Text viewer. *)
          Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y);
          V := MenuViewers.New(
             TextFrames.NewMenu(name, Menu),
             TextFrames.NewText(text, 0),
             TextFrames.menuH,
             X, Y);
       ELSE
          D:=Gadgets.CreateObject("TextDocs.NewDoc");
          NEW(TF); TextGadgets.Init(TF, text, FALSE); D(Documents.Document).W:=300; (* D.name := "Sorted.Text"; *)
          COPY(name, D(Documents.Document).name);
          Documents.Init(D(Documents.Document), TF);
          Desktops.ShowDoc(D(Documents.Document))
       END;
       array:=NIL;
       Oberon.Collect
    END Sort;
BEGIN
    suffixArray := suffix;
    Texts.OpenWriter(W)
END Sort.