IMPLEMENTATION MODULE SortLib;
(*------------------------------------------------------------------------*)
(* Stellt verschiedene Sortieralgorithmen primaer fuer Felder von Gleit- *)
(* kommazahlen aber auch anderer Datenstrukturen zur Verfuegung. *)
(* Module providing several sorting algorithms mainly for arrays of *)
(* reals but also genereal data structures *)
(*------------------------------------------------------------------------*)
(* Procedures MergeSort,VecPerm,RowPerm source: *)
(* NumAl, Stichting Centrum Wiskunde & Informatica (Stichting CWI), *)
(* Section 3.3.1.1.3.1 (November 1976) routines *)
(* *)
(* Authors: Admiraal, J.J.G., Ysselstein, A.C. *)
(* *)
(* This section contains three procedures for sorting the elements of a *)
(* vector and correspondingly permuting the elements of a vector or a *)
(* matrix row. *)
(* *)
(* References: *)
(* *)
(* [1] Knuth, D.E. The art of computer programming, *)
(* Vol. 3 / Sorting and searching, Section 5.2.4, pp 159-173, *)
(* Addison-Wesley (1973). *)
(* [2] Aho, A.V., j.e. Hopcroft, J.E. & Ullman, J.D. *)
(* The design and analysis of computer algorithms, pp 65-67, *)
(* Addison-Wesley (1974). *)
(* *)
(* Procedures Find,ShakerSort,ShellSort,HeapSort,QuickSort, *)
(* NonRecursiveQuickSort,StraightMerge from: *)
(* *)
(* Wirth, Niklaus; "Algorithmen und Datenstrukturen", B.G. Teubner, *)
(* Stuttgart (1986) *)
(*------------------------------------------------------------------------*)
(* Letzte Bearbeitung: *)
(* *)
(* Dez 1994, MRi: Intitial version of HeapSortGeneral *)
(* 20.01.16, MRi: Erstellen der ersten Modula-2 Version von MergeSort, *)
(* VecPerm und RowPerm aus Algol-Quellen *)
(* 21.01.16, MRi: Korrekturen, MergeSort und VecPerm scheinen zu *)
(* funktionieren *)
(* 09.04.16, MRi: Erstellen der Routine MergeSortNR *)
(* 11.04.16, MRi: Erstellen der Routine MergeSortRC *)
(* 13.04.16, MRi: Erstellen der Routinen aus N. Wirth A.&D. *)
(* 14.05.16, MRi: Zusammenfassen in SortLib *)
(* 05.10.17, MRi: CVecPerm eingefuegt *)
(*------------------------------------------------------------------------*)
(* Implementation : Michael Riedl *)
(* Licence : GNU Lesser General Public License (LGPL) *)
(*------------------------------------------------------------------------*)
(* $Id: SortLib.mod,v 1.1 2018/01/16 09:20:42 mriedl Exp $ *)
FROM SYSTEM IMPORT TSIZE;
FROM Storage IMPORT ALLOCATE,DEALLOCATE;
FROM Deklera IMPORT MaxDim,VEKTOR,MATRIX,INTVEKTOR;
IMPORT Errors;
TYPE BVEKTOR = ARRAY [1..MaxDim-0] OF BOOLEAN;
PROCEDURE InvertIndex(VAR In : ARRAY OF INTEGER;
I0 : ARRAY OF INTEGER;
n : INTEGER);
VAR i : INTEGER;
BEGIN
FOR i:=0 TO n-1 DO In[I0[i]]:=i; END;
END InvertIndex;
PROCEDURE QuickSortNR(VAR A : ARRAY OF LONGREAL;
VAR I : ARRAY OF INTEGER;
n : INTEGER);
CONST M = 12;
VAR i,j,L,R,s,w : INTEGER;
x : LONGREAL;
low,high : ARRAY [0..M-1] OF INTEGER; (* index stack *)
BEGIN
FOR i:=0 TO n-1 DO I[i]:=i; END;
FOR i:=n TO VAL(INTEGER,HIGH(I)) DO I[i]:=-1; END;
s:=0; low[0]:=0; high[0]:= n-1;
REPEAT (* take top request from stack *)
L := low[s]; R := high[s]; DEC(s);
REPEAT (* partition A[I[L]] ... A[I[R]] *)
i := L; j := R; x := A[I[(L+R) DIV 2]];
REPEAT
WHILE (A[I[i]] < x) DO INC(i); END;
WHILE (x < A[I[j]]) DO DEC(j); END;
IF (i <= j) THEN
w := I[i]; I[i] := I[j]; I[j] := w; INC(i); DEC(j);
END;
UNTIL (i > j);
IF (i < R) THEN (* stack request to sort right partition *)
INC(s); low[s] := i; high[s] := R;
END;
R := j; (* now L and R delimit the left partition *)
UNTIL (L >= R);
UNTIL (s < 0);
InvertIndex(I,I,n);
END QuickSortNR;
PROCEDURE QuickSortRC(VAR A : ARRAY OF LONGREAL;
n : INTEGER);
PROCEDURE sort(L, R: INTEGER);
VAR i,j : INTEGER;
w,x : LONGREAL;
BEGIN
i := L; j := R;
x := A[(L+R) DIV 2];
REPEAT
WHILE (A[i] < x) DO INC(i); END;
WHILE (x < A[j]) DO DEC(j); END;
IF (i <= j) THEN
w := A[i]; A[i] := A[j]; A[j] := w; INC(i); DEC(j);
END;
UNTIL (i > j);
IF (L < j) THEN sort(L,j); END;
IF (i < R) THEN sort(i,R); END;
END sort;
BEGIN
sort(0,n-1);
END QuickSortRC;
PROCEDURE Find(VAR A : ARRAY OF LONGREAL;
n,k : INTEGER);
VAR L,R,i,j : INTEGER;
w,x : LONGREAL;
BEGIN
L := 0; R := n-1;
WHILE (L < R-1) DO
x := A[k]; i := L; j := R;
REPEAT
WHILE (A[i] < x) DO INC(i); END;
WHILE (x < A[j]) DO DEC(j); END;
IF (i <= j) THEN
w := A[i]; A[i] := A[j]; A[j] := w; INC(i); DEC(j);
END;
UNTIL (i > j);
IF (j < k) THEN L := i; END;
IF (k < i) THEN R := j; END;
END;
END Find;
PROCEDURE ShakerSort(VAR A : ARRAY OF LONGREAL;
n : INTEGER);
VAR j,k,L,R : INTEGER;
x : LONGREAL;
BEGIN
L := 1;
R := n-1;
k := R;
REPEAT
FOR j:=R TO L BY -1 DO
IF (A[j-1] > A[j]) THEN
x := A[j-1]; A[j-1] := A[j]; A[j] := x; k := j;
END;
END ;
L := k+1;
FOR j:=L TO R BY +1 DO
IF (A[j-1] > A[j]) THEN
x := A[j-1]; A[j-1] := A[j]; A[j] := x; k := j;
END;
END;
R := k-1;
UNTIL (L > R);
END ShakerSort;
PROCEDURE ShellSort(VAR A : ARRAY OF LONGREAL;
n : INTEGER);
CONST T = 4;
VAR i,j,k,m : INTEGER;
x : LONGREAL;
h : ARRAY [0..T-1] OF INTEGER;
BEGIN
h[0] := 9; h[1] := 5;
h[2] := 3; h[3] := 1;
FOR m:=0 TO T-1 DO
k := h[m];
FOR i:=k+1 TO n-1 DO
x := A[i]; j := i - k;
WHILE ((j >= k) AND (x < A[j])) DO A[j+k] := A[j]; j:=j - k END;
A[j+k] := x
END
END
END ShellSort;
PROCEDURE HeapSort(VAR A : ARRAY OF LONGREAL;
n : INTEGER);
PROCEDURE sift(L,R : INTEGER);
VAR i,j : INTEGER;
x : LONGREAL;
BEGIN
i := L; j := 2*i + 1;
x := A[i];
IF ((j < R) AND (A[j] < A[j+1])) THEN INC(j); END;
WHILE ((j <= R) AND (x < A[j])) DO
A[i] := A[j]; i := j; j := 2*j + 1;
IF ((j < R) AND (A[j] < A[j+1])) THEN INC(j); END;
END;
A[i] := x;
END sift;
VAR L,R : INTEGER;
x : LONGREAL;
BEGIN
L := n DIV 2; R := n-1;
WHILE (L > 0) DO DEC(L); sift(L,R); END;
WHILE (R > 0) DO
x := A[0]; A[0] := A[R]; A[R] := x;
DEC(R); sift(L,R);
END;
END HeapSort;
PROCEDURE StraightMerge(VAR A : ARRAY OF INTEGER; (* A[0..2*n-1] *)
n : INTEGER);
VAR i,j,k,L,t : INTEGER;
h,m,p,q,r : INTEGER;
up : BOOLEAN;
BEGIN
IF (HIGH(A) < 2*VAL(CARDINAL,n)-1) THEN
Errors.Fehlerflag:="Feld A zu klein (StraightMerge)";
Errors.Fehler:=TRUE;
Errors.ErrOut(Errors.Fehlerflag);
RETURN;
END;
up := TRUE; p := 1;
REPEAT
h := 1; m := n;
IF up THEN
i:=0; j := n - 1; k := n; L := 2*n - 1;
ELSE
k:=0; L := n - 1; i := n; j := 2*n - 1;
END;
REPEAT (* merge a run from i- and j-sources to k-destination *)
IF (m >= p) THEN q := p ELSE q := m; END;
m := m - q;
IF (m >= p) THEN r := p ELSE r := m; END;
m:=m - r;
WHILE (q > 0) AND (r > 0) DO
IF (A[i] < A[j]) THEN
A[k] := A[i]; INC(i); DEC(q);
ELSE
A[k] := A[j]; DEC(j); DEC(r);
END;
k:=k + h;
END;
WHILE (r > 0) DO
A[k] := A[j]; k:=k + h; DEC(j); DEC(r);
END;
WHILE (q > 0) DO
A[k] := A[i]; k:=k + h; INC(i); DEC(q);
END;
h := -h; t := k; k := L; L := t;
UNTIL (m = 0);
up := NOT up; p:=2*p;
UNTIL (p >= n);
IF NOT up THEN
FOR i:=0 TO n-1 DO A[i] := A[i+n]; END; (* Incorrect in original *)
END;
END StraightMerge;
PROCEDURE MergeSortRC(VAR A : ARRAY OF LONGREAL;
N : INTEGER);
VAR B: POINTER TO ARRAY [0..MAX(INTEGER)-1] OF LONGREAL;
PROCEDURE Sort(l,r : INTEGER);
PROCEDURE Merge(left,mid,right : INTEGER);
VAR i,m,k,l : INTEGER;
BEGIN
l := left;
i := left;
m := mid+1;
WHILE (l <= mid) AND (m <= right) DO
IF A[l] <= A[m] THEN
B^[i] := A[l]; INC(l);
ELSE
B^[i] := A[m]; INC(m);
END;
INC(i);
END;
IF (l > mid) THEN
FOR k:=m TO right DO B^[i] := A[k]; INC(i); END;
ELSE
FOR k:=l TO mid DO B^[i] := A[k]; INC(i); END;
END;
FOR k:=left TO right DO A[k] := B^[k]; END;
END Merge;
VAR m: INTEGER;
BEGIN
IF r > l THEN
m := (r + l) DIV 2;
Sort(l ,m);
Sort(m+1,r);
Merge(l,m,r);
END;
END Sort;
BEGIN
ALLOCATE(B,(N+1)*TSIZE(LONGREAL));
Sort(0,N-1);
DEALLOCATE(B,(N+1)*TSIZE(LONGREAL));
END MergeSortRC;
PROCEDURE MergeSortNR(VAR A : ARRAY OF LONGREAL;
num : INTEGER);
(*----------------------------------------------------------------*)
(* Algorithm from Rama Hoetzlein on stackoverflow.com *)
(* questions 1557894 non-recursive-merge-sort *)
(*----------------------------------------------------------------*)
VAR i,j,k,m : INTEGER;
left,right,rend : INTEGER;
B : POINTER TO
ARRAY [0..MAX(INTEGER)-1] OF LONGREAL;
BEGIN
ALLOCATE(B,num*TSIZE(LONGREAL));
IF (B = NIL) THEN
Errors.FatalError("Kein Freispeicher vorhanden (MergeSort)");
END;
k:=1;
WHILE (k < num) DO
left:=0;
WHILE (left+k < num) DO
right := left + k;
rend := right + k;
IF (rend > num) THEN rend := num; END;
m := left; i := left; j := right;
WHILE (i < right) AND (j < rend) DO
IF (A[i] <= A[j]) THEN
B^[m] := A[i]; INC(i);
ELSE
B^[m] := A[j]; INC(j);
END;
INC(m);
END;
WHILE (i < right) DO
B^[m] := A[i];
INC(i); INC(m);
END;
WHILE (j < rend) DO
B^[m] := A[j];
INC(j); INC(m);
END;
FOR m:=left TO rend-1 DO
A[m] := B^[m];
END;
left:=left + k*2;
END; (* WHILE *)
k:=k*2;
END; (* WHILE *)
DEALLOCATE(B,num*TSIZE(LONGREAL));
END MergeSortNR;
PROCEDURE MergeSort(VAR a : VEKTOR;
VAR p : INTVEKTOR;
low,up : INTEGER);
VAR rout,lout : BOOLEAN;
l,r,pl,pr : INTEGER;
hp : POINTER TO INTVEKTOR;
PROCEDURE merge(lo,ls,rs : INTEGER);
VAR i:INTEGER;
BEGIN
l:=lo; i:=lo;
r:=lo+ls;
lout:=FALSE; rout:=FALSE;
REPEAT
pl:=p[l]; pr:=p[r];
IF (a[pl] > a[pr]) THEN
hp^[i]:=pr; INC(r);
rout:=r=lo+ls+rs;
ELSE
hp^[i]:=pl; INC(l);
lout:=l=lo+ls;
END;
INC(i);
UNTIL (lout OR rout);
IF rout THEN
FOR i:=lo+ls-1 TO l BY -1 DO
p[i+rs]:=p[i];
END;
r:=l+rs;
END;
FOR i:=r-1 TO lo BY -1 DO p[i]:=hp^[i]; END;
END merge;
VAR i,lo,step,stap,umlp1,umsp1,rest,restv : INTEGER;
BEGIN
NEW(hp);
FOR i:=low TO up DO p[i]:=i; END;
restv:=0;
umlp1:=up-low+1;
step:=1;
REPEAT
stap:=2*step;
umsp1:=up-stap+1;
lo:=low;
WHILE (lo <= umsp1) DO
merge(lo,step,step);
lo:=lo+stap;
END;
rest:=up-lo+1;
IF (rest > restv) AND (restv > 0) THEN
merge(lo,rest-restv,restv);
END;
restv:=rest;
step:=step*2;
UNTIL (step >= umlp1);
DISPOSE(hp);
END MergeSort;
PROCEDURE VecPerm(VAR perm : INTVEKTOR;
low,upp : INTEGER;
VAR vector : VEKTOR);
VAR t,j,k : INTEGER;
a : LONGREAL;
todo : POINTER TO BVEKTOR;
BEGIN
NEW(todo);
IF (todo = NIL) THEN
Errors.Fehlerflag:="Kein Freispeicher vorhanden (VecPerm)";
Errors.Fehler:=TRUE;
RETURN;
END;
FOR t:=low TO upp DO todo^[t]:=TRUE; END;
FOR t:=low TO upp DO
IF todo^[t] THEN
k:=t;
a:=vector[k];
j:=perm[k];
WHILE (j # t) DO
vector[k]:=vector[j];
todo^[k]:=FALSE;
k:=j; j:=perm[k];
END;
vector[k]:=a;
todo^[k]:= FALSE;
END;
END;
DISPOSE(todo);
END VecPerm;
PROCEDURE CVecPerm(VAR perm : ARRAY OF CARDINAL;
low,upp : CARDINAL;
VAR vector : ARRAY OF LONGCOMPLEX);
TYPE BVEKTOR = ARRAY [0..MAX(INTEGER)-1] OF BOOLEAN;
VAR t,j,k : CARDINAL;
a : LONGCOMPLEX;
todo : POINTER TO BVEKTOR;
BEGIN
DEC(low); DEC(upp); (* wg. offener Feder *)
ALLOCATE(todo,(upp+1)*TSIZE(BOOLEAN));
IF (todo = NIL) THEN
Errors.Fehlerflag:="Kein Freispeicher vorhanden (CVecPerm)";
Errors.Fehler:=TRUE;
RETURN;
END;
FOR t:=low TO upp DO todo^[t]:=TRUE; END;
FOR t:=low TO upp DO
IF todo^[t] THEN
k:=t;
a:=vector[k];
j:=perm[k]-1;
WHILE (j # t) DO
vector[k]:=vector[j];
todo^[k]:=FALSE;
k:=j; j:=perm[k]-1;
END;
vector[k]:=a;
todo^[k]:= FALSE;
END;
END;
DEALLOCATE(todo,(upp+1)*TSIZE(BOOLEAN));
END CVecPerm;
PROCEDURE RowPerm(VAR perm : INTVEKTOR;
low : INTEGER;
upp : INTEGER;
i : INTEGER;
VAR mat : MATRIX);
VAR t,j,k : INTEGER;
a : LONGREAL;
todo : POINTER TO BVEKTOR;
BEGIN
NEW(todo);
FOR t:=low TO upp DO todo^[t]:= TRUE; END;
FOR t:=low TO upp DO
IF todo^[t] THEN
k:=t;
a:=mat[i,k];
j:=perm[k];
WHILE (j # t) DO
mat[i,k]:=mat[i,j];
todo^[k]:=FALSE;
k:=j; j:=perm[k];
END;
mat[i,k]:=a;
todo^[k]:=FALSE;
END;
END;
DISPOSE(todo);
END RowPerm;
PROCEDURE HeapSortGeneral(N : CARDINAL;
Vergleich : VergleichsProz;
Vertausche : VertauschProz);
VAR i,j,k : CARDINAL;
BEGIN
IF (N <= 1) THEN RETURN END;
i := N DIV 2;
REPEAT
j:=i;
LOOP (* Die totale Anzahl von Wiederholungen *)
k := 2*j; (* ist \sum_{i=1}^\infty {i n \over 2^{i+1} } *)
IF (k > N) THEN EXIT END;
IF (k < N) AND Vergleich(k,k+1) THEN INC(k); END;
IF Vergleich(j,k) THEN Vertausche(j,k) ELSE EXIT END;
j:=k;
END;
DEC(i);
UNTIL (i = 0);
i:=N;
REPEAT
j := 1;
Vertausche(j,i);
DEC(i);
LOOP
k := 2*j;
IF (k > i) THEN EXIT END;
IF (k < i) AND Vergleich(k,k+1) THEN INC(k) END;
Vertausche(j,k);
j := k;
END;
LOOP
k := j DIV 2;
IF (k > 0) AND Vergleich(k,j) THEN
Vertausche(j,k); j:=k;
ELSE
EXIT;
END;
END;
UNTIL (i = 0);
END HeapSortGeneral;
END SortLib.