Oberon/V4.Sort.Mod

(* ETH Oberon, Copyright (c) 1990-2017 Computer Systems Institute, ETH Zurich, CH-8092 Zurich. All rights reserved. License at ftp://ftp.ethoberon.ethz.ch/ETHOberon/license.txt . *) MODULE V4Sort; (** portable *) (*SHML 13.11.91 / mf 13.10.94 / tk adapted for System3 1.6.95*) IMPORT Oberon, Texts, Documents, TextFrames, Viewers, MenuViewers; CONST NofLines = 4000; suffix = ".Srt"; Menu = "System.Close System.Copy System.Grow EditTools.StoreAscii "; TYPE Integer = LONGINT; (* LONGINT in EO context, INTEGER in GA context. *) String = ARRAY 256 OF CHAR; Array = POINTER TO ARRAY NofLines OF String; VAR W: Texts.Writer; (* Add suffix to name without overrunning the new array. *) PROCEDURE AddSuffix(name, suffix: ARRAY OF CHAR; VAR 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 new[i] := name[i]; INC(i) END ELSE WHILE (i < si) & (name[i] # 0X) DO 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; (* Write number n followed by str followed by a newline to the Log *) PROCEDURE WriteMsg(n: (* LONGINT *) Integer; str: ARRAY OF CHAR); 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; (* Fill array with lines from text (including empty lines if requested); return number of lines in n *) PROCEDURE FillArray(array: Array; VAR n: (* INTEGER *) Integer; text: Texts.Text; emptyLines: BOOLEAN); 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; (* Fill text with n lines from array; in reverse order if requested *) PROCEDURE FillText(text: Texts.Text; array: Array; n: (* INTEGER *) Integer; reverse, unique: BOOLEAN); 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; (** Sort a marked viewer, a selection, or a file. Option /r means in reverse order; /e keep empty lines **) PROCEDURE Sort*; (** ("^" | "*" | <name>) ["/" {c}] where c IN {"r", "e", "u"} **) 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; 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 V := Oberon.MarkedViewer(); IF ~(V IS MenuViewers.Viewer) THEN HALT(30) END; (* normal Viewers don't have a menu where I can scan for a name and don't have a text to sort *) Texts.OpenScanner(nameS, V.dsc(TextFrames.Frame).text, 0); Texts.Scan(nameS); COPY(nameS.s, name); text := V.dsc.next(TextFrames.Frame).text; ELSIF S.c="^" THEN Oberon.GetSelection(sel, beg, end, time); IF time >= 0 THEN name := "Selection"; NEW(text); Texts.Open(text, name); NEW(buf); Texts.OpenBuf(buf); Texts.Save(sel, beg, end, buf); Texts.Append(text, buf) END END ELSIF S.class=Texts.Name THEN COPY(S.s, name); NEW(text); Texts.Open(text, name) END; Texts.Scan(S); reverse:=FALSE; empty:=FALSE; unique:=FALSE; IF (S.class=Texts.Char) & (S.c="/") 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."); AddSuffix(name, suffix, name); Oberon.AllocateUserViewer(Oberon.Par.vwr.X, X, Y); V := MenuViewers.New( TextFrames.NewMenu(name, Menu), TextFrames.NewText(text, 0), TextFrames.menuH, X, Y); array:=NIL; Oberon.Collect(0) END V4Sort; BEGIN Texts.OpenWriter(W) END V4Sort.