lib/ack/libm2/ArraySort.mod

   1 (*
   2   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3   See the copyright notice in the ACK home directory, in the file "Copyright".
   4 *)
   5
   6 (*$R-*)
   7 IMPLEMENTATION MODULE ArraySort;
   8 (*
   9   Module:       Array sorting module.
  10   Author:       Ceriel J.H. Jacobs
  11   Version:      $Header$
  12 *)
  13   FROM  SYSTEM IMPORT   ADDRESS, BYTE;  (* no generics in Modula-2, sorry *)
  14
  15   TYPE BytePtr = POINTER TO BYTE;
  16
  17   VAR compareproc: CompareProc;
  18
  19   PROCEDURE Sort(base: ADDRESS;         (* address of array *)
  20                  nel: CARDINAL;         (* number of elements in array *)
  21                  size: CARDINAL;        (* size of each element *)
  22                  compar: CompareProc);  (* the comparison procedure *)
  23   BEGIN
  24         compareproc := compar;
  25         qsort(base, base+(nel-1)*size, size);
  26   END Sort;
  27
  28   PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
  29   (* Implemented with quick-sort, with some extra's *)
  30     VAR left, right, lefteq, righteq: ADDRESS;
  31         cmp: CompareResult;
  32         mainloop: BOOLEAN;
  33   BEGIN
  34         WHILE a2 > a1 DO
  35                 left := a1;
  36                 right := a2;
  37                 lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
  38                 righteq := lefteq;
  39                 (*
  40                    Pick an element in the middle of the array.
  41                    We will collect the equals around it.
  42                    "lefteq" and "righteq" indicate the left and right
  43                    bounds of the equals respectively.
  44                    Smaller elements end up left of it, larger elements end
  45                    up right of it.
  46                 *)
  47                 LOOP
  48                         LOOP
  49                                 IF left >= lefteq THEN EXIT END;
  50                                 cmp := compareproc(left, lefteq);
  51                                 IF cmp = greater THEN EXIT END;
  52                                 IF cmp = less THEN
  53                                         left := left + size;
  54                                 ELSE
  55                                         (* equal, so exchange with the element
  56                                            to the left of the "equal"-interval.
  57                                         *)
  58                                         lefteq := lefteq - size;
  59                                         exchange(left, lefteq, size);
  60                                 END;
  61                         END;
  62                         mainloop := FALSE;
  63                         LOOP
  64                                 IF right <= righteq THEN EXIT END;
  65                                 cmp := compareproc(right, righteq);
  66                                 IF cmp = less THEN
  67                                         IF left < lefteq THEN
  68                                                 (* larger one at the left,
  69                                                    so exchange
  70                                                 *)
  71                                                 exchange(left,right,size);
  72                                                 left := left + size;
  73                                                 right := right - size;
  74                                                 mainloop := TRUE;
  75                                                 EXIT;
  76                                         END;
  77                                 (*
  78                                    no more room at the left part, so we
  79                                    move the "equal-interval" one place to the
  80                                    right, and the smaller element to the
  81                                    left of it.
  82                                    This is best expressed as a three-way
  83                                    exchange.
  84                                 *)
  85                                         righteq := righteq + size;
  86                                         threewayexchange(left, righteq, right,
  87                                                 size);
  88                                         lefteq := lefteq + size;
  89                                         left := lefteq;
  90                                 ELSIF cmp = equal THEN
  91                                         (* equal, zo exchange with the element
  92                                            to the right of the "equal"
  93                                            interval
  94                                         *)
  95                                         righteq := righteq + size;
  96                                         exchange(right, righteq, size);
  97                                 ELSE
  98                                         (* leave it where it is *)
  99                                         right := right - size;
 100                                 END;
 101                         END;
 102                         IF (NOT mainloop) THEN
 103                                 IF left >= lefteq THEN
 104                                         (* sort "smaller" part *)
 105                                         qsort(a1, lefteq - size, size);
 106                                         (* and now the "larger" part, saving a
 107                                            procedure call, because of this big
 108                                            WHILE loop
 109                                         *)
 110                                         a1 := righteq + size;
 111                                         EXIT;   (* from the LOOP *)
 112                                 END;
 113                                 (* larger element to the left, but no more room,
 114                                    so move the "equal-interval" one place to the
 115                                    left, and the larger element to the right
 116                                    of it.
 117                                 *)
 118                                 lefteq := lefteq - size;
 119                                 threewayexchange(right, lefteq, left, size);
 120                                 righteq := righteq - size;
 121                                 right := righteq;
 122                         END;
 123                 END;
 124         END;
 125   END qsort;
 126
 127   PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
 128     VAR c: BYTE;
 129   BEGIN
 130         WHILE size > 0 DO
 131                 DEC(size);
 132                 c := a^;
 133                 a^ := b^;
 134                 a := ADDRESS(a) + 1;
 135                 b^ := c;
 136                 b := ADDRESS(b) + 1;
 137         END;
 138   END exchange;
 139
 140   PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
 141     VAR c: BYTE;
 142   BEGIN
 143         WHILE size > 0 DO
 144                 DEC(size);
 145                 c := p^;
 146                 p^ := r^;
 147                 p := ADDRESS(p) + 1;
 148                 r^ := q^;
 149                 r := ADDRESS(r) + 1;
 150                 q^ := c;
 151                 q := ADDRESS(q) + 1;
 152         END;
 153   END threewayexchange;
 154
 155 END ArraySort.