156 lines
4.2 KiB
Modula-2
Executable file
156 lines
4.2 KiB
Modula-2
Executable file
(*
|
|
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
|
|
See the copyright notice in the ACK home directory, in the file "Copyright".
|
|
*)
|
|
|
|
(*$R-*)
|
|
IMPLEMENTATION MODULE ArraySort;
|
|
(*
|
|
Module: Array sorting module.
|
|
Author: Ceriel J.H. Jacobs
|
|
Version: $Header$
|
|
*)
|
|
FROM SYSTEM IMPORT ADDRESS, BYTE; (* no generics in Modula-2, sorry *)
|
|
|
|
TYPE BytePtr = POINTER TO BYTE;
|
|
|
|
VAR compareproc: CompareProc;
|
|
|
|
PROCEDURE Sort(base: ADDRESS; (* address of array *)
|
|
nel: CARDINAL; (* number of elements in array *)
|
|
size: CARDINAL; (* size of each element *)
|
|
compar: CompareProc); (* the comparison procedure *)
|
|
BEGIN
|
|
compareproc := compar;
|
|
qsort(base, base+(nel-1)*size, size);
|
|
END Sort;
|
|
|
|
PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
|
|
(* Implemented with quick-sort, with some extra's *)
|
|
VAR left, right, lefteq, righteq: ADDRESS;
|
|
cmp: CompareResult;
|
|
mainloop: BOOLEAN;
|
|
BEGIN
|
|
WHILE a2 > a1 DO
|
|
left := a1;
|
|
right := a2;
|
|
lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
|
|
righteq := lefteq;
|
|
(*
|
|
Pick an element in the middle of the array.
|
|
We will collect the equals around it.
|
|
"lefteq" and "righteq" indicate the left and right
|
|
bounds of the equals respectively.
|
|
Smaller elements end up left of it, larger elements end
|
|
up right of it.
|
|
*)
|
|
LOOP
|
|
LOOP
|
|
IF left >= lefteq THEN EXIT END;
|
|
cmp := compareproc(left, lefteq);
|
|
IF cmp = greater THEN EXIT END;
|
|
IF cmp = less THEN
|
|
left := left + size;
|
|
ELSE
|
|
(* equal, so exchange with the element
|
|
to the left of the "equal"-interval.
|
|
*)
|
|
lefteq := lefteq - size;
|
|
exchange(left, lefteq, size);
|
|
END;
|
|
END;
|
|
mainloop := FALSE;
|
|
LOOP
|
|
IF right <= righteq THEN EXIT END;
|
|
cmp := compareproc(right, righteq);
|
|
IF cmp = less THEN
|
|
IF left < lefteq THEN
|
|
(* larger one at the left,
|
|
so exchange
|
|
*)
|
|
exchange(left,right,size);
|
|
left := left + size;
|
|
right := right - size;
|
|
mainloop := TRUE;
|
|
EXIT;
|
|
END;
|
|
(*
|
|
no more room at the left part, so we
|
|
move the "equal-interval" one place to the
|
|
right, and the smaller element to the
|
|
left of it.
|
|
This is best expressed as a three-way
|
|
exchange.
|
|
*)
|
|
righteq := righteq + size;
|
|
threewayexchange(left, righteq, right,
|
|
size);
|
|
lefteq := lefteq + size;
|
|
left := lefteq;
|
|
ELSIF cmp = equal THEN
|
|
(* equal, zo exchange with the element
|
|
to the right of the "equal"
|
|
interval
|
|
*)
|
|
righteq := righteq + size;
|
|
exchange(right, righteq, size);
|
|
ELSE
|
|
(* leave it where it is *)
|
|
right := right - size;
|
|
END;
|
|
END;
|
|
IF (NOT mainloop) THEN
|
|
IF left >= lefteq THEN
|
|
(* sort "smaller" part *)
|
|
qsort(a1, lefteq - size, size);
|
|
(* and now the "larger" part, saving a
|
|
procedure call, because of this big
|
|
WHILE loop
|
|
*)
|
|
a1 := righteq + size;
|
|
EXIT; (* from the LOOP *)
|
|
END;
|
|
(* larger element to the left, but no more room,
|
|
so move the "equal-interval" one place to the
|
|
left, and the larger element to the right
|
|
of it.
|
|
*)
|
|
lefteq := lefteq - size;
|
|
threewayexchange(right, lefteq, left, size);
|
|
righteq := righteq - size;
|
|
right := righteq;
|
|
END;
|
|
END;
|
|
END;
|
|
END qsort;
|
|
|
|
PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
|
|
VAR c: BYTE;
|
|
BEGIN
|
|
WHILE size > 0 DO
|
|
DEC(size);
|
|
c := a^;
|
|
a^ := b^;
|
|
a := ADDRESS(a) + 1;
|
|
b^ := c;
|
|
b := ADDRESS(b) + 1;
|
|
END;
|
|
END exchange;
|
|
|
|
PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
|
|
VAR c: BYTE;
|
|
BEGIN
|
|
WHILE size > 0 DO
|
|
DEC(size);
|
|
c := p^;
|
|
p^ := r^;
|
|
p := ADDRESS(p) + 1;
|
|
r^ := q^;
|
|
r := ADDRESS(r) + 1;
|
|
q^ := c;
|
|
q := ADDRESS(q) + 1;
|
|
END;
|
|
END threewayexchange;
|
|
|
|
END ArraySort.
|