Sign in Join
Wiki copytemporary

Smoothsort/fr: what changed

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

Title: Smoothsort/fr

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