Sign in Join
Wiki copytemporary

Smoothsort: what changed

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

Title: Smoothsort

OldNewLine
1+Smoothsort is a comparison-based [[sorting algorithm]].
2+
3+## unit USmoothsortExtra.pas
4+
5+``` pascal
6+
7+unit USmoothsortExtra;
8+
9+{$mode objfpc}{$H+}
10+
11+interface
12+
13+type
14+ // data type
15+ TItemSmoothsort = integer;
16+
17+// comparison function
18+function IsAscendingSmoothsort(v1, v2: TItemSmoothsort): boolean;
19+
20+implementation
21+
22+// customizable comparison function
23+function IsAscendingSmoothsort(v1, v2: TItemSmoothsort): boolean; inline;
24+begin
25+ result := v1 <= v2;
26+end;
27+
28+end.
29+```
30+
31+## unit USmoothsort.pas
32+
33+``` pascal
34+
35+unit USmoothsort;
36+
37+interface
38+uses USmoothsortExtra;
39+
40+// sorting function
41+procedure Smoothsort(var A: array of TItemSmoothsort);
42+
43+implementation
44+
45+// implementation of Djikstra's algorithm
46+procedure Smoothsort(var A: array of TItemSmoothsort);
47+var
48+ q, r,
49+ p, b, c,
50+ r1, b1, c1,
51+ N: integer;
52+
53+ procedure up(var vb, vc: integer);
54+ var
55+ temp: integer;
56+ begin
57+ temp := vb;
58+ vb := vb + vc + 1;
59+ vc := temp;
60+ end;
61+
62+ procedure down(var vb, vc: integer);
63+ var
64+ temp: integer;
65+ begin
66+ temp := vc;
67+ vc := vb - vc - 1;
68+ vb := temp;
69+ end;
70+
71+ procedure sift;
72+ var
73+ r0, r2: integer;
74+ T: TItemSmoothsort;
75+ begin
76+ r0 := r1;
77+ T := A[r0];
78+ while b1 >= 3 do
79+ begin
80+ r2 := r1 - b1 + c1;
81+ if not IsAscendingSmoothsort(A[r1 - 1], A[r2]) then
82+ begin
83+ r2 := r1 - 1;
84+ down(b1, c1);
85+ end;
86+ if IsAscendingSmoothsort(A[r2], T) then b1 := 1
87+ else
88+ begin
89+ A[r1] := A[r2];
90+ r1 := r2;
91+ down(b1, c1);
92+ end;
93+ end; // of while b1 >= 3
94+ if r1 <> r0 then A[r1] := T;
95+ end;
96+
97+ procedure trinkle;
98+ var
99+ p1, r2, r3, r0 : integer;
100+ T: TItemSmoothsort;
101+ begin
102+ p1 := p;
103+ b1 := b;
104+ c1 := c;
105+ r0 := r1;
106+ T := A[r0];
107+ while p1 > 0 do
108+ begin
109+ while (p1 and 1) = 0 do
110+ begin
111+ p1 := p1 shr 1;
112+ up(b1, c1);
113+ end; // of while (p1 and 1) = 0
114+ r3 := r1 - b1;
115+ if (p1 = 1) or IsAscendingSmoothsort(A[r3], T) then p1 := 0
116+ else // p1>1
117+ begin
118+ p1 := p1 - 1;
119+ if b1 = 1 then
120+ begin
121+ A[r1] := A[r3];
122+ r1 := r3;
123+ end
124+ else
125+ if b1 >= 3 then
126+ begin
127+ r2 := r1 - b1 + c1;
128+ if not IsAscendingSmoothsort(A[r1 - 1], A[r2]) then
129+ begin
130+ r2 := r1 - 1;
131+ down(b1, c1);
132+ p1 := p1 shl 1;
133+ end;
134+ if IsAscendingSmoothsort(A[r2], A[r3]) then
135+ begin
136+ A[r1] := A[r3];
137+ r1 := r3;
138+ end
139+ else
140+ begin
141+ A[r1] := A[r2];
142+ r1 := r2;
143+ down(b1, c1);
144+ p1 := 0;
145+ end;
146+ end; // of if b1 >= 3
147+ end; // of else p1 > 1
148+ end; // of while p1 > 0
149+ if r0 <> r1 then A[r1] := T;
150+ sift;
151+ end;
152+
153+ procedure semitrinkle;
154+ var
155+ T: TItemSmoothsort;
156+ begin
157+ r1 := r - c;
158+ if not IsAscendingSmoothsort(A[r1], A[r]) then
159+ begin
160+ T := A[r];
161+ A[r] := A[r1];
162+ A[r1] := T;
163+ trinkle;
164+ end;
165+ end;
166+
167+begin
168+ N := length(A);
169+ q := 1;
170+ r := 0;
171+ p := 1;
172+ b := 1;
173+ c := 1;
174+
175+ //building tree
176+ while q < N do
177+ begin
178+ r1 := r;
179+ if (p and 7) = 3 then
180+ begin
181+ b1 := b;
182+ c1 := c;
183+ sift;
184+ p := ( p + 1 ) shr 2;
185+ up(b, c);
186+ up(b, c);
187+ end
188+ else
189+ if (p and 3) = 1 then
190+ begin
191+ if q + c < N then
192+ begin
193+ b1 := b;
194+ c1 := c;
195+ sift;
196+ end
197+ else trinkle;
198+ down(b, c);
199+ p := p shl 1;
200+ while b > 1 do
201+ begin
202+ down(b, c);
203+ p := p shl 1;
204+ end; // of while b > 1
205+ p := p + 1;
206+ end; // of if (p and 3) = 1
207+ q := q + 1;
208+ r := r + 1;
209+ end;
210+ r1 := r;
211+ trinkle;
212+
213+ //bulding sorted array
214+ while q > 1 do
215+ begin
216+ q := q - 1;
217+ if b = 1 then
218+ begin
219+ r := r - 1;
220+ p := p - 1;
221+ while (p and 1) = 0 do
222+ begin
223+ p := p shr 1;
224+ up(b, c);
225+ end; // of while (p and 1) = 0
226+ end
227+ else
228+ if b >= 3 then
229+ begin
230+ p := p - 1;
231+ r := r - b + c;
232+ if p > 0 then semitrinkle;
233+ down(b, c);
234+ p := p shl 1 + 1;
235+ r := r + c;
236+ semitrinkle;
237+ down(b, c);
238+ p := p shl 1 + 1;
239+ end; // of if b >= 3
240+ //element q is done
241+ end;
242+ //element 0 is done
243+end;
244+
245+end.
246+```
247+
248+## Example of the use
249+
250+``` pascal
251+
252+uses
253+ USmoothsort
254+
255+ ...
256+
257+var
258+
259+ a: array[0..100] of integer;
260+
261+begin
262+
263+ ...
264+
265+ Smoothsort( a );
266+```
267+
268+---
269+*From the Free Pascal wiki, page "Smoothsort", as it stood on 2019-07-07 after a change by Djzepi, 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).*

Back to history