Sign in Join
Wiki copytemporary

Array sort: what changed

Revision 0 to 1. Removed lines have a minus sign; added lines have a plus sign.

Title: Array sort

OldNewLine
1+A typical task is to sort an array. One of the problems is that an array could be of any type. Not a simple type, but more complicated types.
2+
3+## Basic Version
4+
5+Prior to introducing [[Generics]] into Freepascal, sorting an array of arbitrary type could be achieve via untyped variables (implicit [[Pointers]]).
6+
7+- No generics involved
8+- works on any version of FPC (or Delphi)
9+- any array data type
10+
11+### Source Code
12+
13+```delphi
14+unit anysort;
15+
16+{$ifdef fpc}{$mode delphi}{$H+}{$endif}
17+
18+interface
19+
20+type
21+ TCompareFunc = function (const elem1, elem2): Integer;
22+
23+procedure AnySort(var Arr; Count: Integer; Stride: Integer; CompareFunc: TCompareFunc);
24+
25+implementation
26+
27+type
28+ TByteArray = array [Word] of byte;
29+ PByteArray = ^TByteArray;
30+
31+procedure AnyQuickSort(var Arr; idxL, idxH: Integer;
32+ Stride: Integer; CompareFunc: TCompareFunc; var SwapBuf, MedBuf);
33+var
34+ ls,hs : Integer;
35+ li,hi : Integer;
36+ mi : Integer;
37+ ms : Integer;
38+ pb : PByteArray;
39+begin
40+ pb:=@Arr;
41+ li:=idxL;
42+ hi:=idxH;
43+ mi:=(li+hi) div 2;
44+ ls:=li*Stride;
45+ hs:=hi*Stride;
46+ ms:=mi*Stride;
47+ Move(pb[ms], medBuf, Stride);
48+ repeat
49+ while CompareFunc( pb[ls], medBuf) < 0 do begin
50+ inc(ls, Stride);
51+ inc(li);
52+ end;
53+ while CompareFunc( medBuf, pb[hs] ) < 0 do begin
54+ dec(hs, Stride);
55+ dec(hi);
56+ end;
57+ if ls <= hs then begin
58+ Move(pb[ls], SwapBuf, Stride);
59+ Move(pb[hs], pb[ls], Stride);
60+ Move(SwapBuf, pb[hs], Stride);
61+ // begin fix 11/11/2021: update ms if the reference point is moved
62+ if li=mi then ms:=hs;
63+ if hi=mi then ms:=ls;
64+ // end fix
65+ inc(ls, Stride); inc(li);
66+ dec(hs, Stride); dec(hi);
67+ end;
68+ until ls>hs;
69+ if hi>idxL then AnyQuickSort(Arr, idxL, hi, Stride, CompareFunc, SwapBuf, MedBuf);
70+ if li<idxH then AnyQuickSort(Arr, li, idxH, Stride, CompareFunc, SwapBuf, MedBuf);
71+end;
72+
73+procedure AnySort(var Arr; Count: Integer; Stride: Integer; CompareFunc: TCompareFunc);
74+var
75+ buf: array of byte;
76+begin
77+ if Count <= 1 then Exit; // should be more than 1 to be sortable
78+ SetLength(buf, Stride*2);
79+ AnyQuickSort(Arr, 0, Count-1, Stride, compareFunc, buf[0], buf[Stride]);
80+end;
81+
82+end.
83+```
84+
85+### Use Sample
86+
87+Here's an example on how to use AnySort() function to sort an array of Integer
88+
89+```delphi
90+interface
91+
92+uses AnySort;
93+
94+procedure SortArrayInteger(var arr: array of Integer; count: Integer);
95+
96+implementation
97+
98+function CompareInt(const d1,d2): integer;
99+var
100+ i1 : integer absolute d1;
101+ i2 : integer absolute d2;
102+begin
103+ if i1=i2 then Result:=0
104+ else if i1<i2 then Result:=-1
105+ else Result:=1;
106+end;
107+
108+procedure SortArrayInteger(var arr: array of Integer; count: Integer);
109+begin
110+ anysort.AnySort(arr, Count, sizeof(Integer), @CompareInt);
111+end;
112+```
113+
114+## Generics Version
115+
116+- FPC-only.
117+- Uses **generic** with static comparer.
118+- Comparer is a simple *less* predicate.
119+- Essentially an Introsort, a QuickSort that falls back to a simple algorithm for small enough subarrays.
120+- Bypasses managed types handling to greatly speed up sorting arrays of reference-counted types; won't work with custom Copy/AddRef operators.
121+- Protected against
122+ - O(N²) time (falls back to heap sort);
123+ - O(N) recursion depth; maximum recursion depth is ⌈bitsizeof(SizeUint) - log₂ SelectionThreshold⌉.
124+
125+### Source Code
126+
127+```delphi
128+{$mode objfpc} {$coperators on}
129+unit AnySort2;
130+
131+interface
132+
133+type
134+ // Comparer should provide function Less(const a, b: Elem): boolean.
135+ generic Sorter<Elem, Comparer> = class
136+ type
137+ pElem = ^Elem;
138+
139+ class procedure Sort(p: pElem; count: SizeUint); static;
140+ class procedure Sort(var a: array of Elem); static;
141+
142+ private const
143+ SelectionThreshold = 12;
144+ HeapArity = 4;
145+ type
146+ SwapTemp = array[0 .. sizeof(Elem) - 1] of byte;
147+
148+ class procedure SelectionSort(p: pElem; count: SizeUint); static;
149+
150+ class function Median(p: pElem; count: SizeUint): pElem; static;
151+ class procedure QSort(p: pElem; count, reasonable: SizeUint); static;
152+
153+ class procedure HeapReplacePessimistic(p: pElem; count, id: SizeUint; const x: SwapTemp); static;
154+ class procedure HeapSort(p: pElem; count: SizeUint); static;
155+ end;
156+
157+ generic ComparerLessOp<Elem> = class
158+ class function Less(const a, b: Elem): boolean; static; inline;
159+ end;
160+
161+ generic SorterLessOp<Elem> = class(specialize Sorter<Elem, specialize ComparerLessOp<Elem>>) end;
162+
163+implementation
164+
165+ class procedure Sorter.Sort(p: pElem; count: SizeUint);
166+ begin
167+ QSort(p, count, count);
168+ end;
169+
170+ class procedure Sorter.Sort(var a: array of Elem);
171+ begin
172+ Sort(pElem(a), length(a));
173+ end;
174+
175+ class procedure Sorter.SelectionSort(p: pElem; count: SizeUint);
176+ var
177+ i, j, imin: SizeInt;
178+ t: SwapTemp;
179+ begin
180+ for i := 0 to SizeInt(count) - 2 do
181+ begin
182+ imin := i;
183+ for j := i + 1 to SizeInt(count) - 1 do
184+ if Comparer.Less(p[j], p[imin]) then imin := j;
185+ t := SwapTemp(p[i]); SwapTemp(p[i]) := SwapTemp(p[imin]); SwapTemp(p[imin]) := t;
186+ end;
187+ end;
188+
189+ class function Sorter.Median(p: pElem; count: SizeUint): pElem;
190+ var
191+ a, b, c, t: pElem;
192+ begin
193+ a := p;
194+ b := p + count div 2;
195+ c := p + SizeUint(count - 1);
196+ if Comparer.Less(b^, a^) then begin t := a; a := b; b := t; end;
197+ if Comparer.Less(c^, b^) then begin t := c; c := b; b := t; end;
198+ if Comparer.Less(b^, a^) then result := a else result := b;
199+ end;
200+
201+ // see MSVC implementation of std::sort
202+ class procedure Sorter.QSort(p: pElem; count, reasonable: SizeUint);
203+ var
204+ L, R: SizeInt;
205+ t, pivot: SwapTemp;
206+ begin
207+ while (count > SelectionThreshold) and (reasonable > 0) do
208+ begin
209+ reasonable := reasonable div 2 + reasonable div 4;
210+
211+ pivot := SwapTemp(Median(p, count)^);
212+ R := 0;
213+ L := count - 1;
214+
215+ repeat
216+ while Comparer.Less(p[R], Elem(pivot)) do inc(R);
217+ while Comparer.Less(Elem(pivot), p[L]) do dec(L);
218+ if R <= L then
219+ begin
220+ t := SwapTemp(p[R]); SwapTemp(p[R]) := SwapTemp(p[L]); SwapTemp(p[L]) := t;
221+ inc(R);
222+ dec(L);
223+ end;
224+ until R > L;
225+
226+ // [0 .. L], [R .. count - 1]
227+ // possible edge cases are L = -1 or R = count !
228+ if SizeInt(count) - R <= L then
229+ begin
230+ QSort(p + R, SizeInt(count) - R, reasonable); // QSort calls with count = 0 or count = 1 are safe.
231+ count := L + 1;
232+ end else
233+ begin
234+ QSort(p, L + 1, reasonable);
235+ p += R;
236+ count -= R;
237+ end;
238+ end;
239+ if count > SelectionThreshold then
240+ HeapSort(p, count)
241+ else if count >= 2 then
242+ SelectionSort(p, count);
243+ end;
244+
245+ // HeapReplacePessimistic(p, count, id, x)
246+ //
247+ // is equivalent to
248+ //
249+ // p[id] := x;
250+ // id := HeapDownThoroughly(..., id);
251+ // HeapUp(..., id)
252+ //
253+ // where HeapDownThoroughly doesn't stop at correct position, instead shifting the element all the way down, saving one compare at each level.
254+ // HeapUp then bubbles the element up to the correct position.
255+ // See Python's 'heapq' for justification over simple HeapDown.
256+ //
257+ // Careful with 'x' passed by reference and pointing into 'p'!
258+
259+ class procedure Sorter.HeapReplacePessimistic(p: pElem; count, id: SizeUint; const x: SwapTemp);
260+ var
261+ child, bestChild, lastChild, parent, start: SizeUint;
262+ begin
263+ start := id;
264+ repeat
265+ child := HeapArity * id; // childs of 'id' are p[child + 1] ... p[child + HeapArity].
266+ bestChild := child + 1;
267+ if bestChild >= count then break;
268+
269+ lastChild := child + HeapArity;
270+ if lastChild >= count then lastChild := count - 1;
271+
272+ for child := child + 2 to lastChild do
273+ if Comparer.Less(p[bestChild], p[child]) then bestChild := child;
274+
275+ SwapTemp(p[id]) := SwapTemp(p[bestChild]);
276+ id := bestChild;
277+ until false;
278+
279+ while id > start do
280+ begin
281+ parent := (id - 1) div HeapArity;
282+ if not Comparer.Less(p[parent], Elem(x)) then break;
283+ SwapTemp(p[id]) := SwapTemp(p[parent]);
284+ id := parent;
285+ end;
286+ SwapTemp(p[id]) := x;
287+ end;
288+
289+ class procedure Sorter.HeapSort(p: pElem; count: SizeUint);
290+ var
291+ i: SizeInt;
292+ t: SwapTemp;
293+ begin
294+ for i := SizeInt((count + (HeapArity - 2)) div HeapArity) - 1 downto 0 do
295+ begin
296+ t := SwapTemp(p[i]);
297+ HeapReplacePessimistic(p, count, i, t);
298+ end;
299+ for i := SizeInt(count) - 1 downto 1 do
300+ begin
301+ t := SwapTemp(p[i]);
302+ SwapTemp(p[i]) := SwapTemp(p[0]);
303+ HeapReplacePessimistic(p, i, 0, t);
304+ end;
305+ end;
306+
307+ class function ComparerLessOp.Less(const a, b: Elem): boolean;
308+ begin
309+ result := a < b;
310+ end;
311+
312+end.
313+```
314+
315+### Use Sample
316+
317+Usage:
318+
319+```delphi
320+{$mode objfpc}
321+uses AnySort2;
322+
323+var
324+ a: array of integer;
325+
326+begin
327+ a := specialize TArray<integer>.Create(111, 555, 888, 777, 333, 444, 666);
328+ specialize SorterLessOp<integer>.Sort(a);
329+end.
330+```
331+
332+---
333+*From the Free Pascal wiki, page "Array sort", as it stood on 2022-07-23 after a change by Runewalsh, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*
334+Category: Sort

Back to history