home *** CD-ROM | disk | FTP | other *** search
- -- ++
- -- A generic shell sort. This is an implementation of the classical shell sort
- -- function. The function is fully parameterisable with the items to be sorted,
- -- the index range type of the array, the array type of the items and a compare
- -- function. The array of items can be different sizes providing this package
- -- is instantiated with an unconstrained array type.
- -- --
-
- generic
- type Item is private;
- type Index is (<>);
- type Items is array (Index range <>) of Item;
- with function "<" (Left : in Item; Right : in Item) return Boolean;
- package Shell_Sort is
- procedure Sort (The_Items : in out Items);
- end Shell_Sort;
-
- package body Shell_Sort is
- function "+" (Left : in Index; Right : in Positive) return Index is
- begin
- return Index'Val(Index'Pos(Left) + Right);
- end;
-
- function "-" (Left : in Index; Right : in Positive) return Index is
- begin
- return Index'Val(Index'Pos(Left) - Right);
- end;
-
- pragma INLINE ("+","-");
-
- procedure Sort (The_Items : in out Items) is
- Temporary_Item : Item;
- Inner_Index : Index;
- Increment : Positive := 1;
- begin
- while Increment * 3 + 1 < The_Items'Length loop
- Increment := Increment * 3 + 1;
- end loop;
- loop
- for Outer_Index in Index range The_Items'First + Increment .. The_Items'Last loop
- Temporary_Item := The_Items(Outer_Index);
- Inner_Index := Outer_Index;
- while Temporary_Item < The_Items(Inner_Index - Increment) loop
- The_Items(Inner_Index) := The_Items(Inner_Index - Increment);
- Inner_Index := Inner_Index - Increment;
- exit when Inner_Index < The_Items'First + Increment;
- end loop;
- The_Items(Inner_Index) := Temporary_Item;
- end loop;
- exit when Increment = 1;
- Increment := Increment / 3;
- end loop;
- end Sort;
- end Shell_Sort;
-