--- /dev/null
+DEFINITION MODULE ArraySort;
+(*
+ Module: Array sorting module
+ Author: Ceriel J.H. Jacobs
+ Date: $Header$
+
+ Interface is like the qsort() interface in C, so that an array of values
+ can be sorted. This does not mean that it has to be an ARRAY, but it does
+ mean that the values must be consecutive in memory, and the order is the
+ "memory" order.
+ The user has to define a comparison procedure of type CompareProc.
+ This routine gets two pointers as parameters. These are pointers to the
+ opbjects that must be compared. The sorting takes place in ascending order,
+ so that f.i. if the result of the comparison is "less", the first argument
+ comes in front of the second.
+*)
+ FROM SYSTEM IMPORT ADDRESS; (* no generics in Modula-2, sorry *)
+
+ TYPE CompareResult = (less, equal, greater);
+ CompareProc = PROCEDURE(ADDRESS, ADDRESS): CompareResult;
+
+ 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 *)
+END ArraySort.
--- /dev/null
+(*$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);
+ 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.
+
public / ack.git / commitdiff