« back to all changes in this revision
Viewing changes to gal-sorting.adb
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Ludovic Brenta
- Date: 2004-02-14 13:22:40 UTC
- Revision ID: james.westby@ubuntu.com-20040214132240-cqumhiq1677pkvzo
Tags: upstream-4.0.2
Import upstream version 4.0.2
- files added:
- config
- doc
- simple_test
- xml
added
removed
gal-sorting.adb
1
-------------------------------------------------------------------------------
2
--
3
-- <STRONG>Copyright (c) 1999 - 2002 by Thomas Wolf.</STRONG>
4
-- <BLOCKQUOTE>
5
-- AdaBrowse is free software; you can redistribute it and/or modify it
6
-- under the terms of the GNU General Public License as published by the
7
-- Free Software Foundation; either version 2, or (at your option) any
8
-- later version. AdaBrowse is distributed in the hope that it will be
9
-- useful, but <EM>without any warranty</EM>; without even the implied
10
-- warranty of <EM>merchantability or fitness for a particular purpose.</EM>
11
-- See the GNU General Public License for more details. You should have
12
-- received a copy of the GNU General Public License with this distribution,
13
-- see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
14
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
15
-- USA.
16
-- </BLOCKQUOTE>
17
-- <BLOCKQUOTE>
18
-- As a special exception from the GPL, if other files instantiate generics
19
-- from this unit, or you link this unit with other files to produce an
20
-- executable, this unit does not by itself cause the resulting executable
21
-- to be covered by the GPL. This exception does not however invalidate any
22
-- other reasons why the executable file might be covered by the GPL.
23
-- </BLOCKQUOTE>
24
--
25
-- <DL><DT><STRONG>
26
-- Author:</STRONG><DD>
27
-- Thomas Wolf (TW)
28
-- <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
29
--
30
-- <DL><DT><STRONG>
31
-- Purpose:</STRONG><DD>
32
-- Speed and space optimized quicksort. Actually, an <EM>introspective
33
-- quicksort</EM> with a <STRONG>worst-case</STRONG> runtime complexity of
34
-- <CODE>O (N * log2 (N))</CODE>.</DL>
35
--
36
-- <DL><DT><STRONG>
37
-- Literature:</STRONG><DD>
38
-- Musser, D.R.: "Introspective Sorting and Selection Algorithms",
39
-- <EM>Software -- Practice & Experience (8):983-993</EM>; 1997.</DL>
40
--
41
-- <DL><DT><STRONG>
42
-- Tasking semantics:</STRONG><DD>
43
-- N/A. Not abortion-safe.</DL>
44
--
45
-- <DL><DT><STRONG>
46
-- Storage semantics:</STRONG><DD>
47
-- No dynamic storage allocation. Stack space used is
48
-- <CODE>O (log2 (N))</CODE>.</DL>
49
--
50
-- <--
51
-- Revision History
52
--
53
-- 21-JAN-1999 TW Initial version
54
-- 26-JAN-1999 TW Some minor fine-tuning.
55
-- -->
56
-------------------------------------------------------------------------------
57
58
pragma License (Modified_GPL);
59
60
with Ada.Numerics.Elementary_Functions;
61
62
package body GAL.Sorting is
63
64
Cut_Off : constant := 10;
65
-- Empirically determined constant. For smaller arrays, it's actually
66
-- faster to use a simple insertion sort.
67
68
function Max_Depth
69
(Nof_Elements : in Natural)
70
return Natural
71
is
72
-- Compute the recursion depth bound at which we'll switch to using
73
-- Heapsort instead of proceeding further down with Quicksort.
74
use Ada.Numerics.Elementary_Functions;
75
-- This seems to give us the fastest logarithm around...
76
begin
77
return 2 * Natural (Log (Float (Nof_Elements), 2.0));
78
-- This is Musser's suggestion, which seems to work well in practice.
79
-- Note: it should not be too low, or we'll switch to using
80
-- Heapsort prematurely. Since Heapsort is slower than Quicksort
81
-- on the average (its constant factor in the O(N*log2(N)) is
82
-- larger), we might lose. If it's too high, we'll start using
83
-- Heapsort too late and hence we cannot ensure the O(N*log2(N))
84
-- upper bound.
85
end Max_Depth;
86
87
----------------------------------------------------------------------------
88
-- A sort with a classic interface:
89
90
-- generic
91
-- type Index_Type is (<>);
92
-- type Element_Type is private;
93
-- type Array_Type is array (Index_Type range <>) of Element_Type;
94
-- with function "<"
95
-- (Left, Right : in Element_Type) return Boolean is <>;
96
procedure Sort_G
97
(To_Sort : in out Array_Type)
98
is
99
-- Recursion depth is bounded by log2 (To_Sort'Length).
100
-- Worst-case runtime complexity is O(N*log2(N)), not O(N**2)!
101
-- Note: for sensible performance measures, compile with a typical
102
-- optimization level and all checks off (e.g. gcc -O3 -gnatp). For
103
-- correctness testing, switch on checks!
104
105
pragma Suppress (Overflow_Check);
106
pragma Suppress (Index_Check);
107
pragma Suppress (Range_Check);
108
-- For correctness testing, you should also comment out these pragmas!
109
110
Pivot, Temp : Element_Type;
111
-- We need exactly two temporary locations, one for Quicksort's pivot
112
-- element, and a second one for swapping elements and as a general
113
-- temporary during Insertion_Sort or Heap_Sort.
114
115
procedure Swap (Left, Right : in Index_Type);
116
pragma Inline (Swap); -- inline this for increased performance.
117
118
procedure Swap (Left, Right : in Index_Type)
119
is
120
begin
121
Temp := To_Sort (Left);
122
To_Sort (Left) := To_Sort (Right);
123
To_Sort (Right) := Temp;
124
end Swap;
125
126
-- For array slices with less than 'Cut_Off' elements, we use a simple
127
-- insertion sort: it's faster than quicksort.
128
129
procedure Insertion_Sort
130
(L, R : in Index_Type)
131
is
132
-- Precondition: L < R.
133
J : Index_Type;
134
begin -- Insertion_Sort
135
for I in Index_Type range Index_Type'Succ (L) .. R loop
136
Temp := To_Sort (I);
137
J := I;
138
while J > L and then Temp < To_Sort (Index_Type'Pred (J)) loop
139
To_Sort (J) := To_Sort (Index_Type'Pred (J));
140
J := Index_Type'Pred (J);
141
end loop;
142
To_Sort (J) := Temp;
143
end loop;
144
end Insertion_Sort;
145
146
-- If the (logical) recursion depth of quicksort gets too deep, we
147
-- assume that the input is one of the pathological cases causing
148
-- quadratic behavior of quicksort. At that moment, we switch to
149
-- heapsort to sort the sub-array. (This pays off because heap sort
150
-- has a worst-case runtime complexity of O(N*log2(N))).
151
152
procedure Heap_Sort
153
(Left, Right : in Index_Type)
154
is
155
-- Precondition: Left < Right
156
157
Offset : Integer;
158
-- Used for mapping the true index range to 1 .. N.
159
160
procedure Sift
161
(L, R : in Index_Type)
162
is
163
-- Normal heapsort algorithms always sort an array indexed by a
164
-- range 1 .. N. We have to juggle a bit to map this back to a
165
-- range L .. R, and to avoid overflow if R happens to be
166
-- Index_Type'Base'Last.
167
I : Index_Type := L;
168
C : Index_Type := L;
169
begin
170
Temp := To_Sort (L);
171
while (Index_Type'Pos (C) - Offset + 1) <=
172
(Index_Type'Pos (R) - Offset + 1) / 2
173
loop
174
C := Index_Type'Val
175
((Index_Type'Pos (I) - Offset + 1) * 2 - 1 + Offset);
176
-- We must add 'Offset - 1'. Make sure to subtract one first,
177
-- otherwise we might get an overflow if I = 'Last and
178
-- Offset = 'Last-1.
179
if
180
C < R and then To_Sort (C) < To_Sort (Index_Type'Succ (C))
181
then
182
C := Index_Type'Succ (C);
183
end if;
184
exit when not (Temp < To_Sort (C));
185
To_Sort (I) := To_Sort (C);
186
I := C;
187
end loop;
188
To_Sort (I) := Temp;
189
end Sift;
190
191
J : Index_Type;
192
193
begin -- Heap_Sort
194
-- Precondition: Left < Right
195
Offset := Index_Type'Pos (Left);
196
-- Set J to the middle:
197
J := Index_Type'Val
198
((Index_Type'Pos (Right) - Offset + 1) / 2 + Offset - 1);
199
-- Build the heap:
200
for I in reverse Index_Type range Left .. J loop
201
Sift (I, Right);
202
end loop;
203
-- And now extract elements and re-build the heap.
204
J := Right;
205
loop
206
-- Put the largest element (which is now in front) at the end and
207
-- replace it with the last element.
208
Swap (Left, J);
209
J := Index_Type'Pred (J);
210
exit when J = Left;
211
-- Rebuild the remaining heap (one element less).
212
Sift (Left, J);
213
end loop;
214
end Heap_Sort;
215
216
procedure Intro_Sort
217
(L, R : in Index_Type;
218
D : in Natural)
219
is
220
-- This is a quicksort with median-of-three pivot selection and
221
-- stack depth optimization: the tail recusion is resolved by
222
-- always sorting the larger sub-array iteratively instead of
223
-- recursing. This limits the physical recursion depth to log2(N)
224
-- and thus avoids stack overflows even for pathological huge inputs.
225
-- Actually, this is an introspective sort (see Musser's paper).
226
-- It switches to heapsort if the logical recursion depth becomes
227
-- too deep and thus avoids quicksort's usual worst-case quadratic
228
-- behavior.
229
230
Left : Index_Type := L;
231
Right : Index_Type := R;
232
-- L and R are in parameters, so copy.
233
Depth : Natural := D; -- Ditto for D.
234
I : Index_Type := Left;
235
J : Index_Type := Right;
236
Middle : Index_Type;
237
238
begin -- Intro_Sort
239
while Index_Type'Pos (Right) - Index_Type'Pos (Left) > Cut_Off loop
240
-- Only proceed until we have a small unsorted array fragment
241
-- left. This fragment will then be sorted with Insertion_Sort,
242
-- which is faster than quicksort for small arrays.
243
if Depth = 0 then Heap_Sort (Left, Right); return; end if;
244
-- If the (logical) recursion depth gets too deep, we switch
245
-- to heapsort, which has a worst-case run-time complexity of
246
-- O(N*log(N)). This gives Intro_Sort an overall worst-case
247
-- bound of O(N*log(N)), compared with the O(N**2) bound of
248
-- plain quicksort (even with median-of-three).
249
--
250
-- Don't use (Left + Right) / 2; it might overflow. Instead use
251
-- Left + (Right - Left) / 2, which is equivalent.
252
Middle :=
253
Index_Type'Val
254
(Index_Type'Pos (Left) +
255
(Index_Type'Pos (Right) - Index_Type'Pos (Left)) / 2);
256
-- Median-of-three:
257
if To_Sort (Middle) < To_Sort (Left) then
258
Swap (Middle, Left);
259
end if;
260
if To_Sort (Right) < To_Sort (Left) then
261
Swap (Right, Left);
262
end if;
263
if To_Sort (Right) < To_Sort (Middle) then
264
Swap (Right, Middle);
265
end if;
266
Pivot := To_Sort (Middle);
267
-- Here, I = Left and J = Right
268
while I < J loop
269
while To_Sort (I) < Pivot loop
270
I := Index_Type'Succ (I);
271
end loop;
272
while Pivot < To_Sort (J) loop
273
J := Index_Type'Pred (J);
274
end loop;
275
if I <= J then
276
if I < J then Swap (I, J); end if;
277
-- Now increment I and decrement J..., but beware of
278
-- boundary conditions!
279
if I < Index_Type'Last then
280
I := Index_Type'Succ (I);
281
end if;
282
if J > Index_Type'First then
283
J := Index_Type'Pred (J);
284
end if;
285
-- I and J saturate at the bounds of Index_Type... this
286
-- doesn't hurt, we'll quit the loop in this case, and
287
-- continue only (both recusively and iteratively) if
288
-- this didn't happen.
289
end if;
290
end loop;
291
-- Decrement the logical recursion depth. The next iteration will
292
-- hence be (correctly) seen like a true recursive call.
293
Depth := Depth - 1;
294
-- Now handle the shorter part recusively, and do the longer part
295
-- iteratively. This limits the (physical) recusion depth to
296
-- log2(N). Note: Musser advocates omitting this and just doing
297
-- one half recursively and the other one iteratively regardless
298
-- of their sizes, as the 'Depth' counter already puts an
299
-- O(log2(N)) bound on the maximum stack depth. The speed savings
300
-- are marginal, though, and I prefer a bound of log2(N) over one
301
-- of 2 * log2(N)...
302
if Index_Type'Pos (J) - Index_Type'Pos (Left) >
303
Index_Type'Pos (Right) - Index_Type'Pos (I)
304
then
305
-- Left part is longer. If I saturated, it is >= Right, and we
306
-- won't do the recursive call.
307
if I < Right then Intro_Sort (I, Right, Depth); end if;
308
-- Iteratively process To_Sort (Left .. J). Set up the indices:
309
I := Left; Right := J;
310
else
311
-- Right part is longer. If J saturated, it is <= Left, and we
312
-- won't do the recursive call.
313
if J > Left then Intro_Sort (Left, J, Depth); end if;
314
-- Iteratively process To_Sort (I .. Right). Set up the
315
-- indices:
316
J := Right; Left := I;
317
end if;
318
-- If either I or J saturated, Left >= Right now, and we'll
319
-- quit the outer loop.
320
end loop;
321
if Left < Right then Insertion_Sort (Left, Right); end if;
322
-- Note: an alternative is to simply return and run a single
323
-- insertion sort over the whole input at the very end. However,
324
-- in my tests this made sorting slower. Nevertheless it should be
325
-- pointed out that some people advocate this single post-sorting
326
-- insertion sort, notably Musser in his paper.
327
end Intro_Sort;
328
329
begin -- Sort_G
330
if To_Sort'Last > To_Sort'First then
331
Intro_Sort (To_Sort'First, To_Sort'Last,
332
Max_Depth (To_Sort'Length));
333
end if;
334
end Sort_G;
335
336
----------------------------------------------------------------------------
337
-- The same with an access parameter and range bounds.
338
339
-- generic
340
-- type Index_Type is (<>);
341
-- type Element_Type is private;
342
-- type Array_Type is array (Index_Type range <>) of Element_Type;
343
-- with function "<"
344
-- (Left, Right : in Element_Type) return Boolean is <>;
345
procedure Sort_Slice_G
346
(To_Sort : access Array_Type;
347
From, To : in Index_Type)
348
is
349
pragma Suppress (Overflow_Check);
350
pragma Suppress (Index_Check);
351
pragma Suppress (Range_Check);
352
353
Pivot, Temp : Element_Type;
354
355
procedure Swap
356
(Table : access Array_Type;
357
Left, Right : in Index_Type);
358
pragma Inline (Swap); -- inline this for increased performance.
359
360
procedure Swap
361
(Table : access Array_Type;
362
Left, Right : in Index_Type)
363
is
364
begin
365
Temp := Table (Left);
366
Table (Left) := Table (Right);
367
Table (Right) := Temp;
368
end Swap;
369
370
procedure Insertion_Sort
371
(To_Sort : access Array_Type;
372
L, R : in Index_Type)
373
is
374
-- Precondition: L < R.
375
J : Index_Type;
376
begin -- Insertion_Sort
377
for I in Index_Type range Index_Type'Succ (L) .. R loop
378
Temp := To_Sort (I);
379
J := I;
380
while J > L and then Temp < To_Sort (Index_Type'Pred (J)) loop
381
To_Sort (J) := To_Sort (Index_Type'Pred (J));
382
J := Index_Type'Pred (J);
383
end loop;
384
To_Sort (J) := Temp;
385
end loop;
386
end Insertion_Sort;
387
388
procedure Heap_Sort
389
(To_Sort : access Array_Type;
390
Left, Right : in Index_Type)
391
is
392
-- Precondition: Left < Right
393
394
Offset : Integer;
395
396
procedure Sift
397
(To_Sort : access Array_Type;
398
L, R : in Index_Type)
399
is
400
I : Index_Type := L;
401
C : Index_Type := L;
402
begin
403
Temp := To_Sort (L);
404
while (Index_Type'Pos (C) - Offset + 1) <=
405
(Index_Type'Pos (R) - Offset + 1) / 2
406
loop
407
C := Index_Type'Val
408
((Index_Type'Pos (I) - Offset + 1) * 2 - 1 + Offset);
409
if
410
C < R and then To_Sort (C) < To_Sort (Index_Type'Succ (C))
411
then
412
C := Index_Type'Succ (C);
413
end if;
414
exit when not (Temp < To_Sort (C));
415
To_Sort (I) := To_Sort (C);
416
I := C;
417
end loop;
418
To_Sort (I) := Temp;
419
end Sift;
420
421
J : Index_Type;
422
423
begin -- Heap_Sort
424
-- Precondition: Left < Right
425
Offset := Index_Type'Pos (Left);
426
-- Set J to the middle:
427
J := Index_Type'Val
428
((Index_Type'Pos (Right) - Offset + 1) / 2 + Offset - 1);
429
-- Build the heap:
430
for I in reverse Index_Type range Left .. J loop
431
Sift (To_Sort, I, Right);
432
end loop;
433
-- And now extract elements and re-build the heap.
434
J := Right;
435
loop
436
-- Put the largest element (which is now in front) at the end and
437
-- replace it with the last element.
438
Swap (To_Sort, Left, J);
439
J := Index_Type'Pred (J);
440
exit when J = Left;
441
-- Rebuild the remaining heap (one element less).
442
Sift (To_Sort, Left, J);
443
end loop;
444
end Heap_Sort;
445
446
procedure Intro_Sort
447
(To_Sort : access Array_Type;
448
L, R : in Index_Type;
449
D : in Natural)
450
is
451
452
Left : Index_Type := L;
453
Right : Index_Type := R;
454
-- L and R are in parameters, so copy.
455
Depth : Natural := D; -- Ditto for D.
456
I : Index_Type := Left;
457
J : Index_Type := Right;
458
Middle : Index_Type;
459
460
begin -- Intro_Sort
461
while Index_Type'Pos (Right) - Index_Type'Pos (Left) > Cut_Off loop
462
if Depth = 0 then Heap_Sort (To_Sort, Left, Right); return; end if;
463
Middle :=
464
Index_Type'Val
465
(Index_Type'Pos (Left) +
466
(Index_Type'Pos (Right) - Index_Type'Pos (Left)) / 2);
467
-- Median-of-three:
468
if To_Sort (Middle) < To_Sort (Left) then
469
Swap (To_Sort, Middle, Left);
470
end if;
471
if To_Sort (Right) < To_Sort (Left) then
472
Swap (To_Sort, Right, Left);
473
end if;
474
if To_Sort (Right) < To_Sort (Middle) then
475
Swap (To_Sort, Right, Middle);
476
end if;
477
Pivot := To_Sort (Middle);
478
-- Here, I = Left and J = Right
479
while I < J loop
480
while To_Sort (I) < Pivot loop
481
I := Index_Type'Succ (I);
482
end loop;
483
while Pivot < To_Sort (J) loop
484
J := Index_Type'Pred (J);
485
end loop;
486
if I <= J then
487
if I < J then Swap (To_Sort, I, J); end if;
488
-- Now increment I and decrement J..., but beware of
489
-- boundary conditions!
490
if I < Index_Type'Last then
491
I := Index_Type'Succ (I);
492
end if;
493
if J > Index_Type'First then
494
J := Index_Type'Pred (J);
495
end if;
496
end if;
497
end loop;
498
Depth := Depth - 1;
499
if Index_Type'Pos (J) - Index_Type'Pos (Left) >
500
Index_Type'Pos (Right) - Index_Type'Pos (I)
501
then
502
if I < Right then Intro_Sort (To_Sort, I, Right, Depth); end if;
503
I := Left; Right := J;
504
else
505
if J > Left then Intro_Sort (To_Sort, Left, J, Depth); end if;
506
J := Right; Left := I;
507
end if;
508
-- If either I or J saturated, Left >= Right now, and we'll
509
-- quit the outer loop.
510
end loop;
511
if Left < Right then Insertion_Sort (To_Sort, Left, Right); end if;
512
end Intro_Sort;
513
514
begin -- Sort_Slice_G
515
if To_Sort'Last > To_Sort'First and then From <= To then
516
if From < To_Sort'First or else To > To_Sort'Last then
517
-- If 'From' is > To_Sort'Last, then so is 'To'. And if 'To' is
518
-- < To_Sort'First, then so is 'From'. Hence the above condition
519
-- is sufficient to ensure that *both* indices are within range.
520
raise Constraint_Error;
521
end if;
522
Intro_Sort
523
(To_Sort, From, To,
524
Max_Depth (Index_Type'Pos (To) - Index_Type'Pos (From) + 1));
525
end if;
526
end Sort_Slice_G;
527
528
----------------------------------------------------------------------------
529
-- A very general sort that can be used to sort whatever you like. As
530
-- long as you can provide random access in constant time, this will
531
-- be a logarithmic sort. (It's an introspective quicksort, too.)
532
533
-- generic
534
-- with function Is_Smaller (Left, Right : in Integer) return Boolean;
535
-- -- Shall return True if the element at index 'Left' is smaller than
536
-- -- the element at index 'Right' and Fasle otherwise.
537
-- with procedure Copy (To, From : in Integer);
538
-- -- Shall copy the element at index 'From' to position 'To'.
539
procedure Sort_Indexed_G
540
(Left, Right : in Natural)
541
is
542
pragma Suppress (Overflow_Check);
543
pragma Suppress (Index_Check);
544
pragma Suppress (Range_Check);
545
546
procedure Swap (L, R : in Natural);
547
pragma Inline (Swap); -- inline this for increased performance.
548
549
procedure Swap (L, R : in Natural)
550
is
551
begin
552
Copy (-1, L); Copy (L, R); Copy (R, -1);
553
end Swap;
554
555
procedure Insertion_Sort
556
(L, R : in Positive)
557
is
558
-- Precondition: L < R.
559
J : Natural;
560
begin -- Insertion_Sort
561
for I in Natural range L + 1 .. R loop
562
Copy (-1, I);
563
J := I;
564
while J > L and then Is_Smaller (-1, J - 1) loop
565
Copy (J, J - 1);
566
J := J - 1;
567
end loop;
568
Copy (J, -1);
569
end loop;
570
end Insertion_Sort;
571
572
procedure Heap_Sort
573
(Left, Right : in Positive)
574
is
575
-- Precondition: Left < Right
576
577
Offset : constant Integer := Left;
578
579
procedure Sift
580
(L, R : in Natural)
581
is
582
I : Integer := L;
583
C : Integer := L;
584
begin
585
Copy (-1, L);
586
while (C - Offset + 1) <= (R - Offset + 1) / 2 loop
587
C := (I - Offset + 1) * 2 - 1 + Offset;
588
if C < R and then Is_Smaller (C, C + 1) then
589
C := C + 1;
590
end if;
591
exit when not Is_Smaller (-1, C);
592
Copy (I, C);
593
I := C;
594
end loop;
595
Copy (I, -1);
596
end Sift;
597
598
J : Natural;
599
600
begin -- Heap_Sort
601
-- Precondition: Left < Right
602
J := (Right - Offset + 1) / 2 + Offset - 1;
603
-- Build the heap:
604
for I in reverse Positive range Left .. J loop
605
Sift (I, Right);
606
end loop;
607
-- And now extract elements and re-build the heap.
608
J := Right;
609
loop
610
-- Put the largest element (which is now in front) at the end and
611
-- replace it with the last element.
612
Swap (Left, J);
613
J := J - 1;
614
exit when J = Left;
615
-- Rebuild the remaining heap (one element less).
616
Sift (Left, J);
617
end loop;
618
end Heap_Sort;
619
620
procedure Intro_Sort
621
(L, R : in Natural;
622
D : in Natural)
623
is
624
Left : Natural := L; -- L and R are in parameters, so copy.
625
Right : Natural := R;
626
Depth : Natural := D; -- Ditto for D.
627
I : Natural := Left;
628
J : Natural := Right;
629
Middle : Natural;
630
631
begin -- Intro_Sort
632
while Right - Left > Cut_Off loop
633
if Depth = 0 then Heap_Sort (Left, Right); return; end if;
634
Middle := Left + (Right - Left) / 2;
635
-- Median-of-three:
636
if Is_Smaller (Middle, Left) then Swap (Middle, Left); end if;
637
if Is_Smaller (Right, Left) then Swap (Right, Left); end if;
638
if Is_Smaller (Right, Middle) then Swap (Right, Middle); end if;
639
Copy (-2, Middle);
640
-- Here, I = Left and J = Right
641
while I < J loop
642
while Is_Smaller (I, -2) loop I := I + 1; end loop;
643
while Is_Smaller (-2, J) loop J := J - 1; end loop;
644
if I <= J then
645
if I < J then Swap (I, J); end if;
646
if I < Positive'Last then I := I + 1; end if;
647
if J > 1 then J := J - 1; end if;
648
end if;
649
end loop;
650
Depth := Depth - 1;
651
if
652
Integer (J) - Integer (Left) > Integer (Right) - Integer (I)
653
then
654
-- Left part is longer.
655
if I < Right then Intro_Sort (I, Right, Depth); end if;
656
I := Left; Right := J;
657
else
658
-- Right part is longer.
659
if J > Left then Intro_Sort (Left, J, Depth); end if;
660
J := Right; Left := I;
661
end if;
662
end loop;
663
if Left < Right then Insertion_Sort (Left, Right); end if;
664
end Intro_Sort;
665
666
begin -- Sort_Indexed_G
667
if Left < Right then
668
Intro_Sort (Left, Right, Max_Depth (Right - Left + 1));
669
end if;
670
end Sort_Indexed_G;
671
672
----------------------------------------------------------------------------
673
-- Same as above, but using access-to-subroutines.
674
675
procedure Sort
676
(Left, Right : in Natural;
677
Is_Smaller : in Comparator;
678
Copy : in Copier)
679
is
680
pragma Suppress (Overflow_Check);
681
pragma Suppress (Index_Check);
682
pragma Suppress (Range_Check);
683
pragma Suppress (Access_Check);
684
685
procedure Swap (L, R : in Natural);
686
pragma Inline (Swap); -- inline this for increased performance.
687
688
procedure Swap (L, R : in Natural)
689
is
690
begin
691
Copy (-1, L); Copy (L, R); Copy (R, -1);
692
end Swap;
693
694
procedure Insertion_Sort
695
(L, R : in Positive)
696
is
697
-- Precondition: L < R.
698
J : Natural;
699
begin -- Insertion_Sort
700
for I in Natural range L + 1 .. R loop
701
Copy (-1, I);
702
J := I;
703
while J > L and then Is_Smaller (-1, J - 1) loop
704
Copy (J, J - 1);
705
J := J - 1;
706
end loop;
707
Copy (J, -1);
708
end loop;
709
end Insertion_Sort;
710
711
procedure Heap_Sort
712
(Left, Right : in Natural)
713
is
714
-- Precondition: Left < Right
715
716
Offset : constant Integer := Left;
717
718
procedure Sift
719
(L, R : in Natural)
720
is
721
I : Integer := L;
722
C : Integer := L;
723
begin
724
Copy (-1, L);
725
while (C - Offset + 1) <= (R - Offset + 1) / 2 loop
726
C := (I - Offset + 1) * 2 - 1 + Offset;
727
if C < R and then Is_Smaller (C, C + 1) then
728
C := C + 1;
729
end if;
730
exit when not Is_Smaller (-1, C);
731
Copy (I, C);
732
I := C;
733
end loop;
734
Copy (I, -1);
735
end Sift;
736
737
J : Natural;
738
739
begin -- Heap_Sort
740
-- Precondition: Left < Right
741
J := (Right - Offset + 1) / 2 + Offset - 1;
742
-- Build the heap:
743
for I in reverse Positive range Left .. J loop
744
Sift (I, Right);
745
end loop;
746
-- And now extract elements and re-build the heap.
747
J := Right;
748
loop
749
-- Put the largest element (which is now in front) at the end and
750
-- replace it with the last element.
751
Swap (Left, J);
752
J := J - 1;
753
exit when J = Left;
754
-- Rebuild the remaining heap (one element less).
755
Sift (Left, J);
756
end loop;
757
end Heap_Sort;
758
759
procedure Intro_Sort
760
(L, R : in Natural;
761
D : in Natural)
762
is
763
Left : Natural := L; -- L and R are in parameters, so copy.
764
Right : Natural := R;
765
Depth : Natural := D; -- Ditto for D.
766
I : Natural := Left;
767
J : Natural := Right;
768
Middle : Natural;
769
770
begin -- Intro_Sort
771
while Right - Left > Cut_Off loop
772
if Depth = 0 then Heap_Sort (Left, Right); return; end if;
773
Middle := Left + (Right - Left) / 2;
774
-- Median-of-three:
775
if Is_Smaller (Middle, Left) then Swap (Middle, Left); end if;
776
if Is_Smaller (Right, Left) then Swap (Right, Left); end if;
777
if Is_Smaller (Right, Middle) then Swap (Right, Middle); end if;
778
Copy (-2, Middle);
779
-- Here, I = Left and J = Right
780
while I < J loop
781
while Is_Smaller (I, -2) loop I := I + 1; end loop;
782
while Is_Smaller (-2, J) loop J := J - 1; end loop;
783
if I <= J then
784
if I < J then Swap (I, J); end if;
785
if I < Positive'Last then I := I + 1; end if;
786
if J > 1 then J := J - 1; end if;
787
end if;
788
end loop;
789
Depth := Depth - 1;
790
if
791
Integer (J) - Integer (Left) > Integer (Right) - Integer (I)
792
then
793
-- Left part is longer.
794
if I < Right then Intro_Sort (I, Right, Depth); end if;
795
I := Left; Right := J;
796
else
797
-- Right part is longer.
798
if J > Left then Intro_Sort (Left, J, Depth); end if;
799
J := Right; Left := I;
800
end if;
801
end loop;
802
if Left < Right then Insertion_Sort (Left, Right); end if;
803
end Intro_Sort;
804
805
begin -- Sort
806
if Left < Right then
807
-- We have suppressed access checks. Do it once and for all times
808
-- by hand.
809
if Is_Smaller = null or else Copy = null then
810
raise Constraint_Error;
811
end if;
812
Intro_Sort (Left, Right, Max_Depth (Right - Left + 1));
813
end if;
814
end Sort;
815
816
----------------------------------------------------------------------------
817
818
end GAL.Sorting;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1