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.