ArraySort.mod 4.2 KB

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