
Sorting Algorithm

This is a sorting algorithm.   It may be applied to a set of data in order to sort it.    
For comparing various sorts, see compare sorts.  
For other sorting algorithms,   see sorting algorithms,   or:

O(n logn) sorts
Heap sort |
Merge sort |
Patience sort |
Quick sort
O(n log2n) sorts
Shell Sort
O(n2) sorts
Bubble sort |
Cocktail sort |
Cocktail sort with shifting bounds |
Comb sort |
Cycle sort |
Gnome sort |
Insertion sort |
Selection sort |
Strand sort
other sorts
Bead sort |
Bogo sort |
Common sorted list |
Composite structures sort |
Custom comparator sort |
Counting sort |
Disjoint sublist sort |
External sort |
Jort sort |
Lexicographical sort |
Natural sorting |
Order by pair comparisons |
Order disjoint list items |
Order two numerical lists |
Object identifier (OID) sort |
Pancake sort |
Quickselect |
Permutation sort |
Radix sort |
Ranking methods |
Remove duplicate elements |
Sleep sort |
Stooge sort |
[Sort letters of a string] |
Three variable sort |
Topological sort |
Tree sort


Sort an array of numbers (of any convenient size) into ascending order using   Patience sorting.



Related task

   Longest increasing subsequence


MODULE PatienceSortTask;
 
FROM STextIO IMPORT WriteString;
FROM STextIO IMPORT WriteLn;
FROM WholeStr IMPORT IntToStr;
 
CONST MaxSortSize = 1024;       (* A power of two. *)
      MaxWinnersSize = (2 * MaxSortSize) - 1;
 
TYPE PilesArrayType = ARRAY [1 .. MaxSortSize] OF INTEGER;
     WinnersArrayType = ARRAY [1 .. MaxWinnersSize],
                              [1 .. 2] OF INTEGER;
 
VAR ExampleNumbers : ARRAY [0 .. 35] OF INTEGER;
    SortedIndices : ARRAY [0 .. 25] OF INTEGER;
    i : INTEGER;
    NumStr : ARRAY [0 .. 2] OF CHAR;
 
PROCEDURE NextPowerOfTwo (n : INTEGER) : INTEGER;
  VAR Pow2 : INTEGER;
BEGIN
  (* This need not be a fast implementation. *)
  Pow2 := 1;
  WHILE Pow2 < n DO
    Pow2 := Pow2 + Pow2;
  END;
  RETURN Pow2;
END NextPowerOfTwo;
 
PROCEDURE InitPilesArray (VAR Arr : PilesArrayType);
  VAR i : INTEGER;
BEGIN
  FOR i := 1 TO MaxSortSize DO
    Arr[i] := 0;
  END;
END InitPilesArray;
 
PROCEDURE InitWinnersArray (VAR Arr : WinnersArrayType);
  VAR i : INTEGER;
BEGIN
  FOR i := 1 TO MaxWinnersSize DO
    Arr[i, 1] := 0;
    Arr[i, 2] := 0;
  END;
END InitWinnersArray;
 
PROCEDURE IntegerPatienceSort (iFirst, iLast : INTEGER;
                               Arr : ARRAY OF INTEGER;
                               VAR Sorted : ARRAY OF INTEGER);
  VAR NumPiles : INTEGER;
      Piles, Links : PilesArrayType;
      Winners : WinnersArrayType;
 
  PROCEDURE FindPile (q : INTEGER) : INTEGER;
    (*
       Bottenbruch search for the leftmost pile whose top is greater
       than or equal to some element x. Return an index such that:
 
       * if x is greater than the top element at the far right, then
         the index returned will be num-piles.
 
       * otherwise, x is greater than every top element to the left of
         index, and less than or equal to the top elements at index
         and to the right of index.
 
       References:
 
       * H. Bottenbruch, "Structure and use of ALGOL 60", Journal of
         the ACM, Volume 9, Issue 2, April 1962, pp.161-221.
         https://doi.org/10.1145/321119.321120
 
         The general algorithm is described on pages 214 and 215.
 
       * https://en.wikipedia.org/w/index.php?title=Binary_search_algorithm&oldid=1062988272#Alternative_procedure
     *)
    VAR i, j, k, Index : INTEGER;
  BEGIN
    IF NumPiles = 0 THEN
      Index := 1;
    ELSE
      j := 0;
      k := NumPiles - 1;
      WHILE j <> k DO
        i := (j + k) DIV 2;
        IF Arr[Piles[j + 1] + iFirst - 1] < Arr[q + iFirst - 1] THEN
          j := i + 1;
        ELSE
          k := i;
        END;
      END;
      IF j = NumPiles - 1 THEN
        IF Arr[Piles[j + 1] + iFirst - 1] < Arr[q + iFirst - 1] THEN
          (* A new pile is needed. *)
          j := j + 1;
        END;
      END;
      Index := j + 1;
    END;
    RETURN Index;
  END FindPile;
 
  PROCEDURE Deal;
    VAR i, q : INTEGER;
  BEGIN
    FOR q := 1 TO iLast - iFirst + 1 DO
      i := FindPile (q);
      Links[q] := Piles[i];
      Piles[i] := q;
      IF i = NumPiles + 1 THEN
        NumPiles := i;
      END;
    END;
  END Deal;
 
  PROCEDURE KWayMerge;
    (*
       k-way merge by tournament tree.
 
       See Knuth, volume 3, and also
       https://en.wikipedia.org/w/index.php?title=K-way_merge_algorithm&oldid=1047851465#Tournament_Tree
 
       However, I store a winners tree instead of the recommended
       losers tree. If the tree were stored as linked nodes, it would
       probably be more efficient to store a losers tree. However, I
       am storing the tree as an array, and one can find an opponent
       quickly by simply toggling the least significant bit of a
       competitor's array index.
     *)
    VAR TotalExternalNodes : INTEGER;
        TotalNodes : INTEGER;
        iSorted, i, Next : INTEGER;
 
    PROCEDURE FindOpponent (i : INTEGER) : INTEGER;
      VAR Opponent : INTEGER;
    BEGIN
      IF ODD (i) THEN
        Opponent := i - 1;
      ELSE
        Opponent := i + 1;
      END;
      RETURN Opponent;
    END FindOpponent;
 
    PROCEDURE PlayGame (i : INTEGER) : INTEGER;
      VAR j, iWinner : INTEGER;
    BEGIN
      j := FindOpponent (i);
      IF Winners[i, 1] = 0 THEN
        iWinner := j;
      ELSIF Winners[j, 1] = 0 THEN
        iWinner := i;
      ELSIF Arr[Winners[j, 1] + iFirst - 1]
               < Arr[Winners[i, 1] + iFirst - 1] THEN
        iWinner := j;
      ELSE
        iWinner := i;
      END;
      RETURN iWinner;
    END PlayGame;
 
    PROCEDURE ReplayGames (i : INTEGER);
      VAR j, iWinner : INTEGER;
    BEGIN
      j := i;
      WHILE j <> 1 DO
        iWinner := PlayGame (j);
        j := j DIV 2;
        Winners[j, 1] := Winners[iWinner, 1];
        Winners[j, 2] := Winners[iWinner, 2];
      END;
    END ReplayGames;
 
    PROCEDURE BuildTree;
      VAR iStart, i, iWinner : INTEGER;
    BEGIN
      FOR i := 1 TO TotalExternalNodes DO
        (* Record which pile a winner will have come from. *)
        Winners[TotalExternalNodes - 1 + i, 2] := i;
      END;
 
      FOR i := 1 TO NumPiles DO
        (* The top of each pile becomes a starting competitor. *)
        Winners[TotalExternalNodes + i - 1, 1] := Piles[i];
      END;
 
      FOR i := 1 TO NumPiles DO
        (* Discard the top of each pile. *)
        Piles[i] := Links[Piles[i]];
      END;
 
      iStart := TotalExternalNodes;
      WHILE iStart <> 1 DO
        FOR i := iStart TO (2 * iStart) - 1 BY 2 DO
          iWinner := PlayGame (i);
          Winners[i DIV 2, 1] := Winners[iWinner, 1];
          Winners[i DIV 2, 2] := Winners[iWinner, 2];
        END;
        iStart := iStart DIV 2;
      END;
    END BuildTree;
 
  BEGIN
    TotalExternalNodes := NextPowerOfTwo (NumPiles);
    TotalNodes := (2 * TotalExternalNodes) - 1;
    BuildTree;
    iSorted := 0;
    WHILE Winners[1, 1] <> 0 DO
      Sorted[iSorted] := Winners[1, 1] + iFirst - 1;
      iSorted := iSorted + 1;
      i := Winners[1, 2];
      Next := Piles[i];         (* The next top of pile i. *)
      IF Next <> 0 THEN
        Piles[i] := Links[Next]; (* Drop that top. *)
      END;
      i := (TotalNodes DIV 2) + i;
      Winners[i, 1] := Next;
      ReplayGames (i);
    END;
  END KWayMerge;
 
BEGIN
  NumPiles := 0;
  InitPilesArray (Piles);
  InitPilesArray (Links);
  InitWinnersArray (Winners);
 
  IF MaxSortSize < iLast - iFirst + 1 THEN
    WriteString ('This subarray is too large for the program.');
    WriteLn;
    HALT;
  ELSE
    Deal;
    KWayMerge;
  END;
END IntegerPatienceSort;
 
BEGIN
  ExampleNumbers[10] := 22;
  ExampleNumbers[11] := 15;
  ExampleNumbers[12] := 98;
  ExampleNumbers[13] := 82;
  ExampleNumbers[14] := 22;
  ExampleNumbers[15] := 4;
  ExampleNumbers[16] := 58;
  ExampleNumbers[17] := 70;
  ExampleNumbers[18] := 80;
  ExampleNumbers[19] := 38;
  ExampleNumbers[20] := 49;
  ExampleNumbers[21] := 48;
  ExampleNumbers[22] := 46;
  ExampleNumbers[23] := 54;
  ExampleNumbers[24] := 93;
  ExampleNumbers[25] := 8;
  ExampleNumbers[26] := 54;
  ExampleNumbers[27] := 2;
  ExampleNumbers[28] := 72;
  ExampleNumbers[29] := 84;
  ExampleNumbers[30] := 86;
  ExampleNumbers[31] := 76;
  ExampleNumbers[32] := 53;
  ExampleNumbers[33] := 37;
  ExampleNumbers[34] := 90;
 
  IntegerPatienceSort (10, 34, ExampleNumbers, SortedIndices);
 
  WriteString ("unsorted  ");
  FOR i := 10 TO 34 DO
    WriteString (" ");
    IntToStr (ExampleNumbers[i], NumStr);
    WriteString (NumStr);
  END;
  WriteLn;
  WriteString ("sorted    ");
  FOR i := 0 TO 24 DO
    WriteString (" ");
    IntToStr (ExampleNumbers[SortedIndices[i]], NumStr);
    WriteString (NumStr);
  END;
  WriteLn;
END PatienceSortTask.