summaryrefslogtreecommitdiff
path: root/tests/examplefiles/Sorting.mod
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examplefiles/Sorting.mod')
-rw-r--r--tests/examplefiles/Sorting.mod470
1 files changed, 0 insertions, 470 deletions
diff --git a/tests/examplefiles/Sorting.mod b/tests/examplefiles/Sorting.mod
deleted file mode 100644
index d6a27c1f..00000000
--- a/tests/examplefiles/Sorting.mod
+++ /dev/null
@@ -1,470 +0,0 @@
-IMPLEMENTATION MODULE Sorting;
-
-(* J. Andrea, Dec.16/91 *)
-(* This code may be freely used and distributed, it may not be sold. *)
-
-(* Adapted to ISO Module-2 by Frank Schoonjans Feb 2004 *)
-
-FROM Storage IMPORT ALLOCATE;
-
-CONST
- max_stack = 20;
- n_small = 6; (* use a simple sort for this size and smaller *)
-
-VAR
- rtemp :REAL;
- ctemp :CARDINAL;
-
- L, R, n :INTEGER;
- top, bottom, lastflip :INTEGER;
-
- tos :CARDINAL;
- Lstack, Rstack :ARRAY [1..max_stack] OF INTEGER;
-
- (* --------------------------------------------------- *)
- PROCEDURE CardQSortIndex( x :ARRAY OF CARDINAL; array_len :CARDINAL;
- VAR index :ARRAY OF CARDINAL );
-
- VAR
- median : CARDINAL;
- i,j : INTEGER;
- BEGIN
-
- n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
-
- (* initialize the index *)
- FOR i := 0 TO n DO
- index[i] := VAL(CARDINAL,i);
- END;
-
- tos := 0;
-
- L := 0; R := n;
-
- (* PUSH very first set *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := R;
-
- REPEAT
-
- (* POP *)
- L := Lstack[tos]; R := Rstack[tos]; tos := tos - 1;
-
- IF R - L + 1 > n_small THEN
-
- REPEAT
- i := L; j := R; median := x[index[( L + R ) DIV 2]];
-
- REPEAT
- WHILE x[index[i]] < median DO
- i := i + 1;
- END;
- WHILE median < x[index[j]] DO
- j := j - 1;
- END;
-
- IF i <= j THEN (* swap *)
- ctemp := index[i]; index[i] := index[j]; index[j] := ctemp;
- i := i + 1; j := j - 1;
- END;
- UNTIL i > j;
-
- IF j - L < R - i THEN
- IF i < R THEN (* PUSH *)
- tos := tos + 1; Lstack[tos] := i; Rstack[tos] := R;
- END;
- R := j;
- ELSE
- IF L < j THEN (* push *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := j;
- END;
- L := i;
- END;
-
- UNTIL L >= R;
-
- ELSE
-
- (* small sort for small number of values *)
- FOR i := L TO R - 1 DO
- FOR j := i TO R DO
- IF x[index[i]] > x[index[j]] THEN
- ctemp := index[i];
- index[i] := index[j];
- index[j] := ctemp
- END;
- END;
- END;
-
- END; (* check for small *)
-
- UNTIL tos = 0;
-
- END CardQSortIndex;
-
- (* --------------------------------------------------- *)
- PROCEDURE RealQSortIndex( x :ARRAY OF REAL; array_len :CARDINAL;
- VAR index :ARRAY OF CARDINAL );
-
- VAR
- median :REAL;
- i,j :INTEGER;
- BEGIN
-
- n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
-
- (* initialize the index *)
- FOR i := 0 TO n DO
- index[i] := VAL(CARDINAL,i);
- END;
-
- tos := 0;
-
- L := 0; R := n;
-
- (* PUSH very first set *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := R;
-
- REPEAT
-
- (* POP *)
- L := Lstack[tos]; R := Rstack[tos]; tos := tos - 1;
-
- IF R - L + 1 > n_small THEN
-
- REPEAT
- i := L; j := R; median := x[index[( L + R ) DIV 2]];
-
- REPEAT
- WHILE x[index[i]] < median DO
- i := i + 1;
- END;
- WHILE median < x[index[j]] DO
- j := j - 1;
- END;
-
- IF i <= j THEN (* swap *)
- ctemp := index[i]; index[i] := index[j]; index[j] := ctemp;
- i := i + 1; j := j - 1;
- END;
- UNTIL i > j;
-
- IF j - L < R - i THEN
- IF i < R THEN (* PUSH *)
- tos := tos + 1; Lstack[tos] := i; Rstack[tos] := R;
- END;
- R := j;
- ELSE
- IF L < j THEN (* push *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := j;
- END;
- L := i;
- END;
-
- UNTIL L >= R;
-
- ELSE
-
- (* small sort for small number of values *)
- FOR i := L TO R - 1 DO
- FOR j := i TO R DO
- IF x[index[i]] > x[index[j]] THEN
- ctemp := index[i];
- index[i] := index[j];
- index[j] := ctemp
- END;
- END;
- END;
-
- END; (* check for small *)
-
- UNTIL tos = 0;
-
- END RealQSortIndex;
-
- (* --------------------------------------------------- *)
- PROCEDURE CardQSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
-
- VAR
- median : CARDINAL;
- n,i,j : INTEGER;
- BEGIN
-
- n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
-
- tos := 0;
-
- L := 0; R := n;
-
- (* PUSH very first set *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := R;
-
- REPEAT
-
- (* POP *)
- L := Lstack[tos]; R := Rstack[tos]; tos := tos - 1;
-
- IF R - L + 1 > n_small THEN
-
- REPEAT
- i := L; j := R; median := x[( L + R ) DIV 2];
-
- REPEAT
- WHILE x[i] < median DO
- i := i + 1;
- END;
- WHILE median < x[j] DO
- j := j - 1;
- END;
-
- IF i <= j THEN (* swap *)
- ctemp := x[i]; x[i] := x[j]; x[j] := ctemp;
- i := i + 1; j := j - 1;
- END;
- UNTIL i > j;
-
- IF j - L < R - i THEN
- IF i < R THEN (* PUSH *)
- tos := tos + 1; Lstack[tos] := i; Rstack[tos] := R;
- END;
- R := j;
- ELSE
- IF L < j THEN (* push *)
- tos := tos + 1; Lstack[tos] := L; Rstack[tos] := j;
- END;
- L := i;
- END;
-
- UNTIL L >= R;
-
- ELSE
-
- (* small sort for small number of values *)
- FOR i := L TO R - 1 DO
- FOR j := i TO R DO
- IF x[i] > x[j] THEN
- ctemp := x[i];
- x[i] := x[j];
- x[j] := ctemp
- END;
- END;
- END;
-
- END; (* check for small *)
-
- UNTIL tos = 0;
-
- END CardQSort;
-
- (* ----------------------------------------------------- *)
- PROCEDURE CardBSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
- VAR i,j : INTEGER;
- BEGIN
- top := 0; (* open arrays are zero offset *)
- bottom := VAL(INTEGER,array_len) - 1;
-
- WHILE top < bottom DO
-
- lastflip := top;
-
- FOR i := top TO bottom-1 DO
- IF x[i] > x[i+1] THEN (* flip *)
- ctemp := x[i];
- x[i] := x[i+1];
- x[i+1] := ctemp;
- lastflip := i;
- END;
- END;
-
- bottom := lastflip;
-
- IF bottom > top THEN
-
- i := bottom - 1;
- FOR j := top TO bottom-1 DO
- IF x[i] > x[i+1] THEN (* flip *)
- ctemp := x[i];
- x[i] := x[i+1];
- x[i+1] := ctemp;
- lastflip := i;
- END;
- i := i - 1;
- END;
-
- top := lastflip + 1;
-
- ELSE
- (* force a loop failure *)
- top := bottom + 1;
- END;
-
- END;
-
- END CardBSort;
-
-
- (* ----------------------------------------------------- *)
- PROCEDURE RealBSort( VAR x :ARRAY OF REAL; array_len :CARDINAL );
- VAR bottom,top : INTEGER;
- i,j : INTEGER;
- BEGIN
- top := 0; (* open arrays are zero offset *)
- bottom := VAL(INTEGER,array_len) - 1;
-
- WHILE top < bottom DO
-
- lastflip := top;
-
- FOR i := top TO bottom-1 DO
- IF x[i] > x[i+1] THEN (* flip *)
- rtemp := x[i];
- x[i] := x[i+1];
- x[i+1] := rtemp;
- lastflip := i;
- END;
- END;
-
- bottom := lastflip;
-
- IF bottom > top THEN
-
- i := bottom - 1;
- FOR j := top TO bottom-1 DO
- IF x[i] > x[i+1] THEN (* flip *)
- rtemp := x[i];
- x[i] := x[i+1];
- x[i+1] := rtemp;
- lastflip := i;
- END;
- i := i - 1;
- END;
-
- top := lastflip + 1;
-
- ELSE
- (* force a loop failure *)
- top := bottom + 1;
- END;
-
- END;
-
- END RealBSort;
-
-
- (* ----------------------------------------------------- *)
- PROCEDURE TopoSort( x, y :ARRAY OF CARDINAL; n_pairs :CARDINAL;
- VAR solution :ARRAY OF CARDINAL; VAR n_solution :CARDINAL;
- VAR error, sorted :BOOLEAN );
- (*
- This procedure needs some garbage collection added, i've tried but
- will little success. J. Andrea, Dec.18/91
- *)
-
- TYPE
- LPtr = POINTER TO Leader;
- TPtr = POINTER TO Trailer;
-
- Leader = RECORD
- key :CARDINAL;
- count :INTEGER;
- trail :TPtr;
- next :LPtr;
- END;
-
- Trailer = RECORD
- id :LPtr;
- next :TPtr;
- END;
-
- VAR
- p, q, head, tail :LPtr;
- t :TPtr;
- i, max_solutions :CARDINAL;
-
- (* -------------------------------------------- *)
- PROCEDURE Find( w :CARDINAL ) :LPtr;
- VAR h :LPtr;
- BEGIN
- h := head; tail^.key := w; (* sentinel *)
- WHILE h^.key # w DO
- h := h^.next;
- END;
- IF h = tail THEN
- NEW( tail );
- n := n + 1;
- h^.count := 0;
- h^.trail := NIL;
- h^.next := tail;
- END;
- RETURN h;
- END Find;
-
- BEGIN
-
- error := FALSE;
- n_solution := 0;
-
- IF n_pairs < 2 THEN
- error := TRUE;
- ELSE
-
- max_solutions := HIGH( solution ) + 1;
-
- NEW( head ); tail := head; n := 0;
-
- (* add all of the given pairs *)
-
- FOR i := 0 TO n_pairs - 1 DO
- p := Find( x[i] ); q := Find( y[i] );
- NEW(t);
- t^.id := q;
- t^.next := p^.trail;
- p^.trail := t;
- q^.count := q^.count + 1;
- END;
-
- (* search for leaders without predecessors *)
-
- p := head; head := NIL;
- WHILE p # tail DO
- q := p; p := q^.next;
- IF q^.count = 0 THEN
- (* insert q^ in new chain *)
- q^.next := head; head := q;
- END;
- END;
-
- (* output phase *)
-
- q := head;
- WHILE ( NOT error ) & ( q # NIL ) DO
- n_solution := n_solution + 1;
- IF n_solution > max_solutions THEN
- error := TRUE;
- ELSE
-
- solution[n_solution-1] := q^.key;
- n := n - 1;
- t := q^.trail; q := q^.next;
- WHILE t # NIL DO
- p := t^.id; p^.count := p^.count - 1;
- IF p^.count = 0 THEN
- (* insert p^ in leader list *)
- p^.next := q; q := p;
- END;
- t := t^.next;
- END;
- END;
- END;
-
- IF n # 0 THEN
- sorted := FALSE;
- ELSE
- sorted := TRUE;
- END;
-
- END;
-
- END TopoSort;
-
-BEGIN
-END Sorting.
View Lorry Controller Status