Sorting algorithms/Patience sort

From Rosetta Code
Task
Sorting algorithms/Patience sort
You are encouraged to solve this task according to the task description, using any language you may know.

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


Related task



11l

Translation of: Kotlin
F patience_sort(&arr)
   I arr.len < 2 {R}

   [[T(arr[0])]] piles
   L(el) arr
      L(&pile) piles
         I pile.last > el
            pile.append(el)
            L.break
      L.was_no_break
         piles.append([el])

   L(i) 0 .< arr.len
      V min = piles[0].last
      V minPileIndex = 0
      L(j) 1 .< piles.len
         I piles[j].last < min
            min = piles[j].last
            minPileIndex = j
      arr[i] = min
      V& minPile = piles[minPileIndex]
      minPile.pop()
      I minPile.empty
         piles.pop(minPileIndex)

V iArr = [4, 65, 2, -31, 0, 99, 83, 782, 1]
patience_sort(&iArr)
print(iArr)

V cArr = [‘n’, ‘o’, ‘n’, ‘z’, ‘e’, ‘r’, ‘o’, ‘s’, ‘u’, ‘m’]
patience_sort(&cArr)
print(cArr)

V sArr = [‘dog’, ‘cow’, ‘cat’, ‘ape’, ‘ant’, ‘man’, ‘pig’, ‘ass’, ‘gnu’]
patience_sort(&sArr)
print(sArr)
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
[e, m, n, n, o, o, r, s, u, z]
[ant, ape, ass, cat, cow, dog, gnu, man, pig]

AArch64 Assembly

Works with: as version Raspberry Pi 3B version Buster 64 bits
/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program patienceSort64.s  */
 
/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeConstantesARM64.inc"

/*******************************************/
/* Structures                               */
/********************************************/
/* structure Doublylinkedlist*/
    .struct  0
dllist_head:                    // head node
    .struct  dllist_head + 8
dllist_tail:                    // tail node
    .struct  dllist_tail  + 8
dllist_fin:
/* structure Node Doublylinked List*/
    .struct  0
NDlist_next:                    // next element
    .struct  NDlist_next + 8 
NDlist_prev:                    // previous element
    .struct  NDlist_prev + 8 
NDlist_value:                   // element value or key
    .struct  NDlist_value + 8
NDlist_fin:

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"
 
.align 4
TableNumber:      .quad   1,3,11,6,2,-5,9,10,8,4,7
#TableNumber:     .quad   10,9,8,7,6,-5,4,3,2,1
                 .equ NBELEMENTS, (. - TableNumber) / 8 
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:       .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main 
main:                                              // entry of program 
    ldr x0,qAdrTableNumber                         // address number table
    mov x1,0                                       // first element
    mov x2,NBELEMENTS                              // number of élements 
    bl patienceSort
    ldr x0,qAdrTableNumber                         // address number table
    bl displayTable

    ldr x0,qAdrTableNumber                         // address number table
    mov x1,NBELEMENTS                              // number of élements 
    bl isSorted                                    // control sort
    cmp x0,1                                       // sorted ?
    beq 1f                                    
    ldr x0,qAdrszMessSortNok                       // no !! error sort
    bl affichageMess
    b 100f
1:                                                 // yes
    ldr x0,qAdrszMessSortOk
    bl affichageMess
100:                                               // standard end of the program 
    mov x0,0                                       // return code
    mov x8,EXIT                                    // request to exit program
    svc 0                                          // perform the system call
 
qAdrsZoneConv:            .quad sZoneConv
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsMessResult:          .quad sMessResult
qAdrTableNumber:          .quad TableNumber
qAdrszMessSortOk:         .quad szMessSortOk
qAdrszMessSortNok:        .quad szMessSortNok
/******************************************************************/
/*     control sorted table                                   */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains the number of elements  > 0  */
/* x0 return 0  if not sorted   1  if sorted */
isSorted:
    stp x2,lr,[sp,-16]!             // save  registers
    stp x3,x4,[sp,-16]!             // save  registers
    mov x2,0
    ldr x4,[x0,x2,lsl 3]
1:
    add x2,x2,1
    cmp x2,x1
    bge 99f
    ldr x3,[x0,x2, lsl 3]
    cmp x3,x4
    blt 98f
    mov x4,x3
    b 1b
98:
    mov x0,0                       // not sorted
    b 100f
99:
    mov x0,1                       // sorted
100:
    ldp x3,x4,[sp],16              // restaur  2 registers
    ldp x2,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30
/******************************************************************/
/*         patience sort                                                   */ 
/******************************************************************/
/* x0 contains the address of table */
/* x1 contains first start index
/* x2 contains the number of elements  */
patienceSort:
    stp x1,lr,[sp,-16]!        // save  registers
    stp x2,x3,[sp,-16]!        // save  registers
    stp x4,x5,[sp,-16]!        // save  registers
    stp x6,x7,[sp,-16]!        // save  registers
    stp x8,x9,[sp,-16]!        // save  registers
    lsl x9,x2,1                // compute total size of piles (2 list pointer by pile )
    lsl x10,x9,3               // 8 bytes by number
    sub sp,sp,x10              // reserve place to stack
    mov fp,sp                  // frame pointer = stack
    mov x3,0                   // index
    mov x4,0
1:
    str x4,[fp,x3,lsl 3]       // init piles area 
    add x3,x3,1                // increment index
    cmp x3,x9
    blt 1b
    mov x3,0                   // index value
    mov x4,0                   // counter first pile
    mov x8,x0                  // save table address
2:
    ldr x1,[x8,x3,lsl 3]       // load value 
    add x0,fp,x4,lsl 4         // pile address
    bl isEmpty
    cmp x0,0                   // pile empty ?
    bne 3f
    add x0,fp,x4,lsl 4         // pile address
    bl insertHead              // insert value x1
    b 5f
3:
    add x0,fp,x4,lsl 4         // pile address
    ldr x5,[x0,dllist_head]
    ldr x5,[x5,NDlist_value]   // load first list value
    cmp x1,x5                  // compare value and last value on the pile
    blt 4f
    add x0,fp,x4,lsl 4         // pile address
    bl insertHead              // insert value x1
    b 5f
4:                             // value is smaller créate a new pile
    add x4,x4,1
    add x0,fp,x4,lsl 4         // pile address
    bl insertHead              // insert value x1
5:  
    add x3,x3,1                // increment index value
    cmp x3,x2                  // end 
    blt 2b                     // and loop
   
    /* step 2 */
    mov x6,0                   // index value table
6:
    mov x3,0                   // index pile
    mov x5, 1<<62              // min
7:                             // search minimum
    add x0,fp,x3,lsl 4
    bl isEmpty
    cmp x0,0
    beq 8f
    add x0,fp,x3,lsl 4
    bl searchMinList
    cmp x0,x5                 // compare min global
    bge 8f
    mov x5,x0                 // smaller -> store new min
    mov x7,x1                 // and pointer to min
    add x9,fp,x3,lsl 4        // and head list
8:
    add x3,x3,1               // next pile
    cmp x3,x4                 // end ?
    ble 7b
    str x5,[x8,x6,lsl 3]      // store min to table value
    mov x0,x9                 // and suppress the value in the pile
    mov x1,x7
    bl suppressNode
    add x6,x6,1               // increment index value
    cmp x6,x2                 // end ?
    blt 6b
    
    add sp,sp,x10             // stack alignement
100:
    ldp x8,x9,[sp],16         // restaur  2 registers
    ldp x6,x7,[sp],16         // restaur  2 registers
    ldp x4,x5,[sp],16         // restaur  2 registers
    ldp x2,x3,[sp],16         // restaur  2 registers
    ldp x1,lr,[sp],16         // restaur  2 registers
    ret                       // return to address lr x30

/******************************************************************/
/*      Display table elements                                */ 
/******************************************************************/
/* x0 contains the address of table */
displayTable:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    mov x2,x0                        // table address
    mov x3,0
1:                                   // loop display table
    ldr x0,[x2,x3,lsl 3]
    ldr x1,qAdrsZoneConv
    bl conversion10S                  // décimal conversion
    ldr x0,qAdrsMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc            // insert result at // character
    bl affichageMess                 // display message
    add x3,x3,1
    cmp x3,NBELEMENTS - 1
    ble 1b
    ldr x0,qAdrszCarriageReturn
    bl affichageMess
    mov x0,x2
100:
    ldp x2,x3,[sp],16               // restaur  2 registers
    ldp x1,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
/******************************************************************/
/*     list is empty ?                         */ 
/******************************************************************/
/* x0 contains the address of the list structure */
/* x0 return 0 if empty  else return 1 */
isEmpty:
    ldr x0,[x0,#dllist_head]
    cmp x0,0
    cset x0,ne
    ret                                // return
/******************************************************************/
/*     insert value at list head                        */ 
/******************************************************************/
/* x0 contains the address of the list structure */
/* x1 contains value */
insertHead:
    stp x1,lr,[sp,-16]!                  // save  registers
    stp x2,x3,[sp,-16]!                  // save  registers
    stp x4,x5,[sp,-16]!                  // save  registers
    mov x4,x0                            // save address
    mov x0,x1                            // value
    bl createNode
    cmp x0,#-1                           // allocation error ?
    beq 100f
    ldr x2,[x4,#dllist_head]             // load address first node
    str x2,[x0,#NDlist_next]             // store in next pointer on new node
    mov x1,#0
    str x1,[x0,#NDlist_prev]             // store zero in previous pointer on new node
    str x0,[x4,#dllist_head]             // store address new node in address head list 
    cmp x2,#0                            // address first node is null ?
    beq 1f
    str x0,[x2,#NDlist_prev]             // no store adresse new node in previous pointer
    b 100f
1:
    str x0,[x4,#dllist_tail]             // else store new node in tail address
100:
    ldp x4,x5,[sp],16                    // restaur  2 registers
    ldp x2,x3,[sp],16                    // restaur  2 registers
    ldp x1,lr,[sp],16                    // restaur  2 registers
    ret                                  // return to address lr x30

/******************************************************************/
/*     search value minimum                                               */ 
/******************************************************************/
/* x0 contains the address of the list structure */
/* x0 return min   */
/* x1 return address of node */
searchMinList:
    stp x2,lr,[sp,-16]!                  // save  registers
    stp x3,x4,[sp,-16]!                  // save  registers
    ldr x0,[x0,#dllist_head]             // load first node
    mov x3,1<<62
    mov x1,0
1:
    cmp x0,0                             // null -> end 
    beq 99f
    ldr x2,[x0,#NDlist_value]            // load node value
    cmp x2,x3                            // min ?
    bge 2f
    mov x3,x2                            // value -> min
    mov x1,x0                            // store pointer 
2:
    ldr x0,[x0,#NDlist_next]             // load addresse next node 
    b 1b                                 // and loop
99:
    mov x0,x3                            // return minimum
100:
    ldp x3,x4,[sp],16                    // restaur  2 registers
    ldp x2,lr,[sp],16                    // restaur  2 registers
    ret                                  // return to address lr x30
/******************************************************************/
/*     suppress node                                               */ 
/******************************************************************/
/* x0 contains the address of the list structure */
/* x1 contains the address to node to suppress  */
suppressNode:
    stp x2,lr,[sp,-16]!              // save  registers
    stp x3,x4,[sp,-16]!              // save  registers
    ldr x2,[x1,#NDlist_next]         // load addresse next node 
    ldr x3,[x1,#NDlist_prev]         // load addresse prev node 
    cmp x3,#0
    beq 1f
    str x2,[x3,#NDlist_next] 
    b 2f
1:
    str x3,[x0,#NDlist_next] 
2:
    cmp x2,#0
    beq 3f
    str x3,[x2,#NDlist_prev]
    b 100f
3:
    str x2,[x0,#NDlist_prev]
100:

    ldp x3,x4,[sp],16               // restaur  2 registers
    ldp x2,lr,[sp],16               // restaur  2 registers
    ret                             // return to address lr x30
/******************************************************************/
/*     Create new node                                            */ 
/******************************************************************/
/* x0 contains the value */
/* x0 return node address or -1 if allocation error*/
createNode:
    stp x1,lr,[sp,-16]!              // save  registers
    stp x2,x3,[sp,-16]!              // save  registers
    stp x4,x8,[sp,-16]!              // save  registers
    mov x4,x0                        // save value
                                     // allocation place on the heap
    mov x0,0                         // allocation place heap
    mov x8,BRK                       // call system 'brk'
    svc 0
    mov x3,x0                        // save address heap for output string
    add x0,x0,NDlist_fin                // reservation place one element
    mov x8,BRK                       // call system 'brk'
    svc #0
    cmp x0,-1                        // allocation error
    beq 100f
    mov x0,x3
    str x4,[x0,#NDlist_value]        // store value
    mov x2,0
    str x2,[x0,#NDlist_next]         // store zero to pointer next
    str x2,[x0,#NDlist_prev]         // store zero to pointer previous
100:
    ldp x4,x8,[sp],16                // restaur  2 registers
    ldp x2,x3,[sp],16                // restaur  2 registers
    ldp x1,lr,[sp],16                // restaur  2 registers
    ret                              // return to address lr x30
/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"

Ada

Translation of: Fortran
Works with: Ada version GNAT Community 2021


The program implements a generic sort that produces a sorted array of indices. The original array is left untouched. The main program demonstrates an instantiation for arrays of integers.


----------------------------------------------------------------------

with Ada.Text_IO;

procedure patience_sort_task is
  use Ada.Text_IO;

  function next_power_of_two
   (n : in Natural)
    return Positive is
    -- This need not be a fast implementation.
    pow2 : Positive;
  begin
    pow2 := 1;
    while pow2 < n loop
      pow2 := pow2 + pow2;
    end loop;
    return pow2;
  end next_power_of_two;

  generic
    type t is private;
    type t_array is array (Integer range <>) of t;
    type sorted_t_indices is array (Integer range <>) of Integer;
  procedure patience_sort
   (less : access function
     (x, y : t)
      return Boolean;
    ifirst : in Integer;
    ilast : in Integer;
    arr : in t_array;
    sorted : out sorted_t_indices);

  procedure patience_sort
   (less : access function
     (x, y : t)
      return Boolean;
    ifirst : in Integer;
    ilast : in Integer;
    arr : in t_array;
    sorted : out sorted_t_indices) is

    num_piles : Integer;
    piles : array (1 .. ilast - ifirst + 1) of Integer :=
     (others => 0);
    links : array (1 .. ilast - ifirst + 1) of Integer :=
     (others => 0);

    function find_pile
     (q : in Positive)
      return Positive is
      --
      -- 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
      --
      index : Positive;
      i, j, k : Natural;
    begin
      if num_piles = 0 then
        index := 1;
      else
        j := 0;
        k := num_piles - 1;
        while j /= k loop
          i := (j + k) / 2;
          if less
            (arr (piles (j + 1) + ifirst - 1), arr (q + ifirst - 1))
          then
            j := i + 1;
          else
            k := i;
          end if;
        end loop;
        if j = num_piles - 1 then
          if less
            (arr (piles (j + 1) + ifirst - 1), arr (q + ifirst - 1))
          then
            -- A new pile is needed.
            j := j + 1;
          end if;
        end if;
        index := j + 1;
      end if;
      return index;
    end find_pile;

    procedure deal is
      i : Positive;
    begin
      for q in links'range loop
        i := find_pile (q);
        links (q) := piles (i);
        piles (i) := q;
        num_piles := Integer'max (num_piles, i);
      end loop;
    end deal;

    procedure k_way_merge is
      --
      -- 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.
      --
      total_external_nodes : Positive;
      total_nodes : Positive;
    begin

      total_external_nodes := next_power_of_two (num_piles);
      total_nodes := (2 * total_external_nodes) - 1;

      declare

        -- In Fortran I had the length-2 dimension come first, to
        -- take some small advantage of column-major order. The
        -- recommendation for Ada compilers, however, is to use
        -- row-major order. So I have reversed the order.
        winners : array (1 .. total_nodes, 1 .. 2) of Integer :=
         (others => (0, 0));

        function find_opponent
         (i : Natural)
          return Natural is
        begin
          return (if i rem 2 = 0 then i + 1 else i - 1);
        end find_opponent;

        function play_game
         (i : Positive)
          return Positive is
          j, iwinner : Positive;
        begin
          j := find_opponent (i);
          if winners (i, 1) = 0 then
            iwinner := j;
          elsif winners (j, 1) = 0 then
            iwinner := i;
          elsif less
            (arr (winners (j, 1) + ifirst - 1),
             arr (winners (i, 1) + ifirst - 1))
          then
            iwinner := j;
          else
            iwinner := i;
          end if;
          return iwinner;
        end play_game;

        procedure replay_games
         (i : Positive) is
          j, iwinner : Positive;
        begin
          j := i;
          while j /= 1 loop
            iwinner := play_game (j);
            j := j / 2;
            winners (j, 1) := winners (iwinner, 1);
            winners (j, 2) := winners (iwinner, 2);
          end loop;
        end replay_games;

        procedure build_tree is
          istart, i, iwinner : Positive;
        begin
          for i in 1 .. total_external_nodes loop
            -- Record which pile a winner will have come from.
            winners (total_external_nodes - 1 + i, 2) := i;
          end loop;

          for i in 1 .. num_piles loop
            -- The top of each pile becomes a starting competitor.
            winners (total_external_nodes + i - 1, 1) := piles (i);
          end loop;

          for i in 1 .. num_piles loop
            -- Discard the top of each pile
            piles (i) := links (piles (i));
          end loop;

          istart := total_external_nodes;
          while istart /= 1 loop
            i := istart;
            while i <= (2 * istart) - 1 loop
              iwinner := play_game (i);
              winners (i / 2, 1) := winners (iwinner, 1);
              winners (i / 2, 2) := winners (iwinner, 2);
              i := i + 2;
            end loop;
            istart := istart / 2;
          end loop;
        end build_tree;

        isorted, i, next : Integer;

      begin
        build_tree;
        isorted := 0;
        while winners (1, 1) /= 0 loop
          sorted (sorted'first + 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 if;
          i := (total_nodes / 2) + i;
          winners (i, 1) := next;
          replay_games (i);
        end loop;
      end;

    end k_way_merge;

  begin
    deal;
    k_way_merge;
  end patience_sort;

begin

  -- A demonstration.

  declare

    type integer_array is array (Integer range <>) of Integer;
    procedure integer_patience_sort is new patience_sort
     (Integer, integer_array, integer_array);

    subtype int25_array is integer_array (1 .. 25);

    example_numbers : constant int25_array :=
     (22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, 46, 54, 93, 8,
      54, 2, 72, 84, 86, 76, 53, 37, 90);

    sorted_numbers : int25_array := (others => 0);

    function less
     (x, y : Integer)
      return Boolean is
    begin
      return (x < y);
    end less;

  begin
    integer_patience_sort
     (less'access, example_numbers'first, example_numbers'last,
      example_numbers, sorted_numbers);

    Put ("unsorted  ");
    for i of example_numbers loop
      Put (Integer'image (i));
    end loop;
    Put_Line ("");
    Put ("sorted    ");
    for i of sorted_numbers loop
      Put (Integer'image (example_numbers (i)));
    end loop;
    Put_Line ("");
  end;

end patience_sort_task;

----------------------------------------------------------------------
Output:
$ gnatmake -Wall -Wextra -q patience_sort_task.adb && ./patience_sort_task
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

AppleScript

-- In-place patience sort.
on patienceSort(theList, l, r) -- Sort items l thru r of theList.
    set listLen to (count theList)
    if (listLen < 2) then return
    -- Convert any negative and/or transposed range indices.
    if (l < 0) then set l to listLen + l + 1
    if (r < 0) then set r to listLen + r + 1
    if (l > r) then set {l, r} to {r, l}
    
    script o
        property lst : theList
        property piles : {}
    end script
    
    -- Build piles.
    repeat with i from l to r
        set v to o's lst's item i
        set unplaced to true
        repeat with thisPile in o's piles
            if (v > thisPile's end) then
            else
                set thisPile's end to v
                set unplaced to false
                exit repeat
            end if
        end repeat
        if (unplaced) then set o's piles's end to {v}
    end repeat
    
    -- Remove successive lowest end values to the original list.
    set pileCount to (count o's piles)
    repeat with i from l to r
        set min to o's piles's beginning's end
        set minPile to 1
        repeat with j from 2 to pileCount
            set v to o's piles's item j's end
            if (v < min) then
                set min to v
                set minPile to j
            end if
        end repeat
        
        set o's lst's item i to min
        if ((count o's piles's item minPile) > 1) then
            set o's piles's item minPile to o's piles's item minPile's items 1 thru -2
        else
            set o's piles's item minPile to missing value
            set o's piles to o's piles's lists
            set pileCount to pileCount - 1
        end if
    end repeat
    
    return -- nothing
end patienceSort
property sort : patienceSort

local aList
set aList to {62, 86, 59, 65, 92, 85, 71, 71, 27, -52, 67, 59, 65, 80, 3, 65, 2, 46, 83, 72, 47, 5, 26, 18, 63}
sort(aList, 1, -1)
return aList
Output:
{-52, 2, 3, 5, 18, 26, 27, 46, 47, 59, 59, 62, 63, 65, 65, 65, 67, 71, 71, 72, 80, 83, 85, 86, 92}

ARM Assembly

Works with: as version Raspberry Pi
/* ARM assembly Raspberry PI  */
/*  program patienceSort.s  */
 
 /* REMARK 1 : this program use routines in a include file 
   see task Include a file language arm assembly 
   for the routine affichageMess conversion10 
   see at end of this program the instruction include */
/* for constantes see task include a file in arm assembly */
/************************************/
/* Constantes                       */
/************************************/
.include "../constantes.inc"

.include "../../ficmacros.s"
/*******************************************/
/* Structures                               */
/********************************************/
/* structure Doublylinkedlist*/
    .struct  0
dllist_head:                    @ head node
    .struct  dllist_head + 4
dllist_tail:                    @ tail node
    .struct  dllist_tail  + 4
dllist_fin:
/* structure Node Doublylinked List*/
    .struct  0
NDlist_next:                    @ next element
    .struct  NDlist_next + 4 
NDlist_prev:                    @ previous element
    .struct  NDlist_prev + 4 
NDlist_value:                   @ element value or key
    .struct  NDlist_value + 4 
NDlist_fin:

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessSortOk:       .asciz "Table sorted.\n"
szMessSortNok:      .asciz "Table not sorted !!!!!.\n"
sMessResult:        .asciz "Value  : @ \n"
szCarriageReturn:   .asciz "\n"
 
.align 4
TableNumber:      .int   1,11,3,6,2,5,9,10,8,4,7
#TableNumber:       .int   10,9,8,7,6,5,4,3,2,1
                   .equ NBELEMENTS, (. - TableNumber) / 4
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
sZoneConv:            .skip 24
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main 
main:                                              @ entry of program 
 
    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#0                                      @ first element
    mov r2,#NBELEMENTS                             @ number of élements 
    bl patienceSort
    ldr r0,iAdrTableNumber                         @ address number table
    bl displayTable
    
    ldr r0,iAdrTableNumber                         @ address number table
    mov r1,#NBELEMENTS                             @ number of élements 
    bl isSorted                                    @ control sort
    cmp r0,#1                                      @ sorted ?
    beq 1f                                    
    ldr r0,iAdrszMessSortNok                       @ no !! error sort
    bl affichageMess
    b 100f
1:                                                 @ yes
    ldr r0,iAdrszMessSortOk
    bl affichageMess
100:                                               @ standard end of the program 
    mov r0, #0                                     @ return code
    mov r7, #EXIT                                  @ request to exit program
    svc #0                                         @ perform the system call
 
iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessResult:          .int sMessResult
iAdrTableNumber:          .int TableNumber
iAdrszMessSortOk:         .int szMessSortOk
iAdrszMessSortNok:        .int szMessSortNok
/******************************************************************/
/*     control sorted table                                   */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains the number of elements  > 0  */
/* r0 return 0  if not sorted   1  if sorted */
isSorted:
    push {r2-r4,lr}                                    @ save registers
    mov r2,#0
    ldr r4,[r0,r2,lsl #2]
1:
    add r2,#1
    cmp r2,r1
    movge r0,#1
    bge 100f
    ldr r3,[r0,r2, lsl #2]
    cmp r3,r4
    movlt r0,#0
    blt 100f
    mov r4,r3
    b 1b
100:
    pop {r2-r4,lr}
    bx lr                                              @ return 

/******************************************************************/
/*         patience sort                                                   */ 
/******************************************************************/
/* r0 contains the address of table */
/* r1 contains first start index
/* r2 contains the number of elements  */
patienceSort:
    push {r1-r9,lr}            @ save registers
    lsl r9,r2,#1               @ compute total size of piles (2 list pointer by pile )
    lsl r10,r9,#2              @ 4 bytes by number
    sub sp,sp,r10              @ reserve place to stack
    mov fp,sp                  @ frame pointer = stack
    mov r3,#0                  @ index
    mov r4,#0
1:
    str r4,[fp,r3,lsl #2]      @ init piles area 
    add r3,r3,#1               @ increment index
    cmp r3,r9
    blt 1b
    mov r3,#0                  @ index value
    mov r4,#0                  @ counter first pile
    mov r8,r0                  @ save table address
2:
    ldr r1,[r8,r3,lsl #2]      @ load value 
    add r0,fp,r4,lsl #3        @ pile address
    bl isEmpty
    cmp r0,#0                  @ pile empty ?
    bne 3f
    add r0,fp,r4,lsl #3        @ pile address
    bl insertHead              @ insert value r1
    b 5f
3:
    add r0,fp,r4,lsl #3        @ pile address
    ldr r5,[r0,#dllist_head]
    ldr r5,[r5,#NDlist_value]  @ load first list value
    cmp r1,r5                  @ compare value and last value on the pile
    blt 4f
    add r0,fp,r4,lsl #3        @ pile address
    bl insertHead              @ insert value r1
    b 5f
4:                             @ value is smaller créate a new pile
    add r4,r4,#1
    add r0,fp,r4,lsl #3        @ pile address
    bl insertHead              @ insert value r1
5:  
    add r3,r3,#1               @ increment index value
    cmp r3,r2                  @ end 
    blt 2b                     @ and loop
   
    /* step 2 */
    mov r6,#0                 @ index value table
6:
    mov r3,#0                 @ index pile
    mov r5,# 1<<30            @ min
7:                            @ search minimum
    add r0,fp,r3,lsl #3
    bl isEmpty
    cmp r0,#0
    beq 8f
    add r0,fp,r3,lsl #3
    bl searchMinList
    cmp r0,r5                 @ compare min global
    movlt r5,r0               @ smaller -> store new min
    movlt r7,r1               @ and pointer to min
    addlt r9,fp,r3,lsl #3     @ and head list
8:
    add r3,r3,#1              @ next pile
    cmp r3,r4                 @ end ?
    ble 7b
    str r5,[r8,r6,lsl #2]     @ store min to table value
    mov r0,r9                 @ and suppress the value in the pile
    mov r1,r7
    bl suppressNode
    add r6,r6,#1              @ increment index value
    cmp r6,r2                 @ end ?
    blt 6b
    
    add sp,sp,r10             @ stack alignement
100:
    pop {r1-r9,lr}
    bx lr                     @ return 

 
/******************************************************************/
/*      Display table elements                                */ 
/******************************************************************/
/* r0 contains the address of table */
displayTable:
    push {r0-r3,lr}                                    @ save registers
    mov r2,r0                                          @ table address
    mov r3,#0
1:                                                     @ loop display table
    ldr r0,[r2,r3,lsl #2]
    ldr r1,iAdrsZoneConv                               @ 
    bl conversion10S                                    @ décimal conversion 
    ldr r0,iAdrsMessResult
    ldr r1,iAdrsZoneConv                               @ insert conversion
    bl strInsertAtCharInc
    bl affichageMess                                   @ display message
    add r3,#1
    cmp r3,#NBELEMENTS - 1
    ble 1b
    ldr r0,iAdrszCarriageReturn
    bl affichageMess
    mov r0,r2
100:
    pop {r0-r3,lr}
    bx lr
iAdrsZoneConv:           .int sZoneConv
/******************************************************************/
/*     list is empty ?                         */ 
/******************************************************************/
/* r0 contains the address of the list structure */
/* r0 return 0 if empty  else return 1 */
isEmpty:
    ldr r0,[r0,#dllist_head]
    cmp r0,#0
    movne r0,#1
    bx lr                                @ return
/******************************************************************/
/*     insert value at list head                        */ 
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains value */
insertHead:
    push {r1-r4,lr}                         @ save  registers 
    mov r4,r0                            @ save address
    mov r0,r1                            @ value
    bl createNode
    cmp r0,#-1                           @ allocation error ?
    beq 100f
    ldr r2,[r4,#dllist_head]             @ load address first node
    str r2,[r0,#NDlist_next]             @ store in next pointer on new node
    mov r1,#0
    str r1,[r0,#NDlist_prev]             @ store zero in previous pointer on new node
    str r0,[r4,#dllist_head]             @ store address new node in address head list 
    cmp r2,#0                            @ address first node is null ?
    strne r0,[r2,#NDlist_prev]           @ no store adresse new node in previous pointer
    streq r0,[r4,#dllist_tail]           @ else store new node in tail address
100:
    pop {r1-r4,lr}                       @ restaur registers
    bx lr                                @ return

/******************************************************************/
/*     search value minimum                                               */ 
/******************************************************************/
/* r0 contains the address of the list structure */
/* r0 return min   */
/* r1 return address of node */
searchMinList:
    push {r2,r3,lr}                         @ save  registers 
    ldr r0,[r0,#dllist_head]             @ load first node
    mov r3,#1<<30
    mov r1,#0
1:
    cmp r0,#0                            @ null -> end 
    moveq r0,r3
    beq 100f
    ldr r2,[r0,#NDlist_value]            @ load node value
    cmp r2,r3                            @ min ?
    movlt r3,r2                            @ value -> min
    movlt r1,r0                            @ store pointer 
    ldr r0,[r0,#NDlist_next]             @ load addresse next node 
    b 1b                                 @ and loop
100:
    pop {r2,r3,lr}                          @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     suppress node                                               */ 
/******************************************************************/
/* r0 contains the address of the list structure */
/* r1 contains the address to node to suppress  */
suppressNode:
    push {r2,r3,lr}                      @ save  registers 
    ldr r2,[r1,#NDlist_next]             @ load addresse next node 
    ldr r3,[r1,#NDlist_prev]             @ load addresse prev node 
    cmp r3,#0
    strne r2,[r3,#NDlist_next] 
    streq r3,[r0,#NDlist_next] 
    cmp r2,#0
    strne r3,[r2,#NDlist_prev]
    streq r2,[r0,#NDlist_prev]
100:
    pop {r2,r3,lr}                       @ restaur registers
    bx lr                                @ return
/******************************************************************/
/*     Create new node                                            */ 
/******************************************************************/
/* r0 contains the value */
/* r0 return node address or -1 if allocation error*/
createNode:
    push {r1-r7,lr}                         @ save  registers 
    mov r4,r0                            @ save value
    @ allocation place on the heap
    mov r0,#0                                   @ allocation place heap
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    mov r5,r0                                   @ save address heap for output string
    add r0,#NDlist_fin                            @ reservation place one element
    mov r7,#0x2D                                @ call system 'brk'
    svc #0
    cmp r0,#-1                                  @ allocation error
    beq 100f
    mov r0,r5
    str r4,[r0,#NDlist_value]                   @ store value
    mov r2,#0
    str r2,[r0,#NDlist_next]                    @ store zero to pointer next
    str r2,[r0,#NDlist_prev]                    @ store zero to pointer previous
100:
    pop {r1-r7,lr}                          @ restaur registers
    bx lr                                   @ return
/***************************************************/
/*      ROUTINES INCLUDE                           */
/***************************************************/
.include "../affichage.inc"

Arturo

patienceSort: function [arr][
    result: new arr

    if 2 > size result -> return result

    piles: []

    loop result 'elem ->
        'piles ++ @[@[elem]]

    loop 0..dec size result 'i [
        minP: last piles\0
        minPileIndex: 0

        if 2 =< size piles ->
            loop 1..dec size piles 'j [
                if minP > last piles\[j] [
                    minP: last piles\[j]
                    minPileIndex: j
                ]
            ]

        result\[i]: minP
        piles\[minPileIndex]: slice piles\[minPileIndex] 0 dec dec size piles\[minPileIndex]
        if zero? size piles\[minPileIndex] -> 
            piles: remove.index piles minPileIndex
    ]
    return result
]

print patienceSort [3 1 2 8 5 7 9 4 6]
Output:
1 2 3 4 5 6 7 8 9

ATS

A patience sort for arrays of non-linear elements

Translation of: Fortran


The sort routine returns an array of indices into the original array, which is left unmodified.

(*------------------------------------------------------------------*)

#include "share/atspre_staload.hats"

vtypedef array_tup_vt (a : vt@ype+, p : addr, n : int) =
  (* An array, without size information attached. *)
  @(array_v (a, p, n),
    mfree_gc_v p |
    ptr p)

extern fn {a : t@ype}
patience_sort
          {ifirst, len   : int | 0 <= ifirst}
          {n             : int | ifirst + len <= n}
          (arr           : &RD(array (a, n)),
           ifirst        : size_t ifirst,
           len           : size_t len)
    :<!wrt> (* Return an array of indices into arr. *)
            [p : addr]
            array_tup_vt
              ([i : int | len == 0 ||
                          (ifirst <= i && i < ifirst + len)] size_t i,
               p, len)

(* patience_sort$lt : the order predicate. *)
extern fn {a : t@ype}
patience_sort$lt (x : a, y : a) :<> bool

(*------------------------------------------------------------------*)
(*

  In the following implementation of next_power_of_two:

    * I implement it as a template for all types of kind g1uint. This
      includes dependent forms of uint, usint, ulint, ullint, size_t,
      and yet more types in the prelude; also whatever others one may
      create.

    * I prove the result is not less than the input.

    * I prove the result is less than twice the input.

    * I prove the result is a power of two. This last proof is
      provided in the form of an EXP2 prop.

    * I do NOT return what number two is raised to (though I easily
      could have). I leave that number "existentially defined". In
      other words, I prove only that some such non-negative number
      exists.

*)

fn {tk : tkind}
next_power_of_two
          {i : pos}
          (i : g1uint (tk, i))
    :<> [k : int | i <= k; k < 2 * i]
        [n : nat]
        @(EXP2 (n, k) | g1uint (tk, k)) =
  let
    (* This need not be a fast implementation. *)

    val one : g1uint (tk, 1) = g1u2u 1u

    fun
    loop {j  : pos | j < i} .<i + i - j>.
         (pf : [n : nat] EXP2 (n, j) |
          j  : g1uint (tk, j))
        :<> [k : int | i <= k; k < 2 * i]
            [n : nat]
            @(EXP2 (n, k) | g1uint (tk, k)) =
      let
        val j2 = j + j
      in
        if i <= j2 then
          @(EXP2ind pf | j2)
        else
          loop (EXP2ind pf | j2)
      end
  in
    if i = one then
      @(EXP2bas () | one)
    else
      loop (EXP2bas () | one)
  end

(*------------------------------------------------------------------*)

stadef link (ifirst : int, ilast : int, i : int) : bool =
  0 <= i && i <= ilast - ifirst + 1

typedef link_t (ifirst : int, ilast : int, i : int) =
  (* A size_t within legal range for a normalized link, including the
     "nil" link 0. *)
  [link (ifirst, ilast, i)]
  size_t i
typedef link_t (ifirst : int, ilast : int) =
  [i : int]
  link_t (ifirst, ilast, i)

fn {a : t@ype}
find_pile {ifirst, ilast : int | ifirst <= ilast}
          {n             : int | ilast < n}
          {num_piles     : nat | num_piles <= ilast - ifirst + 1}
          {n_piles       : int | ilast - ifirst + 1 <= n_piles}
          {q             : pos | q <= ilast - ifirst + 1}
          (ifirst        : size_t ifirst,
           arr           : &RD(array (a, n)),
           num_piles     : size_t num_piles,
           piles         : &RD(array (link_t (ifirst, ilast),
                               n_piles)),
           q             : size_t q)
    :<> [i : pos | i <= num_piles + 1]
        size_t i =
  (*
    Bottenbruch search for the leftmost pile whose top is greater than
    or equal to the next value dealt by "deal".

    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
  *)
  if num_piles = i2sz 0 then
    i2sz 1
  else
    let
      macdef lt = patience_sort$lt<a>

      prval () = lemma_g1uint_param ifirst
      prval () = prop_verify {0 <= ifirst} ()

      fun
      loop {j, k  : nat | j <= k; k < num_piles}
           .<k - j>.
           (arr   : &RD(array (a, n)),
            piles : &array (link_t (ifirst, ilast), n_piles),
            j     : size_t j,
            k     : size_t k)
          :<> [i : pos | i <= num_piles + 1]
              size_t i =
        if j = k then
          begin
            if succ j <> num_piles then
              succ j
            else
              let
                val piles_j = piles[j]
                val () = $effmask_exn assertloc (piles_j <> g1u2u 0u)

                val x1 = arr[pred q + ifirst]
                and x2 = arr[pred piles_j + ifirst]
              in
                if x2 \lt x1 then
                  succ (succ j)
                else
                  succ j
              end
          end
        else
          let
            typedef index (i : int) = [0 <= i; i < n] size_t i
            typedef index = [i : int] index i

            stadef i = j + ((k - j) / 2)
            val i : size_t i = j + ((k - j) / g1u2u 2u)

            val piles_j = piles[j]
            val () = $effmask_exn assertloc (piles_j <> g1u2u 0u)

            val x1 = arr[pred q + ifirst]
            and x2 = arr[pred piles_j + ifirst]
          in
            if x2 \lt x1 then
              loop (arr, piles, i + 1, k)
            else
              loop (arr, piles, j, i)
          end
    in
      loop (arr, piles, g1u2u 0u, pred num_piles)
    end

fn {a : t@ype}
deal {ifirst, ilast : int | ifirst <= ilast}
     {n             : int | ilast < n}
     (ifirst : size_t ifirst,
      ilast  : size_t ilast,
      arr    : &RD(array (a, n)))
    :<!wrt> [num_piles   : int | num_piles <= ilast - ifirst + 1]
            [n_piles     : int | ilast - ifirst + 1 <= n_piles]
            [n_links     : int | ilast - ifirst + 1 <= n_links]
            [p_piles     : addr]
            [p_links     : addr]
            @(size_t num_piles,
              array_tup_vt (link_t (ifirst, ilast),
                            p_piles, n_piles),
              array_tup_vt (link_t (ifirst, ilast),
                            p_links, n_links)) =
  let
    prval () = prop_verify {0 < ilast - ifirst + 1} ()

    stadef num_elems = ilast - ifirst + 1
    val num_elems : size_t num_elems = succ (ilast - ifirst)

    typedef link_t (i : int) = link_t (ifirst, ilast, i)
    typedef link_t = link_t (ifirst, ilast)

    val zero : size_t 0 = g1u2u 0u
    val one : size_t 1 = g1u2u 1u
    val link_nil : link_t 0 = g1u2u 0u

    fun
    loop {q         : pos | q <= num_elems + 1}
         {m         : nat | m <= num_elems}
         .<num_elems + 1 - q>.
         (arr       : &RD(array (a, n)),
          q         : size_t q,
          piles     : &array (link_t, num_elems),
          links     : &array (link_t, num_elems),
          m         : size_t m)
        :<!wrt> [num_piles : nat | num_piles <= num_elems]
                size_t num_piles =
      if q = succ (num_elems) then
        m
      else
        let
          val i = find_pile {ifirst, ilast} (ifirst, arr, m, piles, q)

          (* We have no proof the number of elements will not exceed
             storage. However, we know it will not, because the number
             of piles cannot exceed the size of the input. Let us get
             a "proof" by runtime check. *)
          val () = $effmask_exn assertloc (i <= num_elems)
        in
          links[pred q] := piles[pred i];
          piles[pred i] := q;
          if i = succ m then
            loop {q + 1} (arr, succ q, piles, links, succ m)
          else
            loop {q + 1} (arr, succ q, piles, links, m)
        end

    val piles_tup = array_ptr_alloc<link_t> num_elems
    macdef piles = !(piles_tup.2)
    val () = array_initize_elt<link_t> (piles, num_elems, link_nil)

    val links_tup = array_ptr_alloc<link_t> num_elems
    macdef links = !(links_tup.2)
    val () = array_initize_elt<link_t> (links, num_elems, link_nil)

    val num_piles = loop (arr, one, piles, links, zero)
  in
    @(num_piles, piles_tup, links_tup)
  end

fn {a : t@ype}
k_way_merge {ifirst, ilast : int | ifirst <= ilast}
            {n             : int | ilast < n}
            {n_piles       : int | ilast - ifirst + 1 <= n_piles}
            {num_piles     : pos | num_piles <= ilast - ifirst + 1}
            {n_links       : int | ilast - ifirst + 1 <= n_links}
            (ifirst        : size_t ifirst,
             ilast         : size_t ilast,
             arr           : &RD(array (a, n)),
             num_piles     : size_t num_piles,
             piles         : &array (link_t (ifirst, ilast), n_piles),
             links         : &array (link_t (ifirst, ilast), n_links))
    :<!wrt> (* Return an array of indices into arr. *)
            [p : addr]
            array_tup_vt
              ([i : int | ifirst <= i; i <= ilast] size_t i,
               p, ilast - ifirst + 1) =
  (*
    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.
  *)
  let
    typedef link_t (i : int) = link_t (ifirst, ilast, i)
    typedef link_t = [i : int] link_t i

    val link_nil : link_t 0 = g1u2u 0u

    typedef index_t (i : int) = [ifirst <= i; i <= ilast] size_t i
    typedef index_t = [i : int] index_t i

    val [total_external_nodes : int]
        @(_ | total_external_nodes) = next_power_of_two num_piles
    prval () = prop_verify {num_piles <= total_external_nodes} ()

    stadef total_nodes = (2 * total_external_nodes) - 1
    val total_nodes : size_t total_nodes =
      pred (g1u2u 2u * total_external_nodes)

    (* We will ignore index 0 of the winners tree arrays. *)
    stadef winners_size = total_nodes + 1
    val winners_size : size_t winners_size = succ total_nodes

    val winners_values_tup = array_ptr_alloc<link_t> winners_size
    macdef winners_values = !(winners_values_tup.2)
    val () = array_initize_elt<link_t> (winners_values, winners_size,
                                        link_nil)

    val winners_links_tup = array_ptr_alloc<link_t> winners_size
    macdef winners_links = !(winners_links_tup.2)
    val () = array_initize_elt<link_t> (winners_links, winners_size,
                                        link_nil)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* Record which pile a winner will have come from.     *)

    fun
    init_pile_links
              {i : nat | i <= num_piles}
              .<num_piles - i>.
              (winners_links : &array (link_t, winners_size),
               i             : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        begin
          winners_links[total_external_nodes + i] := succ i;
          init_pile_links (winners_links, succ i)
        end

    val () = init_pile_links (winners_links, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* The top of each pile becomes a starting competitor. *)

    fun
    init_competitors
              {i : nat | i <= num_piles}
              .<num_piles - i>.
              (winners_values : &array (link_t, winners_size),
               piles          : &array (link_t, n_piles),
               i              : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        begin
          winners_values[total_external_nodes + i] := piles[i];
          init_competitors (winners_values, piles, succ i)
        end
 
    val () = init_competitors (winners_values, piles, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* Discard the top of each pile.                       *)

    fun
    discard_tops {i : nat | i <= num_piles}
                 .<num_piles - i>.
                 (piles : &array (link_t, n_piles),
                  links : &array (link_t, n_links),
                  i     : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        let
          val link = piles[i]

          (* None of the piles should have been empty. *)
          val () = $effmask_exn assertloc (link <> g1u2u 0u)
        in
          piles[i] := links[pred link];
          discard_tops (piles, links, succ i)
        end

    val () = discard_tops (piles, links, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* How to play a game.                                 *)
    
    fn
    play_game {i              : int | 2 <= i; i <= total_nodes}
              (arr            : &RD(array (a, n)),
               winners_values : &array (link_t, winners_size),
               i              : size_t i)
        :<> [iwinner : pos | iwinner <= total_nodes]
            size_t iwinner =
      let
        macdef lt = patience_sort$lt<a>

        fn
        find_opponent {i : int | 2 <= i; i <= total_nodes}
                      (i : size_t i)
            :<> [j : int | 2 <= j; j <= total_nodes]
                size_t j =
          let
            (* The prelude contains bitwise operations only for
               non-dependent unsigned integer. We will not bother to
               add them ourselves, but instead go back and forth
               between dependent and non-dependent. *)
            val i0 = g0ofg1 i
            val j0 = g0uint_lxor<size_kind> (i0, g0u2u 1u)
            val j = g1ofg0 j0

            (* We have no proof the opponent is in the proper
               range. Create a "proof" by runtime checks. *)
            val () = $effmask_exn assertloc (g1u2u 2u <= j)
            val () = $effmask_exn assertloc (j <= total_nodes)
          in
            j
          end

        val j = find_opponent i
        val winner_i = winners_values[i]
        and winner_j = winners_values[j]
      in
        if winner_i = link_nil then
          j
        else if winner_j = link_nil then
          i
        else
          let
            val i1 = pred winner_i + ifirst
            and i2 = pred winner_j + ifirst
            prval () = lemma_g1uint_param i1
            prval () = lemma_g1uint_param i2
          in
            if arr[i2] \lt arr[i1] then j else i
          end
      end

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)

    fun
    build_tree {istart : pos | istart <= total_external_nodes}
               .<istart>.
               (arr            : &RD(array (a, n)),
                winners_values : &array (link_t, winners_size),
                winners_links  : &array (link_t, winners_size),
                istart         : size_t istart)
        :<!wrt> void =
      if istart <> 1 then
        let
          fun
          play_initial_games
                    {i : int | istart <= i; i <= (2 * istart) + 1}
                    .<(2 * istart) + 1 - i>.
                    (arr            : &RD(array (a, n)),
                     winners_values : &array (link_t, winners_size),
                     winners_links  : &array (link_t, winners_size),
                     i              : size_t i)
              :<!wrt> void =
            if i <= pred (istart + istart) then
              let
                val iwinner = play_game (arr, winners_values, i)
                and i2 = i / g1u2u 2u
              in
                winners_values[i2] := winners_values[iwinner];
                winners_links[i2] := winners_links[iwinner];
                play_initial_games (arr, winners_values,
                                    winners_links, succ (succ i))
              end
        in
          play_initial_games (arr, winners_values, winners_links,
                              istart);
          build_tree (arr, winners_values, winners_links,
                      istart / g1u2u 2u)
        end

    val () = build_tree (arr, winners_values, winners_links,
                         total_external_nodes)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)

    fun
    replay_games {i : pos | i <= total_nodes}
                 .<i>.
                 (arr            : &RD(array (a, n)),
                  winners_values : &array (link_t, winners_size),
                  winners_links  : &array (link_t, winners_size),
                  i              : size_t i)
        :<!wrt> void =
      if i <> g1u2u 1u then
        let
          val iwinner = play_game (arr, winners_values, i)
          and i2 = i / g1u2u 2u
        in
          winners_values[i2] := winners_values[iwinner];
          winners_links[i2] := winners_links[iwinner];
          replay_games (arr, winners_values, winners_links, i2)
        end

    stadef num_elems = ilast - ifirst + 1
    val num_elems : size_t num_elems = succ (ilast - ifirst)

    val sorted_tup = array_ptr_alloc<index_t> num_elems

    fun
    merge {isorted  : nat | isorted <= num_elems}
          {p_sorted : addr}
          .<num_elems - isorted>.
          (pf_sorted      : !array_v (index_t?, p_sorted,
                                      num_elems - isorted)
                                >> array_v (index_t, p_sorted,
                                            num_elems - isorted) |
           arr            : &RD(array (a, n)),
           piles          : &array (link_t, n_piles),
           links          : &array (link_t, n_links),
           winners_values : &array (link_t, winners_size),
           winners_links  : &array (link_t, winners_size),
           p_sorted       : ptr p_sorted,
           isorted        : size_t isorted)
        :<!wrt> void =
      (* This function not only fills in the "sorted_tup" array, but
         transforms it from "uninitialized" to "initialized". *)
      if isorted <> num_elems then
        let
          prval @(pf_elem, pf_rest) = array_v_uncons pf_sorted
          val winner = winners_values[1]
          val () = $effmask_exn assertloc (winner <> link_nil)
          val () = !p_sorted := pred winner + ifirst

          (* Move to the next element in the winner's pile. *)
          val ilink = winners_links[1]
          val () = $effmask_exn assertloc (ilink <> link_nil)
          val inext = piles[pred ilink]
          val () = (if inext <> link_nil then
                      piles[pred ilink] := links[pred inext])

          (* Replay games, with the new element as a competitor. *)
          val i = (total_nodes / g1u2u 2u) + ilink
          val () = $effmask_exn assertloc (i <= total_nodes)
          val () = winners_values[i] := inext
          val () =
            replay_games (arr, winners_values, winners_links, i)

          val () = merge (pf_rest | arr, piles, links,
                                    winners_values, winners_links,
                                    ptr_succ<index_t> p_sorted,
                                    succ isorted)
          prval () = pf_sorted := array_v_cons (pf_elem, pf_rest)
        in
        end
      else
        let
          prval () = pf_sorted :=
            array_v_unnil_nil{index_t?, index_t} pf_sorted
        in
        end

    val () = merge (sorted_tup.0 | arr, piles, links,
                                   winners_values, winners_links,
                                   sorted_tup.2, i2sz 0)

    val () = array_ptr_free (winners_values_tup.0,
                             winners_values_tup.1 |
                             winners_values_tup.2)
    val () = array_ptr_free (winners_links_tup.0,
                             winners_links_tup.1 |
                             winners_links_tup.2)
  in
    sorted_tup
  end

implement {a}
patience_sort (arr, ifirst, len) =
  let
    prval () = lemma_g1uint_param ifirst
    prval () = lemma_g1uint_param len
  in
    if len = i2sz 0 then
      let
        val sorted_tup = array_ptr_alloc<size_t 0> len
        prval () = sorted_tup.0 :=
          array_v_unnil_nil{Size_t?, Size_t} sorted_tup.0
      in
        sorted_tup
      end
    else
      let
        val ilast = ifirst + pred len
        val @(num_piles, piles_tup, links_tup) =
          deal<a> (ifirst, ilast, arr)
        macdef piles = !(piles_tup.2)
        macdef links = !(links_tup.2)
        prval () = lemma_g1uint_param num_piles
        val () = $effmask_exn assertloc (num_piles <> i2sz 0)
        val sorted_tup = k_way_merge<a> (ifirst, ilast, arr,
                                         num_piles, piles, links)
      in
        array_ptr_free (piles_tup.0, piles_tup.1 | piles_tup.2);
        array_ptr_free (links_tup.0, links_tup.1 | links_tup.2);
        sorted_tup
      end
  end

(*------------------------------------------------------------------*)

fn
int_patience_sort_ascending
          {ifirst, len   : int | 0 <= ifirst}
          {n             : int | ifirst + len <= n}
          (arr           : &RD(array (int, n)),
           ifirst        : size_t ifirst,
           len           : size_t len)
    :<!wrt> [p : addr]
            array_tup_vt
              ([i : int | len == 0 ||
                          (ifirst <= i && i < ifirst + len)] size_t i,
               p, len) =
  let
    implement
    patience_sort$lt<int> (x, y) =
      x < y
  in
    patience_sort<int> (arr, ifirst, len)
  end

fn {a : t@ype}
find_length {n   : int}
            (lst : list (a, n))
    :<> [m : int | m == n] size_t m =
  let
    prval () = lemma_list_param lst
  in
    g1i2u (length lst)
  end

implement
main0 () =
  let
    val example_list =
      $list (22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, 46, 54,
             93, 8, 54, 2, 72, 84, 86, 76, 53, 37, 90)

    val ifirst = i2sz 10
    val [len : int] len = find_length example_list

    #define ARRSZ 100
    val () = assertloc (i2sz 10 + len <= ARRSZ)

    var arr : array (int, ARRSZ)
    val () = array_initize_elt<int> (arr, i2sz ARRSZ, 0)

    prval @(pf_left, pf_right) =
      array_v_split {int} {..} {ARRSZ} {10} (view@ arr)
    prval @(pf_middle, pf_right) =
      array_v_split {int} {..} {90} {len} pf_right

    val p = ptr_add<int> (addr@ arr, 10)
    val () = array_copy_from_list<int> (!p, example_list)

    prval pf_right = array_v_unsplit (pf_middle, pf_right)
    prval () = view@ arr := array_v_unsplit (pf_left, pf_right)

    val @(pf_sorted, pfgc_sorted | p_sorted) =
      int_patience_sort_ascending (arr, i2sz 10, len)

    macdef sorted = !p_sorted

    var i : [i : nat | i <= len] size_t i
  in
    print! ("unsorted  ");
    for (i := i2sz 0; i <> len; i := succ i)
      print! (" ", arr[i2sz 10 + i]);
    println! ();

    print! ("sorted    ");
    for (i := i2sz 0; i <> len; i := succ i)
      print! (" ", arr[sorted[i]]);
    println! ();

    array_ptr_free (pf_sorted, pfgc_sorted | p_sorted)
  end

(*------------------------------------------------------------------*)
Output:
$ patscc -O3 -DATS_MEMALLOC_LIBC patience_sort_task.dats && ./a.out
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

A patience sort for arrays of non-linear elements (second version)

Translation of: Fortran


This version of the sort (which I derived from the first) has a more primitive "core" implementation, and a wrapper around that. The "core" requires that the user pass workspace to it (much as Fortran 77 procedures often do). The wrapper uses stack storage for the workspaces, if the sorted subarray is small; otherwise it uses malloc. One may be interested in contrasting the branch that uses stack storage with the branch that uses malloc.

(* A version of the patience sort that uses arrays passed to it as its
   workspace, and returns the results in an array passed to it.

   This way, the arrays could be reused between calls, or easily put
   on the stack if they are not too large, yet still allocated if they
   are larger than that.

   Notice that the work arrays both start *and finish* as
   uninitialized storage. *)

(*------------------------------------------------------------------*)

#include "share/atspre_staload.hats"

(* ================================================================ *)
(* Interface declarations that really should be moved to a .sats    *)
(* file.                                                            *)

stadef patience_sort_index (ifirst : int, len : int, i : int) =
  len == 0 || (ifirst <= i && i < ifirst + len)
typedef patience_sort_index (ifirst : int, len : int, i : int) =
  [patience_sort_index (ifirst, len, i)] size_t i
typedef patience_sort_index (ifirst : int, len : int) =
  [i : int] patience_sort_index (ifirst, len, i)

stadef patience_sort_link (ifirst : int, len : int, i : int) =
  0 <= i && i <= len
typedef patience_sort_link (ifirst : int, len : int, i : int) =
  [patience_sort_link (ifirst, len, i)] size_t i
typedef patience_sort_link (ifirst : int, len : int) =
  [i : int] patience_sort_link (ifirst, len, i)

(* patience_sort$lt : the order predicate for patience sort. *)
extern fn {a : t@ype}
patience_sort$lt (x : a, y : a) :<> bool

local

  typedef index_t (ifirst : int, len : int) =
    patience_sort_index (ifirst, len)
  typedef link_t (ifirst : int, len : int) =
    patience_sort_link (ifirst, len)

in

  extern fn {a : t@ype}
  patience_sort_given_workspaces
            {ifirst, len : int | 0 <= ifirst}
            {n        : int | ifirst + len <= n}
            {power    : int | len <= power}
            {n_piles  : int | len <= n_piles}
            {n_links  : int | len <= n_links}
            {n_winv   : int | 2 * power <= n_winv}
            {n_winl   : int | 2 * power <= n_winl}
            (pf_exp2  : [exponent : nat] EXP2 (exponent, power) |
             arr      : &RD(array (a, n)),
             ifirst   : size_t ifirst,
             len      : size_t len,
             power    : size_t power,
             piles    : &array (link_t (ifirst, len)?, n_piles) >> _,
             links    : &array (link_t (ifirst, len)?, n_links) >> _,
             winvals  : &array (link_t (ifirst, len)?, n_winv) >> _,
             winlinks : &array (link_t (ifirst, len)?, n_winl) >> _,
             sorted   : &array (index_t (ifirst, len)?, len)
                          >> array (index_t (ifirst, len), len))
      :<!wrt> void

  extern fn {a : t@ype}
  patience_sort_with_its_own_workspaces
            {ifirst, len : int | 0 <= ifirst}
            {n        : int | ifirst + len <= n}
            (arr      : &RD(array (a, n)),
             ifirst   : size_t ifirst,
             len      : size_t len,
             sorted   : &array (index_t (ifirst, len)?, len)
                          >> array (index_t (ifirst, len), len))
      :<!wrt> void

end

overload patience_sort with patience_sort_given_workspaces
overload patience_sort with patience_sort_with_its_own_workspaces

extern fn {tk : tkind}
next_power_of_two
          {i : pos}
          (i : g1uint (tk, i))
    :<> [k : int | i <= k; k < 2 * i]
        [n : nat]
        @(EXP2 (n, k) | g1uint (tk, k))

(* ================================================================ *)
(* What follows is implementation and belongs in .dats files.       *)

(*------------------------------------------------------------------*)
(*

  In the following implementation of next_power_of_two:

    * I implement it as a template for all types of kind g1uint. This
      includes dependent forms of uint, usint, ulint, ullint, size_t,
      and yet more types in the prelude; also whatever others one may
      create.

    * I prove the result is not less than the input.

    * I prove the result is less than twice the input.

    * I prove the result is a power of two. This last proof is
      provided in the form of an EXP2 prop.

    * I do NOT return what number two is raised to (though I easily
      could have). I leave that number "existentially defined". In
      other words, I prove only that some such non-negative number
      exists.

*)

implement {tk}
next_power_of_two {i} (i) =
  let
    (* This is not the fastest implementation, although it does verify
       its own correctness. *)

    val one : g1uint (tk, 1) = g1u2u 1u

    fun
    loop {j  : pos | j < i} .<i + i - j>.
         (pf : [n : nat] EXP2 (n, j) |
          j  : g1uint (tk, j))
        :<> [k : int | i <= k; k < 2 * i]
            [n : nat]
            @(EXP2 (n, k) | g1uint (tk, k)) =
      let
        val j2 = j + j
      in
        if i <= j2 then
          @(EXP2ind pf | j2)
        else
          loop (EXP2ind pf | j2)
      end
  in
    if i = one then
      @(EXP2bas () | one)
    else
      loop (EXP2bas () | one)
  end

(*------------------------------------------------------------------*)

extern praxi {a : vt@ype}
array_uninitize_without_doing_anything
          {n   : int}
          (arr : &array (INV(a), n) >> array (a?, n),
           asz : size_t n)
    :<prf> void

(*------------------------------------------------------------------*)

stadef index_t (ifirst : int, len : int, i : int) =
  patience_sort_index (ifirst, len, i)
typedef index_t (ifirst : int, len : int, i : int) =
  patience_sort_index (ifirst, len, i)
typedef index_t (ifirst : int, len : int) =
  patience_sort_index (ifirst, len)

stadef link_t (ifirst : int, len : int, i : int) =
  patience_sort_link (ifirst, len, i)
typedef link_t (ifirst : int, len : int, i : int) =
  patience_sort_link (ifirst, len, i)
typedef link_t (ifirst : int, len : int) =
  patience_sort_link (ifirst, len)

fn {a : t@ype}
find_pile {ifirst, len : int}
          {n           : int | ifirst + len <= n}
          {num_piles   : nat | num_piles <= len}
          {n_piles     : int | len <= n_piles}
          {q           : pos | q <= len}
          (ifirst      : size_t ifirst,
           arr         : &RD(array (a, n)),
           num_piles   : size_t num_piles,
           piles       : &RD(array (link_t (ifirst, len), n_piles)),
           q           : size_t q)
    :<> [i : pos | i <= num_piles + 1]
        size_t i =
  (*
    Bottenbruch search for the leftmost pile whose top is greater than
    or equal to the next value dealt by "deal".

    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
  *)
  if num_piles = i2sz 0 then
    i2sz 1
  else
    let
      macdef lt = patience_sort$lt<a>

      prval () = lemma_g1uint_param ifirst
      prval () = prop_verify {0 <= ifirst} ()

      fun
      loop {j, k  : nat | j <= k; k < num_piles}
           .<k - j>.
           (arr   : &RD(array (a, n)),
            piles : &array (link_t (ifirst, len), n_piles),
            j     : size_t j,
            k     : size_t k)
          :<> [i : pos | i <= num_piles + 1]
              size_t i =
        if j = k then
          begin
            if succ j <> num_piles then
              succ j
            else
              let
                val piles_j = piles[j]
                val () = $effmask_exn assertloc (piles_j <> g1u2u 0u)

                val x1 = arr[pred q + ifirst]
                and x2 = arr[pred piles_j + ifirst]
              in
                if x2 \lt x1 then
                  succ (succ j)
                else
                  succ j
              end
          end
        else
          let
            typedef index (i : int) = [0 <= i; i < n] size_t i
            typedef index = [i : int] index i

            stadef i = j + ((k - j) / 2)
            val i : size_t i = j + ((k - j) / g1u2u 2u)

            val piles_j = piles[j]
            val () = $effmask_exn assertloc (piles_j <> g1u2u 0u)

            val x1 = arr[pred q + ifirst]
            and x2 = arr[pred piles_j + ifirst]
          in
            if x2 \lt x1 then
              loop (arr, piles, i + 1, k)
            else
              loop (arr, piles, j, i)
          end
    in
      loop (arr, piles, g1u2u 0u, pred num_piles)
    end

fn {a : t@ype}
deal {ifirst, len : int}
     {n           : int | ifirst + len <= n}
     (ifirst      : size_t ifirst,
      len         : size_t len,
      arr         : &RD(array (a, n)),
      piles       : &array (link_t (ifirst, len)?, len)
                      >> array (link_t (ifirst, len), len),
      links       : &array (link_t (ifirst, len)?, len)
                      >> array (link_t (ifirst, len), len))
    :<!wrt> [num_piles   : int | num_piles <= len]
            size_t num_piles =
  let
    prval () = lemma_g1uint_param ifirst
    prval () = lemma_g1uint_param len

    typedef link_t (i : int) = link_t (ifirst, len, i)
    typedef link_t = link_t (ifirst, len)

    val zero : size_t 0 = g1u2u 0u
    val one : size_t 1 = g1u2u 1u
    val link_nil : link_t 0 = g1u2u 0u

    fun
    loop {q         : pos | q <= len + 1}
         {m         : nat | m <= len}
         .<len + 1 - q>.
         (arr       : &RD(array (a, n)),
          q         : size_t q,
          piles     : &array (link_t, len) >> _,
          links     : &array (link_t, len) >> _,
          m         : size_t m)
        :<!wrt> [num_piles : nat | num_piles <= len]
                size_t num_piles =
      if q = succ (len) then
        m
      else
        let
          val i = find_pile {ifirst, len} (ifirst, arr, m, piles, q)

          (* We have no proof the number of elements will not exceed
             storage. However, we know it will not, because the number
             of piles cannot exceed the size of the input. Let us get
             a "proof" by runtime check. *)
          val () = $effmask_exn assertloc (i <= len)
        in
          links[pred q] := piles[pred i];
          piles[pred i] := q;
          if i = succ m then
            loop {q + 1} (arr, succ q, piles, links, succ m)
          else
            loop {q + 1} (arr, succ q, piles, links, m)
        end
  in
    array_initize_elt<link_t> (piles, len, link_nil);
    array_initize_elt<link_t> (links, len, link_nil);
    loop (arr, one, piles, links, zero)
  end

fn {a : t@ype}
k_way_merge {ifirst, len : int}
            {n           : int | ifirst + len <= n}
            {num_piles   : pos | num_piles <= len}
            {power       : int | len <= power}
            (pf_exp2     : [exponent : nat] EXP2 (exponent, power) |
             arr         : &RD(array (a, n)),
             ifirst      : size_t ifirst,
             len         : size_t len,
             num_piles   : size_t num_piles,
             power       : size_t power,
             piles       : &array (link_t (ifirst, len), len) >> _,
             links       : &RD(array (link_t (ifirst, len), len)),
             winvals     : &array (link_t (ifirst, len)?, 2 * power)
                              >> _,
             winlinks    : &array (link_t (ifirst, len)?, 2 * power)
                              >> _,
             sorted      : &array (index_t (ifirst, len)?, len)
                              >> array (index_t (ifirst, len), len))
    :<!wrt> void =
  (*
    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.
  *)
  let
    prval () = lemma_g1uint_param ifirst
    prval () = lemma_g1uint_param len

    typedef link_t (i : int) = link_t (ifirst, len, i)
    typedef link_t = link_t (ifirst, len)

    val link_nil : link_t 0 = g1u2u 0u

    typedef index_t (i : int) = index_t (ifirst, len, i)
    typedef index_t = index_t (ifirst, len)

    val [total_external_nodes : int]
        @(_ | total_external_nodes) = next_power_of_two num_piles
    prval () = prop_verify {num_piles <= total_external_nodes} ()

    stadef total_nodes = (2 * total_external_nodes) - 1
    val total_nodes : size_t total_nodes =
      pred (g1u2u 2u * total_external_nodes)

    (* We will ignore index 0 of the winners tree arrays. *)
    stadef winners_size = total_nodes + 1
    val winners_size : size_t winners_size = succ total_nodes

    (* An exercise for the reader is to write a proof that
       winners_size <= 2 * power, so one can get rid of the
       runtime assertion here: *)
    val () = $effmask_exn assertloc (winners_size <= 2 * power)

    prval @(winvals_left, winvals_right) =
      array_v_split {link_t?} {..} {2 * power} {winners_size}
                    (view@ winvals)
    prval () = view@ winvals := winvals_left

    prval @(winlinks_left, winlinks_right) =
      array_v_split {link_t?} {..} {2 * power} {winners_size}
                    (view@ winlinks)
    prval () = view@ winlinks := winlinks_left

    val () = array_initize_elt<link_t> (winvals, winners_size,
                                        link_nil)
    val () = array_initize_elt<link_t> (winlinks, winners_size,
                                        link_nil)


    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* Record which pile a winner will have come from.     *)

    fun
    init_pile_links
              {i : nat | i <= num_piles}
              .<num_piles - i>.
              (winlinks : &array (link_t, winners_size),
               i        : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        begin
          winlinks[total_external_nodes + i] := succ i;
          init_pile_links (winlinks, succ i)
        end

    val () = init_pile_links (winlinks, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* The top of each pile becomes a starting competitor. *)

    fun
    init_competitors
              {i : nat | i <= num_piles}
              .<num_piles - i>.
              (winvals : &array (link_t, winners_size),
               piles   : &array (link_t, len),
               i       : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        begin
          winvals[total_external_nodes + i] := piles[i];
          init_competitors (winvals, piles, succ i)
        end
 
    val () = init_competitors (winvals, piles, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* Discard the top of each pile.                       *)

    fun
    discard_tops {i : nat | i <= num_piles}
                 .<num_piles - i>.
                 (piles : &array (link_t, len),
                  links : &array (link_t, len),
                  i     : size_t i)
        :<!wrt> void =
      if i <> num_piles then
        let
          val link = piles[i]

          (* None of the piles should have been empty. *)
          val () = $effmask_exn assertloc (link <> g1u2u 0u)
        in
          piles[i] := links[pred link];
          discard_tops (piles, links, succ i)
        end

    val () = discard_tops (piles, links, g1u2u 0u)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)
    (* How to play a game.                                 *)
    
    fn
    play_game {i       : int | 2 <= i; i <= total_nodes}
              (arr     : &RD(array (a, n)),
               winvals : &array (link_t, winners_size),
               i       : size_t i)
        :<> [iwinner : pos | iwinner <= total_nodes]
            size_t iwinner =
      let
        macdef lt = patience_sort$lt<a>

        fn
        find_opponent {i : int | 2 <= i; i <= total_nodes}
                      (i : size_t i)
            :<> [j : int | 2 <= j; j <= total_nodes]
                size_t j =
          let
            (* The prelude contains bitwise operations only for
               non-dependent unsigned integer. We will not bother to
               add them ourselves, but instead go back and forth
               between dependent and non-dependent. *)
            val i0 = g0ofg1 i
            val j0 = g0uint_lxor<size_kind> (i0, g0u2u 1u)
            val j = g1ofg0 j0

            (* We have no proof the opponent is in the proper
               range. Create a "proof" by runtime checks. *)
            val () = $effmask_exn assertloc (g1u2u 2u <= j)
            val () = $effmask_exn assertloc (j <= total_nodes)
          in
            j
          end

        val j = find_opponent i
        val winner_i = winvals[i]
        and winner_j = winvals[j]
      in
        if winner_i = link_nil then
          j
        else if winner_j = link_nil then
          i
        else
          let
            val i1 = pred winner_i + ifirst
            and i2 = pred winner_j + ifirst
            prval () = lemma_g1uint_param i1
            prval () = lemma_g1uint_param i2
          in
            if arr[i2] \lt arr[i1] then j else i
          end
      end

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)

    fun
    build_tree {istart : pos | istart <= total_external_nodes}
               .<istart>.
               (arr      : &RD(array (a, n)),
                winvals  : &array (link_t, winners_size),
                winlinks : &array (link_t, winners_size),
                istart   : size_t istart)
        :<!wrt> void =
      if istart <> 1 then
        let
          fun
          play_initial_games
                    {i : int | istart <= i; i <= (2 * istart) + 1}
                    .<(2 * istart) + 1 - i>.
                    (arr      : &RD(array (a, n)),
                     winvals  : &array (link_t, winners_size),
                     winlinks : &array (link_t, winners_size),
                     i        : size_t i)
              :<!wrt> void =
            if i <= pred (istart + istart) then
              let
                val iwinner = play_game (arr, winvals, i)
                and i2 = i / g1u2u 2u
              in
                winvals[i2] := winvals[iwinner];
                winlinks[i2] := winlinks[iwinner];
                play_initial_games (arr, winvals, winlinks,
                                    succ (succ i))
              end
        in
          play_initial_games (arr, winvals, winlinks, istart);
          build_tree (arr, winvals, winlinks, istart / g1u2u 2u)
        end

    val () = build_tree (arr, winvals, winlinks, total_external_nodes)

    (* - - - - - - - - - - - - - - - - - - - - - - - - - - *)

    fun
    replay_games {i : pos | i <= total_nodes}
                 .<i>.
                 (arr      : &RD(array (a, n)),
                  winvals  : &array (link_t, winners_size),
                  winlinks : &array (link_t, winners_size),
                  i        : size_t i)
        :<!wrt> void =
      if i <> g1u2u 1u then
        let
          val iwinner = play_game (arr, winvals, i)
          and i2 = i / g1u2u 2u
        in
          winvals[i2] := winvals[iwinner];
          winlinks[i2] := winlinks[iwinner];
          replay_games (arr, winvals, winlinks, i2)
        end

    fun
    merge {isorted  : nat | isorted <= len}
          {p_sorted : addr}
          .<len - isorted>.
          (pf_sorted : !array_v (index_t?, p_sorted,
                                 len - isorted)
                          >> array_v (index_t, p_sorted,
                                      len - isorted) |
           arr       : &RD(array (a, n)),
           piles     : &array (link_t, len),
           links     : &array (link_t, len),
           winvals   : &array (link_t, winners_size),
           winlinks  : &array (link_t, winners_size),
           p_sorted  : ptr p_sorted,
           isorted   : size_t isorted)
        :<!wrt> void =
      (* This function not only fills in the "sorted" array, but
         transforms it from "uninitialized" to "initialized". *)
      if isorted <> len then
        let
          prval @(pf_elem, pf_rest) = array_v_uncons pf_sorted
          val winner = winvals[1]
          val () = $effmask_exn assertloc (winner <> link_nil)
          val () = !p_sorted := pred winner + ifirst

          (* Move to the next element in the winner's pile. *)
          val ilink = winlinks[1]
          val () = $effmask_exn assertloc (ilink <> link_nil)
          val inext = piles[pred ilink]
          val () = (if inext <> link_nil then
                      piles[pred ilink] := links[pred inext])

          (* Replay games, with the new element as a competitor. *)
          val i = (total_nodes / g1u2u 2u) + ilink
          val () = $effmask_exn assertloc (i <= total_nodes)
          val () = winvals[i] := inext
          val () = replay_games (arr, winvals, winlinks, i)

          val () = merge (pf_rest |
                          arr, piles, links, winvals, winlinks,
                          ptr_succ<index_t> p_sorted, succ isorted)
          prval () = pf_sorted := array_v_cons (pf_elem, pf_rest)
        in
        end
      else
        let
          prval () = pf_sorted :=
            array_v_unnil_nil{index_t?, index_t} pf_sorted
        in
        end

    val () = merge (view@ sorted |
                    arr, piles, links, winvals, winlinks,
                    addr@ sorted, i2sz 0)

    prval () =
      array_uninitize_without_doing_anything<link_t>
        (winvals, winners_size)
    prval () =
      array_uninitize_without_doing_anything<link_t>
        (winlinks, winners_size)
    prval () = view@ winvals :=
      array_v_unsplit (view@ winvals, winvals_right)
    prval () = view@ winlinks :=
      array_v_unsplit (view@ winlinks, winlinks_right)
  in
  end

implement {a}
patience_sort_given_workspaces
          {ifirst, len} {n} {power}
          {n_piles} {n_links} {n_winv} {n_winl}
          (pf_exp2 | arr, ifirst, len, power,
                     piles, links, winvals, winlinks,
                     sorted) =
  let
    prval () = lemma_g1uint_param ifirst
    prval () = lemma_g1uint_param len

    typedef index_t = index_t (ifirst, len)
    typedef link_t = link_t (ifirst, len)
  in
    if len = i2sz 0 then
      let
        prval () = view@ sorted :=
          array_v_unnil_nil{index_t?, index_t} (view@ sorted)
      in
      end
    else
      let
        prval @(piles_left, piles_right) =
          array_v_split {link_t?} {..} {n_piles} {len} (view@ piles)
        prval () = view@ piles := piles_left

        prval @(links_left, links_right) =
          array_v_split {link_t?} {..} {n_links} {len} (view@ links)
        prval () = view@ links := links_left

        prval @(winvals_left, winvals_right) =
          array_v_split {link_t?} {..} {n_winv} {2 * power}
                        (view@ winvals)
        prval () = view@ winvals := winvals_left

        prval @(winlinks_left, winlinks_right) =
          array_v_split {link_t?} {..} {n_winl} {2 * power}
                        (view@ winlinks)
        prval () = view@ winlinks := winlinks_left

        val num_piles =
          deal {ifirst, len} {n} (ifirst, len, arr, piles, links)
        prval () = lemma_g1uint_param num_piles
        val () = $effmask_exn assertloc (num_piles <> i2sz 0)

        val () =
          k_way_merge {ifirst, len} {n} {..} {power}
                      (pf_exp2 | arr, ifirst, len, num_piles, power,
                                 piles, links, winvals, winlinks,
                                 sorted)

        prval () =
          array_uninitize_without_doing_anything<link_t>
            (piles, len)
        prval () =
          array_uninitize_without_doing_anything<link_t>
            (links, len)

        prval () = view@ piles :=
          array_v_unsplit (view@ piles, piles_right)
        prval () = view@ links :=
          array_v_unsplit (view@ links, links_right)
        prval () = view@ winvals :=
          array_v_unsplit (view@ winvals, winvals_right)
        prval () = view@ winlinks :=
          array_v_unsplit (view@ winlinks, winlinks_right)
      in
      end
  end

(* ================================================================ *)
(* An interface that provides the workspaces. If the subarray to    *)
(* be sorted is small enough, stack storage will be used.           *)

#define LEN_THRESHOLD 128
#define WINNERS_SIZE  256

prval () = prop_verify {WINNERS_SIZE == 2 * LEN_THRESHOLD} ()

local
  prval pf_exp2 = EXP2bas ()      (*   1*)
  prval pf_exp2 = EXP2ind pf_exp2 (*   2 *)
  prval pf_exp2 = EXP2ind pf_exp2 (*   4 *)
  prval pf_exp2 = EXP2ind pf_exp2 (*   8 *)
  prval pf_exp2 = EXP2ind pf_exp2 (*  16 *)
  prval pf_exp2 = EXP2ind pf_exp2 (*  32 *)
  prval pf_exp2 = EXP2ind pf_exp2 (*  64 *)
  prval pf_exp2 = EXP2ind pf_exp2 (* 128 *)
in
  prval pf_exp2_for_stack_storage = pf_exp2
end

implement {a}
patience_sort_with_its_own_workspaces
          {ifirst, len} {n} (arr, ifirst, len, sorted) =
  let
    prval () = lemma_g1uint_param ifirst
    prval () = lemma_g1uint_param len

    typedef link_t = link_t (ifirst, len)

    fn
    sort {ifirst, len : int | 0 <= ifirst}
         {n        : int | ifirst + len <= n}
         {power    : int | len <= power}
         {n_piles  : int | len <= n_piles}
         {n_links  : int | len <= n_links}
         {n_winv   : int | 2 * power <= n_winv}
         {n_winl   : int | 2 * power <= n_winl}
         (pf_exp2  : [exponent : nat] EXP2 (exponent, power) |
          arr      : &RD(array (a, n)),
          ifirst   : size_t ifirst,
          len      : size_t len,
          power    : size_t power,
          piles    : &array (link_t (ifirst, len)?, n_piles) >> _,
          links    : &array (link_t (ifirst, len)?, n_links) >> _,
          winvals  : &array (link_t (ifirst, len)?, n_winv) >> _,
          winlinks : &array (link_t (ifirst, len)?, n_winl) >> _,
          sorted   : &array (index_t (ifirst, len)?, len)
                       >> array (index_t (ifirst, len), len))
        :<!wrt> void =
      patience_sort_given_workspaces<a>
        {ifirst, len} {n} {power}
        {n_piles} {n_links} {n_winv} {n_winl}
        (pf_exp2 | arr, ifirst, len, power, piles, links,
                   winvals, winlinks, sorted)
  in
    if len <= i2sz LEN_THRESHOLD then
      let
        var piles : array (link_t?, LEN_THRESHOLD)
        var links : array (link_t?, LEN_THRESHOLD)
        var winvals : array (link_t?, WINNERS_SIZE)
        var winlinks : array (link_t?, WINNERS_SIZE)
      in
        sort (pf_exp2_for_stack_storage |
              arr, ifirst, len, i2sz LEN_THRESHOLD,
              piles, links, winvals, winlinks, sorted)
      end
    else
      let
        val @(pf_piles, pfgc_piles | p_piles) =
          array_ptr_alloc<link_t> len
        val @(pf_links, pfgc_links | p_links) =
          array_ptr_alloc<link_t> len

        val @(pf_exp2 | power) = next_power_of_two<size_kind> len

        val @(pf_winvals, pfgc_winvals | p_winvals) =
          array_ptr_alloc<link_t> (power + power)
        val @(pf_winlinks, pfgc_winlinks | p_winlinks) =
          array_ptr_alloc<link_t> (power + power)

        macdef piles = !p_piles
        macdef links = !p_links
        macdef winvals = !p_winvals
        macdef winlinks = !p_winlinks
      in
        sort (pf_exp2 |
              arr, ifirst, len, power, piles, links,
              winvals, winlinks, sorted);
        array_ptr_free (pf_piles, pfgc_piles | p_piles);
        array_ptr_free (pf_links, pfgc_links | p_links);
        array_ptr_free (pf_winvals, pfgc_winvals | p_winvals);
        array_ptr_free (pf_winlinks, pfgc_winlinks | p_winlinks)
      end
  end

(* ================================================================ *)
(* A demonstration program.                                         *)

fn {a : t@ype}
find_length {n   : int}
            (lst : list (a, n))
    :<> [m : int | m == n] size_t m =
  let
    prval () = lemma_list_param lst
  in
    g1i2u (length lst)
  end

implement
main0 () =
  let
    implement
    patience_sort$lt<int> (x, y) =
      x < y

    val example_list =
      $list (22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, 46, 54,
             93, 8, 54, 2, 72, 84, 86, 76, 53, 37, 90)

    val ifirst = i2sz 10
    val [len : int] len = find_length example_list

    #define ARRSZ 100
    val () = assertloc (i2sz 10 + len <= ARRSZ)

    var arr : array (int, ARRSZ)
    val () = array_initize_elt<int> (arr, i2sz ARRSZ, 0)

    prval @(pf_left, pf_right) =
      array_v_split {int} {..} {ARRSZ} {10} (view@ arr)
    prval @(pf_middle, pf_right) =
      array_v_split {int} {..} {90} {len} pf_right

    val p = ptr_add<int> (addr@ arr, 10)
    val () = array_copy_from_list<int> (!p, example_list)

    prval pf_right = array_v_unsplit (pf_middle, pf_right)
    prval () = view@ arr := array_v_unsplit (pf_left, pf_right)

    typedef index_t = patience_sort_index (10, len)

    var sorted : array (index_t, ARRSZ)
    val () = array_initize_elt<index_t> (sorted, i2sz ARRSZ,
                                         g1u2u 10u)
    
    prval @(sorted_left, sorted_right) =
      array_v_split {index_t} {..} {ARRSZ} {len} (view@ sorted)
    prval () = view@ sorted := sorted_left

    val () = patience_sort<int> (arr, i2sz 10, len, sorted)

    prval () = view@ sorted :=
      array_v_unsplit (view@ sorted, sorted_right)

    var i : [i : nat | i <= len] size_t i
  in
    print! ("unsorted  ");
    for (i := i2sz 0; i <> len; i := succ i)
      print! (" ", arr[i2sz 10 + i]);
    println! ();

    print! ("sorted    ");
    for (i := i2sz 0; i <> len; i := succ i)
      print! (" ", arr[sorted[i]]);
    println! ()
  end

(*------------------------------------------------------------------*)
Output:
$ patscc -O3 -DATS_MEMALLOC_LIBC patience_sort_task_provided_storage.dats && ./a.out
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

A patience sort for non-linear lists of integers, guaranteeing a sorted result

This implementation borrows code from a mergesort that also guarantees a sorted result.

The mergesort proves the result has the same length as the original, but this patience sort does not.

//--------------------------------------------------------------------
//
//  A patience sort for 32-bit signed integers.
//
//  This implementation proves that result is sorted, though it
//  does not prove that the result is of the same length as the
//  original.
//
//--------------------------------------------------------------------

#include "share/atspre_staload.hats"

(*------------------------------------------------------------------*)

#define ENTIER_MAX 2147483647

(* We do not include the most negative two's-complement number. *)
stadef entier (i : int) = ~ENTIER_MAX <= i && i <= ENTIER_MAX
sortdef entier          = {i : int | entier i}

typedef entier (i : int) = [entier i] int i
typedef entier           = [i : entier] entier i

datatype sorted_entier_list (int, int) =
| sorted_entier_list_nil (0, ENTIER_MAX)
| {n : nat}
  {i, j : entier | ~(j < i)}
  sorted_entier_list_cons (n + 1, i) of
    (entier i, sorted_entier_list (n, j))
typedef sorted_entier_list (n : int) =
  [i : entier] sorted_entier_list (n, i)
typedef sorted_entier_list =
  [n : int] sorted_entier_list n

infixr ( :: ) :::
#define NIL  list_nil ()
#define ::   list_cons
#define SNIL sorted_entier_list_nil ()
#define :::  sorted_entier_list_cons

(*------------------------------------------------------------------*)

extern prfn
lemma_sorted_entier_list_param
          {n   : int}
          (lst : sorted_entier_list n)
    :<prf> [0 <= n] void

extern fn
sorted_entier_list_merge
          {m, n : int}
          {i, j : entier}
          (lst1 : sorted_entier_list (m, i),
           lst2 : sorted_entier_list (n, j))
    :<> sorted_entier_list (m + n, min (i, j))

extern fn
entier_list_patience_sort
          {n   : int}
          (lst : list (entier, n)) (* An ordinary list. *)
    :<!wrt> sorted_entier_list     (* No proof of the length. *)

extern fn
sorted_entier_list2list
          {n   : int}
          (lst : sorted_entier_list n)
    :<> list (entier, n)

overload merge with sorted_entier_list_merge
overload patience_sort with entier_list_patience_sort
overload to_list with sorted_entier_list2list

(*------------------------------------------------------------------*)

primplement
lemma_sorted_entier_list_param {n} lst =
  case+ lst of
  | SNIL => ()
  | _ ::: _ => ()

implement
sorted_entier_list_merge (lst1, lst2) =
  (* This implementation is *NOT* tail recursive. It will use O(m+n)
     stack space. *)
  let
    fun
    recurs {m, n : nat}
           {i, j : entier} .<m + n>.
           (lst1 : sorted_entier_list (m, i),
            lst2 : sorted_entier_list (n, j))
        :<> sorted_entier_list (m + n, min (i, j)) =
      case+ lst1 of
      | SNIL => lst2
      | i ::: tail1 =>
        begin
          case+ lst2 of
          | SNIL => lst1
          | j ::: tail2 =>
            if ~(j < i) then
              i ::: recurs (tail1, lst2)
            else
              j ::: recurs (lst1, tail2)
        end

    prval () = lemma_sorted_entier_list_param lst1
    prval () = lemma_sorted_entier_list_param lst2
  in
    recurs (lst1, lst2)
  end

implement
entier_list_patience_sort {n} lst =
  let
    prval () = lemma_list_param lst
    val n : int n = length lst
  in
    if n = 0 then
      SNIL
    else if n = 1 then
      let
        val+ head :: NIL = lst
      in
        head ::: SNIL
      end
    else
      let
        val @(pf, pfgc | p) =
          array_ptr_alloc<sorted_entier_list> (i2sz n)
        macdef piles = !p
        val () = array_initize_elt (piles, i2sz n, SNIL)

        fn
        find_pile {m         : nat | m <= n}
                  {x         : entier}
                  (num_piles : int m,
                   piles     : &array (sorted_entier_list, n),
                   x         : entier x)
            :<> [i   : nat | i < n]
                [len : int]
                [y   : entier | ~(y < x)]
                @(int i, sorted_entier_list (len, y)) =
          //
          // Bottenbruch search for the leftmost pile whose top is
          // greater than or equal to some element x.
          //
          // 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
          //
          let
            fun
            loop {j, k  : nat | j < k; k < m}
                 {x     : entier} .<k - j>.
                 (piles : &array (sorted_entier_list, n),
                  j     : int j,
                  k     : int k,
                  x     : entier x)
                :<> [i   : nat | i < n]
                    [len : int]
                    [y   : entier | ~(y < x)]
                    @(int i, sorted_entier_list (len, y)) =
              let
                val i = j + g1int_ndiv (k - j, 2)
                val pile = piles[i]
                val- head ::: _ = pile
              in
                if head < x then
                  begin
                    if succ i <> k then
                      loop (piles, succ i, k, x)
                    else
                      let
                        val pile1 = piles[k]
                      in
                        case- pile1 of
                        | head1 ::: _ =>
                          if head1 < x then
                            let
                              (* Runtime check for buffer overrun. *)
                              val () =
                                $effmask_exn assertloc (k + 1 < n)
                            in
                              (* No pile satisfies the binary search.
                                 Start a new pile. *)
                              @(k + 1, SNIL)
                            end
                          else
                            @(k, pile1)
                      end
                  end
                else
                  begin
                    if j <> i then
                      loop (piles, j, i, x)
                    else
                      @(j, pile)
                  end
              end
          in
            if 1 < num_piles then
              let
                prval () = prop_verify {m >= 1} ()
              in
                loop (piles, 0, pred num_piles, x)
              end
            else if num_piles = 1 then
              let
                prval () = prop_verify {m == 1} ()
                val pile = piles[0]
              in
                case- pile of
                | head ::: _ =>
                  if head < x then
                    @(1, SNIL)
                  else
                    @(0, pile)
              end
            else
              let
                prval () = prop_verify {m == 0} ()
              in
                @(0, SNIL)
              end
          end

        fun
        deal {m         : nat | m <= n}
             {j         : nat | j <= n} .<m>.
             (num_piles : &int j >> int k,
              piles     : &array (sorted_entier_list, n) >> _,
              lst       : list (entier, m))
            :<!wrt> #[k : nat | j <= k; k <= n] void =
          (* This implementation verifies at compile time that the
             piles are sorted. *)
          case+ lst of
          | NIL => ()
          | head :: tail =>
            let
              val @(i, pile) = find_pile (num_piles, piles, head)
              prval () = lemma_sorted_entier_list_param pile
            in
              piles[i] := head ::: pile;
              num_piles := max (num_piles, succ i);
              deal (num_piles, piles, tail);
            end

        fun
        make_list_of_piles
                  {num_piles, i : nat | num_piles <= n;
                                        i <= num_piles}
                  .<num_piles - i>.
                  (num_piles : int num_piles,
                   piles     : &array (sorted_entier_list, n),
                   i         : int i)
            :<> [m : nat] @(list (sorted_entier_list, m), int m) =
          (* I do NOT bother to make this implementation tail
             recursive. *)
          if i = num_piles then
            @(NIL, 0)
          else
            let
              val @(lst, m) =
                make_list_of_piles (num_piles, piles, succ i)
            in
              @(piles[i] :: lst, succ m)
            end

        var num_piles : Int = 0
        val () = deal (num_piles, piles, lst)
        val @(list_of_piles, m) =
          make_list_of_piles (num_piles, piles, 0)

        val () = array_ptr_free (pf, pfgc | p)

        fun
        merge_piles {m             : nat} .<m>.
                    (list_of_piles : list (sorted_entier_list, m),
                     m             : int m)
            :<!wrt> sorted_entier_list =
          (* This is essentially the same algorithm as a
             NON-tail-recursive mergesort. *)
          if m = 1 then
            let
              val+ sorted_lst :: NIL = list_of_piles
            in
              sorted_lst
            end
          else if m = 0 then
            SNIL
          else
            let
              val m_left = m \g1int_ndiv 2
              val m_right = m - m_left
              val @(left, right) =
                list_split_at (list_of_piles, m_left)
              val left = merge_piles (list_vt2t left, m_left)
              and right = merge_piles (right, m_right)
            in
              left \merge right
            end
      in
        merge_piles (list_of_piles, m)
      end
  end

implement
sorted_entier_list2list lst =
  (* This implementation is *NOT* tail recursive. It will use O(n)
     stack space. *)
  let
    fun
    recurs {n   : nat} .<n>.
           (lst : sorted_entier_list n)
        :<> list (entier, n) =
      case+ lst of
      | SNIL => NIL
      | head ::: tail => head :: recurs tail

    prval () = lemma_sorted_entier_list_param lst
  in
    recurs lst
  end

(*------------------------------------------------------------------*)

fn
print_Int_list
          {n   : int}
          (lst : list (Int, n))
    : void =
  let
    fun
    loop {n   : nat} .<n>.
         (lst : list (Int, n))
        : void =
      case+ lst of
      | NIL => ()
      | head :: tail =>
        begin
          print! (" ");
          print! (head);
          loop tail
        end
    prval () = lemma_list_param lst
  in
    loop lst
  end

implement
main0 () =
  let
    val example_list =
      $list (22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, 46, 54,
             93, 8, 54, 2, 72, 84, 86, 76, 53, 37, 90)
    val sorted_list = patience_sort example_list
  in
    print! ("unsorted  ");
    print_Int_list example_list;
    println! ();
    print! ("sorted    ");
    print_Int_list (to_list sorted_list);
    println! ()
  end

(*------------------------------------------------------------------*)
Output:
$ patscc -O3 -DATS_MEMALLOC_GCBDW patience_sort_task_verified.dats -lgc && ./a.out
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

AutoHotkey

PatienceSort(A){
    P:=0, Pile:=[], Result:=[]
    for k, v in A
    {
        Pushed := 0
        loop % P 
        {
            i := A_Index
            if Pile[i].Count() && (Pile[i, 1] >= v)
            {
                Pile[i].InsertAt(1, v)
                pushed := true
                break
            }
        }
        if Pushed
            continue
        P++
        Pile[p] := []
        Pile[p].InsertAt(1, v)
    }
    
    ; optional to show steps ;;;;;;;;;;;;;;;;;;;;;;;
    loop % P 
    {
        i := A_Index, step := ""
        for k, v in Pile[i]
            step .= v ", "
        step := "Pile" i " = "  Trim(step, ", ")
        steps .= step "`n"
    }
    MsgBox % steps
    ; end optional ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
    loop % A.Count()
    {
        Collect:=[]
        loop % P
            if Pile[A_index].Count()
                Collect.Push(Pile[A_index, 1])
            
        for k, v in Collect
            if k=1
                m := v
            else if (v < m)
            {
                m := v
                break
            }
                
        Result.push(m)
        loop % P
            if (m = Pile[A_index, 1])
            {
                Pile[A_index].RemoveAt(1)
                break
            }
    }
    return Result
}
Examples:
Test := [[4, 65, 2, -31, 0, 99, 83, 782, 1]
        ,["n", "o", "n", "z", "e", "r", "o", "s", "u", "m"]
        ,["dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"]]

for i, v in Test{
    X := PatienceSort(V)
    output := ""
    for k, v in X
        output .= v ", "
    MsgBox % "[" Trim(output, ", ") "]"
}
return
Output:
Pile1 = [-31, 2, 4]
Pile2 = [0, 65]
Pile3 = [1, 83, 99]
Pile4 = [782]
Result = [-31, 0, 1, 2, 4, 65, 83, 99, 782]
----------------------------------
Pile1 = [e, n, n]
Pile2 = [m, o, o]
Pile3 = [r, z]
Pile4 = [s]
Pile5 = [u]
Result = [e, m, n, n, o, o, r, s, u, z]
----------------------------------
Pile1 = [ant, ape, cat, cow, dog]
Pile2 = [ass, man]
Pile3 = [gnu, pig]
Result = [ant, ape, ass, cat, cow, dog, gnu, man, pig]

C

Takes integers as input, prints out usage on incorrect invocation

#include<stdlib.h>
#include<stdio.h>

int* patienceSort(int* arr,int size){
	int decks[size][size],i,j,min,pickedRow;
	
	int *count = (int*)calloc(sizeof(int),size),*sortedArr = (int*)malloc(size*sizeof(int));
	
	for(i=0;i<size;i++){
		for(j=0;j<size;j++){
			if(count[j]==0 || (count[j]>0 && decks[j][count[j]-1]>=arr[i])){
				decks[j][count[j]] = arr[i];
				count[j]++;
				break;
			}
		}
	}
	
	min = decks[0][count[0]-1];
	pickedRow = 0;
	
	for(i=0;i<size;i++){
		for(j=0;j<size;j++){
			if(count[j]>0 && decks[j][count[j]-1]<min){
				min = decks[j][count[j]-1];
				pickedRow = j;
			}
		}
		sortedArr[i] = min;
		count[pickedRow]--;
		
		for(j=0;j<size;j++)
			if(count[j]>0){
				min = decks[j][count[j]-1];
				pickedRow = j;
				break;
			}
	}
	
	free(count);
	free(decks);
	
	return sortedArr;
}

int main(int argC,char* argV[])
{
	int *arr, *sortedArr, i;
	
	if(argC==0)
		printf("Usage : %s <integers to be sorted separated by space>");
	else{
		arr = (int*)malloc((argC-1)*sizeof(int));
		
		for(i=1;i<=argC;i++)
			arr[i-1] = atoi(argV[i]);
		
		sortedArr = patienceSort(arr,argC-1);
		
		for(i=0;i<argC-1;i++)
			printf("%d ",sortedArr[i]);
	}
	
	return 0;
}

Invocation and output :

C:\rosettaCode>patienceSort.exe 4 65 2 -31 0 99 83 781 1
-31 0 1 2 4 65 83 99 781

C++

#include <iostream>
#include <vector>
#include <stack>
#include <iterator>
#include <algorithm>
#include <cassert>

template <class E>
struct pile_less {
  bool operator()(const std::stack<E> &pile1, const std::stack<E> &pile2) const {
    return pile1.top() < pile2.top();
  }
};

template <class E>
struct pile_greater {
  bool operator()(const std::stack<E> &pile1, const std::stack<E> &pile2) const {
    return pile1.top() > pile2.top();
  }
};


template <class Iterator>
void patience_sort(Iterator first, Iterator last) {
  typedef typename std::iterator_traits<Iterator>::value_type E;
  typedef std::stack<E> Pile;

  std::vector<Pile> piles;
  // sort into piles
  for (Iterator it = first; it != last; it++) {
    E& x = *it;
    Pile newPile;
    newPile.push(x);
    typename std::vector<Pile>::iterator i =
      std::lower_bound(piles.begin(), piles.end(), newPile, pile_less<E>());
    if (i != piles.end())
      i->push(x);
    else
      piles.push_back(newPile);
  }

  // priority queue allows us to merge piles efficiently
  // we use greater-than comparator for min-heap
  std::make_heap(piles.begin(), piles.end(), pile_greater<E>());
  for (Iterator it = first; it != last; it++) {
    std::pop_heap(piles.begin(), piles.end(), pile_greater<E>());
    Pile &smallPile = piles.back();
    *it = smallPile.top();
    smallPile.pop();
    if (smallPile.empty())
      piles.pop_back();
    else
      std::push_heap(piles.begin(), piles.end(), pile_greater<E>());
  }
  assert(piles.empty());
}

int main() {
  int a[] = {4, 65, 2, -31, 0, 99, 83, 782, 1};
  patience_sort(a, a+sizeof(a)/sizeof(*a));
  std::copy(a, a+sizeof(a)/sizeof(*a), std::ostream_iterator<int>(std::cout, ", "));
  std::cout << std::endl;
  return 0;
}
Output:
-31, 0, 1, 2, 4, 65, 83, 99, 782, 

Clojure

(defn patience-insert
  "Inserts a value into the sequence where each element is a stack.
   Comparison replaces the definition of less than.
   Uses the greedy strategy."
  [comparison sequence value]
  (lazy-seq
   (if (empty? sequence) `((~value)) ;; If there are no places to put the "card", make a new stack
       (let [stack (first sequence)  
             top       (peek stack)]
         (if (comparison value top)
           (cons (conj stack value)  ;; Either put the card in a stack or recurse to the next stack
                 (rest sequence))   
           (cons stack               
                 (patience-insert comparison
                                  (rest sequence)
                                  value)))))))
 
(defn patience-remove
  "Removes the value from the top of the first stack it shows up in.
   Leaves the stacks otherwise intact."
  [sequence value]
  (lazy-seq
   (if (empty? sequence) nil              ;; If there are no stacks, we have no work to do
       (let [stack (first sequence)
             top       (peek stack)]
         (if (= top value)                ;; Are we there yet?
           (let [left-overs (pop stack)]  
             (if (empty? left-overs)      ;; Handle the case that the stack is empty and needs to be removed
               (rest sequence)            
               (cons left-overs           
                     (rest sequence))))   
           (cons stack                    
                 (patience-remove (rest sequence)
                                  value)))))))
 
(defn patience-recover
  "Builds a sorted sequence from a list of patience stacks.
   The given comparison takes the place of 'less than'"
  [comparison sequence]
  (loop [sequence sequence
         sorted         []]
    (if (empty? sequence) sorted 
        (let [smallest  (reduce #(if (comparison %1 %2) %1 %2)  ;; Gets the smallest element in the list
                                (map peek sequence))            
              remaining    (patience-remove sequence smallest)] 
          (recur remaining                    
                 (conj sorted smallest)))))) ;; Recurse over the remaining values and add the new smallest to the end of the sorted list
 
(defn patience-sort
  "Sorts the sequence by comparison.
   First builds the list of valid patience stacks.
   Then recovers the sorted list from those.
   If you don't supply a comparison, assumes less than."
  ([comparison sequence]
     (->> (reduce (comp doall ;; This is prevent a stack overflow by making sure all work is done when it needs to be
                        (partial patience-insert comparison)) ;; Insert all the values into the list of stacks
                  nil                                         
                  sequence)
          (patience-recover comparison)))              ;; After we have the stacks, send it off to recover the sorted list
  ([sequence]
     ;; In the case we don't have an operator, defer to ourselves with less than
     (patience-sort < sequence)))
 
;; Sort the test sequence and print it
(println (patience-sort [4 65 2 -31 0 99 83 782 1]))
Output:
[-31 0 1 2 4 65 83 99 782]

D

Translation of: Python
import std.stdio, std.array, std.range, std.algorithm;

void patienceSort(T)(T[] items) /*pure nothrow @safe*/
if (__traits(compiles, T.init < T.init)) {
    //SortedRange!(int[][], q{ a.back < b.back }) piles;
    T[][] piles;

    foreach (x; items) {
        auto p = [x];
        immutable i = piles.length -
                      piles
                      .assumeSorted!q{ a.back < b.back }
                      .upperBound(p)
                      .length;
        if (i != piles.length)
            piles[i] ~= x;
        else
            piles ~= p;
    }

    piles.nWayUnion!q{ a > b }.copy(items.retro);
}

void main() {
    auto data = [4, 65, 2, -31, 0, 99, 83, 782, 1];
    data.patienceSort;
    assert(data.isSorted);
    data.writeln;
}
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

Elixir

defmodule Sort do
  def patience_sort(list) do
    piles = deal_pile(list, [])
    merge_pile(piles, [])
  end
  
  defp deal_pile([], piles), do: piles
  defp deal_pile([h|t], piles) do
    index = Enum.find_index(piles, fn pile -> hd(pile) <= h end)
    new_piles = if index, do:   add_element(piles, index, h, []),
                          else: piles ++ [[h]]
    deal_pile(t, new_piles)
  end
  
  defp add_element([h|t], 0,     elm, work), do: Enum.reverse(work, [[elm | h] | t])
  defp add_element([h|t], index, elm, work), do: add_element(t, index-1, elm, [h | work])
  
  defp merge_pile([], list), do: list
  defp merge_pile(piles, list) do
    {max, index} = max_index(piles)
    merge_pile(delete_element(piles, index, []), [max | list])
  end
  
  defp max_index([h|t]), do: max_index(t, hd(h), 1, 0)
  
  defp max_index([], max, _, max_i), do: {max, max_i}
  defp max_index([h|t], max, index, _) when hd(h)>max, do: max_index(t, hd(h), index+1, index)
  defp max_index([_|t], max, index, max_i)           , do: max_index(t, max, index+1, max_i)
  
  defp delete_element([h|t], 0, work) when length(h)==1, do: Enum.reverse(work, t)
  defp delete_element([h|t], 0, work)                  , do: Enum.reverse(work, [tl(h) | t])
  defp delete_element([h|t], index, work), do: delete_element(t, index-1, [h | work])
end

IO.inspect Sort.patience_sort [4, 65, 2, -31, 0, 99, 83, 782, 1]
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

Fortran

Translation of: Icon
Works with: gfortran version 11.3.0


Patience sort on unlimited polymorphic arrays, with a demonstration on an array of integers.

I actually exaggerate in calling this implementation a translation of the Icon. This Fortran introduces significant improvements. It neither moves nor copies input elements, but instead works on integer indices. The return value itself is an array of indices.

Beware: if you compile the program in gfortran without the optimizer, you may see a warning such as

Warning: trampoline generated for nested function "less" [-Wtrampolines]

The generated code is perfectly alright and should run right away, except on some hardened platforms. Turn on the optimizer and the trampoline should go away.


module rosetta_code_patience_sort
  implicit none
  private

  public :: patience_sort

  interface
     function binary_predicate (x, y) result (truth)
       class(*), intent(in) :: x, y
       logical :: truth
     end function binary_predicate
  end interface

contains

  function patience_sort (less, ifirst, ilast, array) result (sorted)
    procedure(binary_predicate) :: less
    integer, intent(in) :: ifirst, ilast
    class(*), intent(in) :: array(*)
    integer, allocatable :: sorted(:)

    !
    ! Returns a sorted list of indices.
    !

    integer :: num_piles
    integer, allocatable :: piles(:)
    integer, allocatable :: links(:)

    ! We shall build the piles as linked lists stored as arrays of
    ! element indices. The indices are normalized to run from 1 to
    ! ifirst-ilast+1. The "piles" array stores the heads, and the
    ! "links" array stores the rest of each list. A null link is
    ! represented by zero.
    allocate (piles(1 : ilast - ifirst + 1), source = 0)
    allocate (links(1 : ilast - ifirst + 1), source = 0)

    num_piles = 0
    call deal (less, ifirst, ilast, array, num_piles, piles, links)

    allocate (sorted(1 : ilast - ifirst + 1))

    call k_way_merge (less, ifirst, ilast, array, num_piles, piles, &
         &            links, sorted)

  end function patience_sort

  subroutine deal (less, ifirst, ilast, array, &
       &           num_piles, piles, links)
    procedure(binary_predicate) :: less
    integer, intent(in) :: ifirst, ilast
    class(*), intent(in) :: array(*)
    integer, intent(inout) :: num_piles
    integer, intent(inout) :: piles(1 : ilast - ifirst + 1)
    integer, intent(inout) :: links(1 : ilast - ifirst + 1)

    integer :: i, q

    do q = 1, ilast - ifirst + 1
       i = find_pile (q)
       links(q) = piles(i)
       piles(i) = q
       num_piles = max (num_piles, i)
    end do

  contains

    function find_pile (q) result (index)
      integer, value :: q
      integer :: index

      !
      ! Bottenbruch search for the leftmost pile whose top is greater
      ! than or equal to 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
      !

      integer :: i, j, k

      if (num_piles == 0) then
         index = 1
      else
         j = 0
         k = num_piles - 1
         do while (j /= k)
            i = (j + k) / 2
            if (less (array(piles(j + 1) + ifirst - 1), &
                 &    array(q + ifirst - 1))) then
               j = i + 1
            else
               k = i
            end if
         end do
         if (j == num_piles - 1) then
            if (less (array(piles(j + 1) + ifirst - 1), &
                 &    array(q + ifirst - 1))) then
               ! A new pile is needed.
               j = j + 1
            end if
         end if
         index = j + 1
      end if
    end function find_pile

  end subroutine deal

  subroutine k_way_merge (less, ifirst, ilast, array, num_piles, &
       &                  piles, links, sorted)
    procedure(binary_predicate) :: less
    integer, intent(in) :: ifirst, ilast
    class(*), intent(in) :: array(*)
    integer, intent(in) :: num_piles
    integer, intent(inout) :: piles(1 : ilast - ifirst + 1)
    integer, intent(inout) :: links(1 : ilast - ifirst + 1)
    integer, intent(inout) :: sorted(1 : ilast - ifirst + 1)

    !
    ! 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.
    !

    integer :: total_external_nodes
    integer :: total_nodes
    integer :: winners(1:2, 1:(2 * next_power_of_two (num_piles)) - 1)
    integer :: isorted, i, next

    total_external_nodes = next_power_of_two (num_piles)
    total_nodes = (2 * total_external_nodes) - 1

    call build_tree

    isorted = 0
    do while (winners(1, 1) /= 0)
       isorted = isorted + 1
       sorted(isorted) = winners(1, 1) + ifirst - 1
       i = winners(2, 1)
       next = piles(i)          ! The next top of pile i.
       if (next /= 0) piles(i) = links(next) ! Drop that top.
       i = (total_nodes / 2) + i
       winners(1, i) = next
       call replay_games (i)
    end do

  contains

    subroutine build_tree
      integer :: i
      integer :: istart
      integer :: iwinner

      winners = 0

      do i = 1, total_external_nodes
         ! Record which pile a winner will have come from.
         winners(2, total_external_nodes - 1 + i) = i
      end do

      ! The top of each pile becomes a starting competitor.
      winners(1, total_external_nodes :                  &
           &     total_external_nodes + num_piles - 1) = &
           &  piles(1:num_piles)

      do i = 1, num_piles
         ! Discard the top of each pile
         piles(i) = links(piles(i))
      end do

      istart = total_external_nodes
      do while (istart /= 1)
         do i = istart, (2 * istart) - 1, 2
            iwinner = play_game (i)
            winners(:, i / 2) = winners(:, iwinner)
         end do
         istart = istart / 2
      end do
    end subroutine build_tree

    subroutine replay_games (i)
      integer, value :: i

      integer :: iwinner

      do while (i /= 1)
         iwinner = play_game (i)
         i = i / 2
         winners(:, i) = winners(:, iwinner)
      end do
    end subroutine replay_games

    function play_game (i) result (iwinner)
      integer, value :: i
      integer :: iwinner

      integer :: j

      j = ieor (i, 1)
      if (winners(1, i) == 0) then
         iwinner = j
      else if (winners(1, j) == 0) then
         iwinner = i
      else if (less (array(winners(1, j) + ifirst - 1), &
           &         array(winners(1, i) + ifirst - 1))) then
         iwinner = j
      else
         iwinner = i
      end if
    end function play_game

  end subroutine k_way_merge

  elemental function next_power_of_two (n) result (pow2)
    integer, value :: n
    integer :: pow2

    ! This need not be a fast implementation.
    pow2 = 1
    do while (pow2 < n)
       pow2 = pow2 + pow2
    end do
  end function next_power_of_two

end module rosetta_code_patience_sort

program patience_sort_task
  use, non_intrinsic :: rosetta_code_patience_sort
  implicit none

  integer, parameter :: example_numbers(*) =               &
       & (/ 22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, &
       &    46, 54, 93, 8, 54, 2, 72, 84, 86, 76, 53, 37,  &
       &    90 /)

  integer :: i
  integer, allocatable :: sorted(:)

  sorted = patience_sort (less, &
       &                  lbound (example_numbers, 1), &
       &                  ubound (example_numbers, 1), &
       &                  example_numbers)

  write (*, '("unsorted  ")', advance = 'no')
  do i = lbound (example_numbers, 1), ubound (example_numbers, 1)
     write (*, '(1X, I0)', advance = 'no') example_numbers(i)
  end do
  write (*, '()')
  write (*, '("sorted    ")', advance = 'no')
  do i = lbound (sorted, 1), ubound (sorted, 1)
     write (*, '(1X, I0)', advance = 'no') example_numbers(sorted(i))
  end do
  write (*, '()')

contains

  function less (x, y) result (truth)
    class(*), intent(in) :: x, y
    logical :: truth

    select type (x)
    type is (integer)
       select type (y)
       type is (integer)
          truth = (x < y)
       class default
          error stop
       end select
    class default
       error stop
    end select
  end function less

end program patience_sort_task
Output:
$ gfortran -Wall -Wextra -std=f2018 -fcheck=all -O patience_sort_task.f90 && ./a.out
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

Go

This version is written for int slices, but can be easily modified to sort other types.

package main

import (
  "fmt"
  "container/heap"
  "sort"
)

type IntPile []int
func (self IntPile) Top() int { return self[len(self)-1] }
func (self *IntPile) Pop() int {
    x := (*self)[len(*self)-1]
    *self = (*self)[:len(*self)-1]
    return x
}

type IntPilesHeap []IntPile
func (self IntPilesHeap) Len() int { return len(self) }
func (self IntPilesHeap) Less(i, j int) bool { return self[i].Top() < self[j].Top() }
func (self IntPilesHeap) Swap(i, j int) { self[i], self[j] = self[j], self[i] }
func (self *IntPilesHeap) Push(x interface{}) { *self = append(*self, x.(IntPile)) }
func (self *IntPilesHeap) Pop() interface{} {
    x := (*self)[len(*self)-1]
    *self = (*self)[:len(*self)-1]
    return x
}

func patience_sort (n []int) {
  var piles []IntPile
  // sort into piles
  for _, x := range n {
    j := sort.Search(len(piles), func (i int) bool { return piles[i].Top() >= x })
    if j != len(piles) {
      piles[j] = append(piles[j], x)
    } else {
      piles = append(piles, IntPile{ x })
    }
  }

  // priority queue allows us to merge piles efficiently
  hp := IntPilesHeap(piles)
  heap.Init(&hp)
  for i, _ := range n {
    smallPile := heap.Pop(&hp).(IntPile)
    n[i] = smallPile.Pop()
    if len(smallPile) != 0 {
      heap.Push(&hp, smallPile)
    }
  }
  if len(hp) != 0 {
    panic("something went wrong")
  }
}

func main() {
    a := []int{4, 65, 2, -31, 0, 99, 83, 782, 1}
    patience_sort(a)
    fmt.Println(a)
}
Output:
[-31 0 1 2 4 65 83 99 782]

Haskell

import Control.Monad.ST
import Control.Monad
import Data.Array.ST
import Data.List
import qualified Data.Set as S

newtype Pile a = Pile [a]

instance Eq a => Eq (Pile a) where
  Pile (x:_) == Pile (y:_) = x == y

instance Ord a => Ord (Pile a) where
  Pile (x:_) `compare` Pile (y:_) = x `compare` y

patienceSort :: Ord a => [a] -> [a]
patienceSort = mergePiles . sortIntoPiles where

  sortIntoPiles :: Ord a => [a] -> [[a]]
  sortIntoPiles lst = runST $ do
      piles <- newSTArray (1, length lst) []
      let bsearchPiles x len = aux 1 len where
            aux lo hi | lo > hi = return lo
                      | otherwise = do
              let mid = (lo + hi) `div` 2
              m <- readArray piles mid
              if head m < x then
                aux (mid+1) hi
              else
                aux lo (mid-1)
          f len x = do
            i <- bsearchPiles x len
            writeArray piles i . (x:) =<< readArray piles i
            return $ if i == len+1 then len+1 else len
      len <- foldM f 0 lst
      e <- getElems piles
      return $ take len e
      where newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
            newSTArray = newArray

  mergePiles :: Ord a => [[a]] -> [a]
  mergePiles = unfoldr f . S.fromList . map Pile where
    f pq = case S.minView pq of
             Nothing -> Nothing
             Just (Pile [x], pq') -> Just (x, pq')
             Just (Pile (x:xs), pq') -> Just (x, S.insert (Pile xs) pq')

main :: IO ()
main = print $ patienceSort [4, 65, 2, -31, 0, 99, 83, 782, 1]
Output:
[-31,0,1,2,4,65,83,99,782]

Icon

Translation of: Scheme


#---------------------------------------------------------------------
#
# Patience sorting.
#

procedure patience_sort (less, lst)
  local piles

  piles := deal (less, lst)
  return k_way_merge (less, piles)
end

procedure deal (less, lst)
  local piles
  local x
  local i

  piles := []
  every x := !lst do {
    i := find_pile (less, x, piles)
    if i = *piles + 1 then {
      # Start a new pile after the existing ones.
      put (piles, [x])
    } else {
      # Push the new value onto the top of an existing pile.
      push (piles[i], x)
    }
  }
  return piles
end

procedure find_pile (less, x, piles)
  local i, j, k

  #
  # Do a Bottenbruch search for the leftmost pile whose top is greater
  # than or equal to 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
  #

  j := 0
  k := *piles - 1
  until j = k do {
    i := (j + k) / 2
    if less (piles[j + 1][1], x) then {
      j := i + 1
    } else {
      k := i
    }
  }
  if j = *piles - 1 & less (piles[j + 1][1], x) then {
    # We need a new pile.
    j +:= 1
  }
  return j + 1
end

#---------------------------------------------------------------------
#
# 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 Icon list, and one can find an opponent quickly by simply
# toggling the least significant bit of a competitor's array index.
#

record infinity ()

procedure is_infinity (x)
  return type (x) == "infinity"
end

procedure k_way_merge (less, lists)
  local merged_list

  # Return the merge as a list, which is guaranteed to be freshly
  # allocated.

  every put (merged_list := [], generate_k_way_merge (less, lists))
  return merged_list
end

procedure generate_k_way_merge (less, lists)

  # Generate the results of the merge.

  case *lists of {
    0 : fail
    1 : every suspend !(lists[1])
    default : every suspend generate_merged_lists (less, lists)
  }
end

procedure generate_merged_lists (less, lists)
  local indices
  local winners
  local winner, winner_index
  local i
  local next_value

  indices := list (*lists, 2)
  winners := build_tree (less, lists)
  until is_infinity (winners[1][1]) do {
    suspend winners[1][1]
    winner_index := winners[1][2]
    next_value := get_next (lists, indices, winner_index)
    i := ((*winners + 1) / 2) + winner_index - 1
    winners[i] := [next_value, winner_index]
    replay_games (less, winners, i)
  }
end

procedure build_tree (less, lists)
  local total_external_nodes
  local total_nodes
  local winners
  local i, j
  local istart
  local i1, i2
  local elem1, elem2
  local iwinner, winner

  total_external_nodes := next_power_of_two (*lists)
  total_nodes := (2 * total_external_nodes) - 1
  winners := list (total_nodes)
  every i := 1 to total_external_nodes do {
    j := total_external_nodes + (i - 1)
    if *lists < i | *(lists[i]) = 0 then {
      winners[j] := [infinity (), i]
    } else {
      winners[j] := [lists[i][1], i]
    }
  }
  istart := total_external_nodes
  while istart ~= 1 do {
    every i := istart to (2 * istart) - 1 by 2 do {
      i1 := i
      i2 := ixor (i, 1)
      elem1 := winners[i1][1]
      elem2 := winners[i2][1]
      iwinner := (if play_game (less, elem1, elem2) then i1 else i2)
      winner := winners[iwinner]
      winners[i / 2] := winner
    }
    istart /:= 2
  }
  return winners
end

procedure replay_games (less, winners, i)
  local i1, i2
  local elem1, elem2
  local iwinner, winner

  until i = 1 do {
    i1 := i
    i2 := ixor (i1, 1)
    elem1 := winners[i1][1]
    elem2 := winners[i2][1]
    iwinner := (if play_game (less, elem1, elem2) then i1 else i2)
    winner := winners[iwinner]
    i /:= 2
    winners[i] := winner
  }
  return
end

procedure play_game (less, x, y)
  if is_infinity (x) then fail
  if is_infinity (y) then return
  if less (y, x) then fail
  return
end

procedure get_next (lists, indices, i)
  local next_value

  if *(lists[i]) < indices[i] then {
    next_value := infinity ()
  } else {
    next_value := lists[i][indices[i]]
    indices[i] +:= 1
  }
  return next_value
end

procedure next_power_of_two (n)
  local i

  # This need not be a fast implementation. Also, it need not return
  # any value less than 2; a single list requires no merge.
  i := 2
  while i < n do i +:= i
  return i
end

#---------------------------------------------------------------------

procedure main ()
  local example_numbers

  example_numbers := [22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48,
                      46, 54, 93, 8, 54, 2, 72, 84, 86, 76, 53, 37,
                      90]

  writes ("unsorted  ")
  every writes (" ", !example_numbers)
  write ()
  writes ("sorted    ")
  every writes (" ", !patience_sort ("<", example_numbers))
  write ()
end

#---------------------------------------------------------------------
Output:
$ icont -s -u patience_sort_task.icn && ./patience_sort_task
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

J

The data structure for append and transfer are as x argument a list with cdr as the stacks and car as the data to sort or growing sorted list; and the y argument being the index of pile to operate on. New piles are created by using the new value, accomplished by selecting the entire x argument as a result. Filtering removes empty stacks during unpiling.

Until =: 2 :'u^:(0=v)^:_'
Filter =: (#~`)(`:6)

locate_for_append =: 1 i.~ (<&> {:S:0)  NB. returns an index
append =: (<@:(({::~ >:) , 0 {:: [)`]`(}.@:[)}) :: [
pile =: (,  append locate_for_append)/@:(;/)  NB. pile DATA

smallest =: ((>:@:i. , ]) <./)@:({:S:0@:}.) NB. index of pile with smallest value , that value
transfer =: (}:&.>@:({~ {.) , <@:((0{::[),{:@:]))`(1 0 * ])`[}
unpile =: >@:{.@:((0<#S:0)Filter@:(transfer smallest)Until(1=#))@:(a:&,)

patience_sort =: unpile@:pile

assert (/:~ -: patience_sort) ?@$~30    NB. test with 30 randomly chosen integers

Show =: 1 : 0
 smoutput y
 u y
:
 smoutput A=:x ,&:< y
 x u y
)

pile_demo =: (,  append Show  locate_for_append)/@:(;/)  NB. pile DATA
unpile_demo =: >@:{.@:((0<#S:0)Filter@:(transfer Show  smallest)Until(1=#))@:(a:&,)
patience_sort_demo =: unpile_demo@:pile_demo
   JVERSION
Engine: j701/2011-01-10/11:25
Library: 8.02.12
Platform: Linux 64
Installer: unknown
InstallPath: /usr/share/j/8.0.2
   
   patience_sort_demo Show ?.@$~10
4 6 8 6 5 8 6 6 6 9
┌─────┬─┐
│┌─┬─┐│0│
││6│9││ │
│└─┴─┘│ │
└─────┴─┘
┌───────┬─┐
│┌─┬───┐│1│
││6│9 6││ │
│└─┴───┘│ │
└───────┴─┘
┌─────────┬─┐
│┌─┬─┬───┐│2│
││6│6│9 6││ │
│└─┴─┴───┘│ │
└─────────┴─┘
┌───────────┬─┐
│┌─┬─┬─┬───┐│3│
││8│6│6│9 6││ │
│└─┴─┴─┴───┘│ │
└───────────┴─┘
┌─────────────┬─┐
│┌─┬─┬─┬─┬───┐│0│
││5│8│6│6│9 6││ │
│└─┴─┴─┴─┴───┘│ │
└─────────────┴─┘
┌───────────────┬─┐
│┌─┬───┬─┬─┬───┐│4│
││6│8 5│6│6│9 6││ │
│└─┴───┴─┴─┴───┘│ │
└───────────────┴─┘
┌─────────────────┬─┐
│┌─┬─┬───┬─┬─┬───┐│5│
││8│6│8 5│6│6│9 6││ │
│└─┴─┴───┴─┴─┴───┘│ │
└─────────────────┴─┘
┌───────────────────┬─┐
│┌─┬─┬─┬───┬─┬─┬───┐│0│
││6│8│6│8 5│6│6│9 6││ │
│└─┴─┴─┴───┴─┴─┴───┘│ │
└───────────────────┴─┘
┌─────────────────────┬─┐
│┌─┬───┬─┬───┬─┬─┬───┐│0│
││4│8 6│6│8 5│6│6│9 6││ │
│└─┴───┴─┴───┴─┴─┴───┘│ │
└─────────────────────┴─┘
┌──────────────────────┬───┐
│┌┬─────┬─┬───┬─┬─┬───┐│1 4│
│││8 6 4│6│8 5│6│6│9 6││   │
│└┴─────┴─┴───┴─┴─┴───┘│   │
└──────────────────────┴───┘
┌─────────────────────┬───┐
│┌─┬───┬─┬───┬─┬─┬───┐│3 5│
││4│8 6│6│8 5│6│6│9 6││   │
│└─┴───┴─┴───┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌───┬───┬─┬─┬─┬─┬───┐│1 6│
││4 5│8 6│6│8│6│6│9 6││   │
│└───┴───┴─┴─┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌─────┬─┬─┬─┬─┬─┬───┐│2 6│
││4 5 6│8│6│8│6│6│9 6││   │
│└─────┴─┴─┴─┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌───────┬─┬─┬─┬─┬───┐│3 6│
││4 5 6 6│8│8│6│6│9 6││   │
│└───────┴─┴─┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌─────────┬─┬─┬─┬───┐│3 6│
││4 5 6 6 6│8│8│6│9 6││   │
│└─────────┴─┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌───────────┬─┬─┬───┐│3 6│
││4 5 6 6 6 6│8│8│9 6││   │
│└───────────┴─┴─┴───┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌─────────────┬─┬─┬─┐│1 8│
││4 5 6 6 6 6 6│8│8│9││   │
│└─────────────┴─┴─┴─┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌───────────────┬─┬─┐│1 8│
││4 5 6 6 6 6 6 8│8│9││   │
│└───────────────┴─┴─┘│   │
└─────────────────────┴───┘
┌─────────────────────┬───┐
│┌─────────────────┬─┐│1 9│
││4 5 6 6 6 6 6 8 8│9││   │
│└─────────────────┴─┘│   │
└─────────────────────┴───┘
4 5 6 6 6 6 6 8 8 9
   

Java

import java.util.*;

public class PatienceSort {
    public static <E extends Comparable<? super E>> void sort (E[] n) {
        List<Pile<E>> piles = new ArrayList<Pile<E>>();
        // sort into piles
        for (E x : n) {
            Pile<E> newPile = new Pile<E>();
            newPile.push(x);
            int i = Collections.binarySearch(piles, newPile);
            if (i < 0) i = ~i;
            if (i != piles.size())
                piles.get(i).push(x);
            else
                piles.add(newPile);
        }
 
        // priority queue allows us to retrieve least pile efficiently
        PriorityQueue<Pile<E>> heap = new PriorityQueue<Pile<E>>(piles);
        for (int c = 0; c < n.length; c++) {
            Pile<E> smallPile = heap.poll();
            n[c] = smallPile.pop();
            if (!smallPile.isEmpty())
                heap.offer(smallPile);
        }
        assert(heap.isEmpty());
    }
 
    private static class Pile<E extends Comparable<? super E>> extends Stack<E> implements Comparable<Pile<E>> {
        public int compareTo(Pile<E> y) { return peek().compareTo(y.peek()); }
    }

    public static void main(String[] args) {
	Integer[] a = {4, 65, 2, -31, 0, 99, 83, 782, 1};
	sort(a);
	System.out.println(Arrays.toString(a));
    }
}
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

JavaScript

const patienceSort = (nums) => {
  const piles = []

  for (let i = 0; i < nums.length; i++) {
    const num = nums[i]
    const destinationPileIndex = piles.findIndex(
      (pile) => num >= pile[pile.length - 1]
    )
    if (destinationPileIndex === -1) {
      piles.push([num])
    } else {
      piles[destinationPileIndex].push(num)
    }
  }

  for (let i = 0; i < nums.length; i++) {
    let destinationPileIndex = 0
    for (let p = 1; p < piles.length; p++) {
      const pile = piles[p]
      if (pile[0] < piles[destinationPileIndex][0]) {
        destinationPileIndex = p
      }
    }
    const distPile = piles[destinationPileIndex]
    nums[i] = distPile.shift()
    if (distPile.length === 0) {
      piles.splice(destinationPileIndex, 1)
    }
  }

  return nums
}
console.log(patienceSort([10,6,-30,9,18,1,-20]));
Output:
[-30, -20, 1, 6, 9, 10, 18]

jq

Adapted from Wren

Works with: jq

Works with gojq, the Go implementation of jq

def patienceSort:
  length as $size
  | if $size < 2 then .
    else
      reduce .[] as $e ( {piles: []};
        .outer = false
	| first( range(0; .piles|length) as $ipile
                 | if .piles[$ipile][-1] < $e
                   then .piles[$ipile] += [$e]
                   | .outer = true
		   else empty
		   end ) // .
        | if (.outer|not) then .piles += [[$e]] else . end )
    | reduce range(0; $size) as $i (.;
        .min = .piles[0][0]
        | .minPileIndex = 0
        | reduce range(1; .piles|length) as $j (.;
            if .piles[$j][0] < .min
            then .min = .piles[$j][0]
            | .minPileIndex = $j
	    else .
	    end )
        | .a += [.min]
	| .minPileIndex as $mpx
	| .piles[$mpx] |= .[1:]
        | if (.piles[$mpx] == []) then .piles |= .[:$mpx] + .[$mpx + 1:]
	  else .
	  end)
  end
  | .a ;


[4, 65, 2, -31, 0, 99, 83, 782, 1],
 ["n", "o", "n", "z", "e", "r", "o", "s", "u", "m"],
 ["dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"]
| patienceSort
Output:
[-31,0,1,2,4,65,83,99,782]
["e","m","n","n","o","o","r","s","u","z"]
["ant","ape","ass","cat","cow","dog","gnu","man","pig"]

Julia

function patiencesort(list::Vector{T}) where T
    piles = Vector{Vector{T}}()
    for n in list
        if isempty(piles) || 
            (i = findfirst(pile -> n <= pile[end], piles)) ==  nothing
            push!(piles, [n])
        else
            push!(piles[i], n)
        end
    end
    mergesorted(piles)
end

function mergesorted(vecvec)
    lengths = map(length, vecvec)
    allsum = sum(lengths)
    sorted = similar(vecvec[1], allsum)
    for i in 1:allsum
        (val, idx) = findmin(map(x -> x[end], vecvec))
        sorted[i] = pop!(vecvec[idx])
        if isempty(vecvec[idx])
            deleteat!(vecvec, idx)
        end
    end
    sorted
end
                
println(patiencesort(rand(collect(1:1000), 12)))
Output:
[186, 243, 255, 257, 427, 486, 513, 613, 657, 734, 866, 907]

Kotlin

// version 1.1.2

fun <T : Comparable<T>> patienceSort(arr: Array<T>) {
    if (arr.size < 2) return
    val piles = mutableListOf<MutableList<T>>()
    outer@ for (el in arr) {
        for (pile in piles) {
            if (pile.last() > el) {
                pile.add(el)
                continue@outer
            }
        }
        piles.add(mutableListOf(el))
    }
 
    for (i in 0 until arr.size) {
        var min = piles[0].last()
        var minPileIndex = 0
        for (j in 1 until piles.size) {
            if (piles[j].last() < min) {
                min = piles[j].last()
                minPileIndex = j
            }
        } 
        arr[i] = min
        val minPile = piles[minPileIndex]
        minPile.removeAt(minPile.lastIndex)
        if (minPile.size == 0) piles.removeAt(minPileIndex)
    }    
}

fun main(args: Array<String>) {
    val iArr = arrayOf(4, 65, 2, -31, 0, 99, 83, 782, 1)
    patienceSort(iArr)
    println(iArr.contentToString())
    val cArr = arrayOf('n', 'o', 'n', 'z', 'e', 'r', 'o', 's', 'u','m')
    patienceSort(cArr)
    println(cArr.contentToString())
    val sArr = arrayOf("dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu")
    patienceSort(sArr)
    println(sArr.contentToString())
}
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
[e, m, n, n, o, o, r, s, u, z]
[ant, ape, ass, cat, cow, dog, gnu, man, pig]

Mercury

Translation of: Fortran
Works with: Mercury version 22.01.1


The Mercury standard library has binary search on arrays, and also a priority queue module, but I did not use these. Instead I translated the Fortran implementation entirely. The binary search and k-way merge for Fortran were known to work, and also are known to work in Ada. Also they are specialized for the patience sort task.


:- module patience_sort_task.

:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module array.
:- import_module int.
:- import_module list.
:- import_module string.

%%%-------------------------------------------------------------------
%%%
%%% patience_sort/5 -- sorts Array[Ifirst..Ilast] out of place,
%%%                    returning indices in Sorted[0..Ilast-Ifirst].
%%%

:- pred patience_sort(pred(T, T), int, int, array(T), array(int)).
:- mode patience_sort(pred(in, in) is semidet,
                      in, in, in, out) is det.
patience_sort(Less, Ifirst, Ilast, Array, Sorted) :-
  deal(Less, Ifirst, Ilast, Array, Num_piles, Piles, Links),
  k_way_merge(Less, Ifirst, Ilast, Array,
              Num_piles, Piles, Links, Sorted).

%%%-------------------------------------------------------------------
%%%
%%% deal/7 -- deals array elements into piles.
%%%

:- pred deal(pred(T, T), int, int, array(T),
             int, array(int), array(int)).
:- mode deal(pred(in, in) is semidet, in, in, in,
             out, array_uo, array_uo).
deal(Less, Ifirst, Ilast, Array, Num_piles, Piles, Links) :-
  Piles_last = Ilast - Ifirst + 1,
  %% I do not use index zero of arrays, so must allocate one extra
  %% entry per array.
  init(Piles_last + 1, 0, Piles0),
  init(Piles_last + 1, 0, Links0),
  deal_loop(Less, Ifirst, Ilast, Array, 1,
            0, Num_piles,
            Piles0, Piles,
            Links0, Links).

:- pred deal_loop(pred(T, T), int, int, array(T),
                  int, int, int,
                  array(int), array(int),
                  array(int), array(int)).
:- mode deal_loop(pred(in, in) is semidet, in, in, in,
                  in, in, out,
                  array_di, array_uo,
                  array_di, array_uo) is det.
deal_loop(Less, Ifirst, Ilast, Array, Q,
          !Num_piles, !Piles, !Links) :-
  Piles_last = Ilast - Ifirst + 1,
  (if (Q =< Piles_last)
   then (find_pile(Less, Ifirst, Array, !.Num_piles, !.Piles, Q) = I,
         (!.Piles^elem(I)) = L1,
         (!.Piles^elem(I) := Q) = !:Piles,
         (!.Links^elem(Q) := L1) = !:Links,
         max(!.Num_piles, I) = !:Num_piles,
         deal_loop(Less, Ifirst, Ilast, Array, Q + 1,
                   !Num_piles, !Piles, !Links))
   else true).

:- func find_pile(pred(T, T), int, array(T),
                  int, array(int), int) = int.
:- mode find_pile(pred(in, in) is semidet,
                  in, in, in, in, in) = out is det.
find_pile(Less, Ifirst, Array, Num_piles, Piles, Q) = Index :-
  %%
  %% Bottenbruch search for the leftmost pile whose top is greater
  %% than or equal to 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
  %%
  %% Note:
  %%
  %%   * There is a binary search in the array module of the standard
  %%   library, but our search algorithm is known to work in other
  %%   programming languages and is written specifically for the
  %%   situation.
  %%
  (if (Num_piles = 0) then (Index = 1)
   else (find_pile_loop(Less, Ifirst, Array, Piles, Q,
                        0, Num_piles - 1, J),
         (if (J = Num_piles - 1)
          then (I1 = Piles^elem(J + 1) + Ifirst - 1,
                I2 = Q + Ifirst - 1,
                (if Less(Array^elem(I1), Array^elem(I2))
                 then (Index = J + 2)
                 else (Index = J + 1)))
          else (Index = J + 1)))).

:- pred find_pile_loop(pred(T, T), int, array(T), array(int),
                       int, int, int, int).
:- mode find_pile_loop(pred(in, in) is semidet,
                       in, in, in, in, in, in, out) is det.
find_pile_loop(Less, Ifirst, Array, Piles, Q, J, K, J1) :-
  (if (J = K) then (J1 = J)
   else ((J + K) // 2 = I,
         I1 = Piles^elem(J + 1) + Ifirst - 1,
         I2 = Q + Ifirst - 1,
         (if Less(Array^elem(I1), Array^elem(I2))
          then find_pile_loop(Less, Ifirst, Array, Piles, Q,
                              I + 1, K, J1)
          else find_pile_loop(Less, Ifirst, Array, Piles, Q,
                              J, I, J1)))).

%%%-------------------------------------------------------------------
%%%
%%% k_way_merge/8 --
%%%
%%% k-way merge by tournament tree (specific to this patience sort).
%%%
%%% 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.
%%%

:- pred k_way_merge(pred(T, T), int, int, array(T), int,
                    array(int), array(int), array(int)).
:- mode k_way_merge(pred(in, in) is semidet,
                    in, in, in, in, array_di, in, out) is det.
%% Contrary to the arrays used internally, the Sorted array is indexed
%% starting at zero.
k_way_merge(Less, Ifirst, Ilast, Array,
            Num_piles, Piles, Links, Sorted) :-
  init(Ilast - Ifirst + 1, 0, Sorted0),
  build_tree(Less, Ifirst, Array, Num_piles, Links, Piles, Piles1,
             Total_external_nodes, Winners_values, Winners_indices),
  k_way_merge_(Less, Ifirst, Array, Piles1, Links,
               Total_external_nodes, Winners_values, Winners_indices,
               0, Sorted0, Sorted).

:- pred k_way_merge_(pred(T, T), int, array(T),
                     array(int), array(int), int,
                     array(int), array(int), int,
                     array(int), array(int)).
:- mode k_way_merge_(pred(in, in) is semidet, in, in, array_di,
                     in, in, array_di, array_di,
                     in, array_di, array_uo) is det.
%% Contrary to the arrays used internally, the Sorted array is indexed
%% starting at zero.
k_way_merge_(Less, Ifirst, Array, Piles, Links, Total_external_nodes,
             Winners_values, Winners_indices, Isorted, !Sorted) :-
  Total_nodes = (2 * Total_external_nodes) - 1,
  (Winners_values^elem(1)) = Value,
  (if (Value = 0) then true
   else (set(Isorted, Value + Ifirst - 1, !Sorted),
         (Winners_indices^elem(1)) = Index,
         (Piles^elem(Index)) = Next, % The next top of pile Index.
         (if (Next \= 0)        % Drop that top of pile.
          then (Links^elem(Next) = Link,
                set(Index, Link, Piles, Piles1))
          else (Piles = Piles1)),
         (Total_nodes // 2) + Index = I,
         (Winners_values^elem(I) := Next) = Winners_values1,
         replay_games(Less, Ifirst, Array, I,
                      Winners_values1, Winners_values2,
                      Winners_indices, Winners_indices1),
         k_way_merge_(Less, Ifirst, Array, Piles1, Links,
                      Total_external_nodes, Winners_values2,
                      Winners_indices1, Isorted + 1, !Sorted))).

:- pred build_tree(pred(T, T), int, array(T), int, array(int),
                   array(int), array(int), int, array(int),
                   array(int)).
:- mode build_tree(pred(in, in) is semidet, in, in, in, in,
                   array_di, array_uo, out, out, out) is det.
build_tree(Less, Ifirst, Array, Num_piles, Links, !Piles,
           Total_external_nodes, Winners_values, Winners_indices) :-
  Total_external_nodes = next_power_of_two(Num_piles),
  Total_nodes = (2 * Total_external_nodes) - 1,
  %% I do not use index zero of arrays, so must allocate one extra
  %% entry per array.
  init(Total_nodes + 1, 0, Winners_values0),
  init(Total_nodes + 1, 0, Winners_indices0),
  init_winners_pile_indices(Total_external_nodes, 1,
                            Winners_indices0, Winners_indices1),
  init_starting_competitors(Total_external_nodes, Num_piles,
                            (!.Piles), 1, Winners_values0,
                            Winners_values1),
  discard_initial_tops_of_piles(Num_piles, Links, 1, !Piles),
  play_initial_games(Less, Ifirst, Array,
                     Total_external_nodes,
                     Winners_values1, Winners_values,
                     Winners_indices1, Winners_indices).

:- pred init_winners_pile_indices(int::in, int::in,
                                  array(int)::array_di,
                                  array(int)::array_uo) is det.
init_winners_pile_indices(Total_external_nodes, I,
                          !Winners_indices) :-
  (if (I = Total_external_nodes + 1) then true
   else (set(Total_external_nodes - 1 + I, I, !Winners_indices),
         init_winners_pile_indices(Total_external_nodes, I + 1,
                                   !Winners_indices))).

:- pred init_starting_competitors(int::in, int::in,
                                  array(int)::in, int::in,
                                  array(int)::array_di,
                                  array(int)::array_uo) is det.
init_starting_competitors(Total_external_nodes, Num_piles,
                          Piles, I, !Winners_values) :-
  (if (I = Num_piles + 1) then true
   else (Piles^elem(I) = Value,
         set(Total_external_nodes - 1 + I, Value, !Winners_values),
         init_starting_competitors(Total_external_nodes, Num_piles,
                                   Piles, I + 1, !Winners_values))).

:- pred discard_initial_tops_of_piles(int::in, array(int)::in,
                                      int::in, array(int)::array_di,
                                      array(int)::array_uo) is det.
discard_initial_tops_of_piles(Num_piles, Links, I, !Piles) :-
  (if (I = Num_piles + 1) then true
   else ((!.Piles^elem(I)) = Old_value,
         Links^elem(Old_value) = New_value,
         set(I, New_value, !Piles),
         discard_initial_tops_of_piles(Num_piles, Links, I + 1,
                                       !Piles))).

:- pred play_initial_games(pred(T, T), int, array(T), int,
                           array(int), array(int),
                           array(int), array(int)).
:- mode play_initial_games(pred(in, in) is semidet,
                           in, in, in,
                           array_di, array_uo,
                           array_di, array_uo) is det.
play_initial_games(Less, Ifirst, Array, Istart,
                   !Winners_values, !Winners_indices) :-
  (if (Istart = 1) then true
   else (play_an_initial_round(Less, Ifirst, Array, Istart, Istart,
                               !Winners_values, !Winners_indices),
         play_initial_games(Less, Ifirst, Array, Istart // 2,
                            !Winners_values, !Winners_indices))).

:- pred play_an_initial_round(pred(T, T), int, array(T), int, int,
                              array(int), array(int),
                              array(int), array(int)).
:- mode play_an_initial_round(pred(in, in) is semidet,
                              in, in, in, in,
                              array_di, array_uo,
                              array_di, array_uo) is det.
play_an_initial_round(Less, Ifirst, Array, Istart, I,
                      !Winners_values, !Winners_indices) :-
  (if ((2 * Istart) - 1 < I) then true
   else (play_game(Less, Ifirst, Array,
                   !.Winners_values, I) = Iwinner,
         (!.Winners_values^elem(Iwinner)) = Value,
         (!.Winners_indices^elem(Iwinner)) = Index,
         I // 2 = Iparent,
         set(Iparent, Value, !Winners_values),
         set(Iparent, Index, !Winners_indices),
         play_an_initial_round(Less, Ifirst, Array, Istart, I + 2,
                               !Winners_values, !Winners_indices))).

:- pred replay_games(pred(T, T), int, array(T), int,
                     array(int), array(int),
                     array(int), array(int)).
:- mode replay_games(pred(in, in) is semidet, in, in, in,
                     array_di, array_uo,
                     array_di, array_uo) is det.
replay_games(Less, Ifirst, Array, I,
             !Winners_values, !Winners_indices) :-
  (if (I = 1) then true
   else (Iwinner = play_game(Less, Ifirst, Array,
                             !.Winners_values, I),
         (!.Winners_values^elem(Iwinner)) = Value,
         (!.Winners_indices^elem(Iwinner)) = Index,
         I // 2 = Iparent,
         set(Iparent, Value, !Winners_values),
         set(Iparent, Index, !Winners_indices),
         replay_games(Less, Ifirst, Array, Iparent,
                      !Winners_values, !Winners_indices))).

:- func play_game(pred(T, T), int, array(T), array(int), int) = int.
:- mode play_game(pred(in, in) is semidet,
                  in, in, in, in) = out is det.
play_game(Less, Ifirst, Array, Winners_values, I) = Iwinner :-
  J = xor(I, 1),                % Find an opponent.
  Winners_values^elem(I) = Value_I,
  (if (Value_I = 0) then (Iwinner = J)
   else (Winners_values^elem(J) = Value_J,
         (if (Value_J = 0) then (Iwinner = I)
          else (AJ = Array^elem(Value_J + Ifirst - 1),
                AI = Array^elem(Value_I + Ifirst - 1),
                (if Less(AJ, AI) then (Iwinner = J)
                 else (Iwinner = I)))))).

%%%-------------------------------------------------------------------

:- func next_power_of_two(int) = int.
%% This need not be a fast implemention.
next_power_of_two(N) = next_power_of_two_(N, 1).

:- func next_power_of_two_(int, int) = int.
next_power_of_two_(N, I) = Pow2 :-
  if (I < N) then (Pow2 = next_power_of_two_(N, I + I))
  else (Pow2 = I).

%%%-------------------------------------------------------------------

:- func example_numbers = list(int).
example_numbers = [22, 15, 98, 82, 22, 4, 58, 70, 80, 38, 49, 48, 46,
                   54, 93, 8, 54, 2, 72, 84, 86, 76, 53, 37, 90].

main(!IO) :-
  from_list(example_numbers, Array),
  bounds(Array, Ifirst, Ilast),
  patience_sort(<, Ifirst, Ilast, Array, Sorted),
  print("unsorted  ", !IO),
  print_int_array(Array, Ifirst, !IO),
  print_line("", !IO),
  print("sorted    ", !IO),
  print_indirect_array(Sorted, Array, 0, !IO),
  print_line("", !IO).

:- pred print_int_array(array(int)::in, int::in,
                        io::di, io::uo) is det.
print_int_array(Array, I, !IO) :-
  bounds(Array, _, Ilast),
  (if (I = Ilast + 1) then true
   else (print(" ", !IO),  
         print(from_int(Array^elem(I)), !IO),
         print_int_array(Array, I + 1, !IO))).

:- pred print_indirect_array(array(int)::in, array(int)::in,
                             int::in, io::di, io::uo) is det.
print_indirect_array(Sorted, Array, I, !IO) :-
  bounds(Sorted, _, Ilast),
  (if (I = Ilast + 1) then true
   else (print(" ", !IO),  
         print(from_int(Array^elem(Sorted^elem(I))), !IO),
         print_indirect_array(Sorted, Array, I + 1, !IO))).

%%%-------------------------------------------------------------------
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
Output:

I thought to put the code through a bit of a stress test by running the optimizer on it.

$ mmc -O6 --intermod-opt --warn-non-tail-recursion=self-and-mutual --use-subdirs patience_sort_task.m && ./patience_sort_task
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

Modula-2

Translation of: Ada
Works with: GNU Modula-2


Patience sort for ISO Modula-2. I tested it with the GNU Modula-2 that is in a development branch of GCC 12.

Unlike the Ada upon which it is based, this implementation of patience sort is specific to arrays of integers, rather than generic.

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.
Output:
$ gm2 -fiso PatienceSortTask.mod && ./a.out
unsorted   +22 +15 +98 +82 +22 +4 +58 +70 +80 +38 +49 +48 +46 +54 +93 +8 +54 +2 +72 +84 +86 +76 +53 +37 +90
sorted     +2 +4 +8 +15 +22 +22 +37 +38 +46 +48 +49 +53 +54 +54 +58 +70 +72 +76 +80 +82 +84 +86 +90 +93 +98

Nim

import std/decls

func patienceSort[T](a: var openArray[T]) =

  if a.len < 2: return

  var piles: seq[seq[T]]

  for elem in a:
    block processElem:
      for pile in piles.mitems:
        if pile[^1] > elem:
          pile.add(elem)
          break processElem
      piles.add(@[elem])

  for i in 0..a.high:
    var min = piles[0][^1]
    var minPileIndex = 0
    for j in 1..piles.high:
      if piles[j][^1] < min:
        min = piles[j][^1]
        minPileIndex = j

    a[i] = min
    var minPile {.byAddr.} = piles[minPileIndex]
    minPile.setLen(minpile.len - 1)
    if minPile.len == 0: piles.delete(minPileIndex)


when isMainModule:

  var iArray = [4, 65, 2, -31, 0, 99, 83, 782, 1]
  iArray.patienceSort()
  echo iArray
  var cArray = ['n', 'o', 'n', 'z', 'e', 'r', 'o', 's', 'u','m']
  cArray.patienceSort()
  echo cArray
  var sArray = ["dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"]
  sArray.patienceSort()
  echo sArray
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
['e', 'm', 'n', 'n', 'o', 'o', 'r', 's', 'u', 'z']
["ant", "ape", "ass", "cat", "cow", "dog", "gnu", "man", "pig"]

OCaml

module PatienceSortFn (Ord : Set.OrderedType) : sig
    val patience_sort : Ord.t list -> Ord.t list
  end = struct

  module PilesSet = Set.Make
    (struct
       type t = Ord.t list
       let compare x y = Ord.compare (List.hd x) (List.hd y)
     end);;

  let sort_into_piles list =
    let piles = Array.make (List.length list) [] in
    let bsearch_piles x len =
      let rec aux lo hi =
        if lo > hi then
          lo
        else
          let mid = (lo + hi) / 2 in
          if Ord.compare (List.hd piles.(mid)) x < 0 then
            aux (mid+1) hi
          else
            aux lo (mid-1)
      in
        aux 0 (len-1)
    in
    let f len x =
      let i = bsearch_piles x len in
      piles.(i) <- x :: piles.(i);
      if i = len then len+1 else len
    in
    let len = List.fold_left f 0 list in
    Array.sub piles 0 len

  let merge_piles piles =
    let pq = Array.fold_right PilesSet.add piles PilesSet.empty in
    let rec f pq acc =
      if PilesSet.is_empty pq then
        acc
      else
        let elt = PilesSet.min_elt pq in
        match elt with
          [] -> failwith "Impossible"
        | x::xs ->
          let pq' = PilesSet.remove elt pq in
          f (if xs = [] then pq' else PilesSet.add xs pq') (x::acc)
    in
    List.rev (f pq [])

  let patience_sort n =
    merge_piles (sort_into_piles n)
end

Usage:

# module IntPatienceSort = PatienceSortFn
  (struct
     type t = int
     let compare = compare
   end);;        
module IntPatienceSort : sig val patience_sort : int list -> int list end
# IntPatienceSort.patience_sort [4; 65; 2; -31; 0; 99; 83; 782; 1];;
- : int list = [-31; 0; 1; 2; 4; 65; 83; 99; 782]

Pascal

Translation of: Modula-2
Works with: Free Pascal Compiler version 3.2.2
PatienceSortTask (Output);

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;

FUNCTION NextPowerOfTwo (n : INTEGER) : INTEGER;
  VAR Pow2 : INTEGER;
BEGIN
  { This need not be a fast implementation. }
  Pow2 := 1;
  WHILE Pow2 < n DO
    Pow2 := Pow2 + Pow2;
  NextPowerOfTwo := Pow2;
END;

PROCEDURE InitPilesArray (VAR Arr : PilesArrayType);
  VAR i : INTEGER;
BEGIN
  FOR i := 1 TO MaxSortSize DO
    Arr[i] := 0;
END;

PROCEDURE InitWinnersArray (VAR Arr : WinnersArrayType);
  VAR i : INTEGER;
BEGIN
  FOR i := 1 TO MaxWinnersSize DO
    BEGIN
      Arr[i, 1] := 0;
      Arr[i, 2] := 0;
    END;
END;

PROCEDURE IntegerPatienceSort (iFirst, iLast : INTEGER;
                               Arr : ARRAY OF INTEGER;
                               VAR Sorted : ARRAY OF INTEGER);
  VAR NumPiles : INTEGER;
      Piles, Links : PilesArrayType;
      Winners : WinnersArrayType;

  FUNCTION 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
      BEGIN
        j := 0;
        k := NumPiles - 1;
        WHILE j <> k DO
          BEGIN
            i := (j + k) DIV 2;
            IF Arr[Piles[j + 1] + iFirst - 1] < Arr[q + iFirst - 1] THEN
              j := i + 1
            ELSE
              k := i
          END;
        IF j = NumPiles - 1 THEN
          BEGIN
            IF Arr[Piles[j + 1] + iFirst - 1] < Arr[q + iFirst - 1] THEN
              { A new pile is needed. }
              j := j + 1
          END;
        Index := j + 1
      END;
    FindPile := Index
  END;

  PROCEDURE Deal;
    VAR i, q : INTEGER;
  BEGIN
    FOR q := 1 TO iLast - iFirst + 1 DO
      BEGIN
        i := FindPile (q);
        Links[q] := Piles[i];
        Piles[i] := q;
        IF i = NumPiles + 1 THEN
          NumPiles := i
      END
  END;

  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;

    FUNCTION FindOpponent (i : INTEGER) : INTEGER;
      VAR Opponent : INTEGER;
    BEGIN
      IF ODD (i) THEN
        Opponent := i - 1
      ELSE
        Opponent := i + 1;
      FindOpponent := Opponent
    END;

    FUNCTION PlayGame (i : INTEGER) : INTEGER;
      VAR j, iWinner : INTEGER;
    BEGIN
      j := FindOpponent (i);
      IF Winners[i, 1] = 0 THEN
        iWinner := j
      ELSE IF Winners[j, 1] = 0 THEN
        iWinner := i
      ELSE IF (Arr[Winners[j, 1] + iFirst - 1]
               < Arr[Winners[i, 1] + iFirst - 1]) THEN
        iWinner := j
      ELSE
        iWinner := i;
      PlayGame := iWinner
    END;

    PROCEDURE ReplayGames (i : INTEGER);
      VAR j, iWinner : INTEGER;
    BEGIN
      j := i;
      WHILE j <> 1 DO
        BEGIN
          iWinner := PlayGame (j);
          j := j DIV 2;
          Winners[j, 1] := Winners[iWinner, 1];
          Winners[j, 2] := Winners[iWinner, 2];
        END
    END;

    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;

      FOR i := 1 TO NumPiles DO
        { The top of each pile becomes a starting competitor. }
        Winners[TotalExternalNodes + i - 1, 1] := Piles[i];

      FOR i := 1 TO NumPiles DO
        { Discard the top of each pile. }
        Piles[i] := Links[Piles[i]];

      iStart := TotalExternalNodes;
      WHILE iStart <> 1 DO
        BEGIN
          i := iStart;
          WHILE i <= (2 * iStart) - 1 DO
            BEGIN
              iWinner := PlayGame (i);
              Winners[i DIV 2, 1] := Winners[iWinner, 1];
              Winners[i DIV 2, 2] := Winners[iWinner, 2];
              i := i + 2
            END;
          iStart := iStart DIV 2
        END
    END;

  BEGIN
    TotalExternalNodes := NextPowerOfTwo (NumPiles);
    TotalNodes := (2 * TotalExternalNodes) - 1;
    BuildTree;
    iSorted := 0;
    WHILE Winners[1, 1] <> 0 DO
      BEGIN
        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. }
        i := (TotalNodes DIV 2) + i;
        Winners[i, 1] := Next;
        ReplayGames (i)
      END
  END;

BEGIN
  NumPiles := 0;
  InitPilesArray (Piles);
  InitPilesArray (Links);
  InitWinnersArray (Winners);

  IF MaxSortSize < iLast - iFirst + 1 THEN
    BEGIN
      Write ('This subarray is too large for the program.');
      WriteLn;
      HALT
    END
  ELSE
    BEGIN
      Deal;
      KWayMerge
    END
END;

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);

  Write ('unsorted  ');
  FOR i := 10 TO 34 DO
    BEGIN
      Write (' ');
      Write (ExampleNumbers[i])
    END;
  WriteLn;
  Write ('sorted    ');
  FOR i := 0 TO 24 DO
    BEGIN
      Write (' ');
      Write (ExampleNumbers[SortedIndices[i]]);
    END;
  WriteLn
END.
Output:
$ fpc PatienceSortTask.pas && ./PatienceSortTask
Free Pascal Compiler version 3.2.2 [2021/06/27] for x86_64
Copyright (c) 1993-2021 by Florian Klaempfl and others
Target OS: Linux for x86-64
Compiling PatienceSortTask.pas
Linking PatienceSortTask
278 lines compiled, 0.1 sec
unsorted   22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90
sorted     2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98

Perl

Translation of: Raku
sub patience_sort {
    my @s = [shift];
    for my $card (@_) {
	my @t = grep { $_->[-1] > $card } @s;
	if (@t) { push @{shift(@t)}, $card }
	else { push @s, [$card] }
    }
    my @u;
    while (my @v = grep @$_, @s) {
	my $value = (my $min = shift @v)->[-1];
	for (@v) {
	    ($min, $value) =
	    ($_, $_->[-1]) if $_->[-1] < $value
	}
	push @u, pop @$min;
    }
    return @u
}

print join ' ', patience_sort qw(4 3 6 2 -1 13 12 9);
Output:
-1 2 3 4 6 9 12 13

Phix

with javascript_semantics

function patience_sort(sequence s)
    -- create list of sorted lists
    sequence piles = {}
    for i=1 to length(s) do
        object n = s[i]
        for p=1 to length(piles)+1 do
            if p>length(piles) then
                piles = append(piles,{n})
            elsif n>=piles[p][$] then
                piles[p] = append(deep_copy(piles[p]),n)
                exit
            end if
        end for
    end for
    -- merge sort the piles
    sequence res = ""
    while length(piles) do
        integer idx = smallest(piles,return_index:=true)
        res = append(res,piles[idx][1])
        if length(piles[idx])=1 then
            piles[idx..idx] = {}
        else
            piles[idx] = piles[idx][2..$]
        end if
    end while
    return res
end function
 
constant tests = {{4,65,2,-31,0,99,83,782,1},
                  {0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15},
                  "nonzerosum",
                  {"dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"}}
 
for i=1 to length(tests) do
    pp(patience_sort(tests[i]),{pp_IntCh,false})
end for
Output:
{-31,0,1,2,4,65,83,99,782}
{0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15}
`emnnoorsuz`
{`ant`, `ape`, `ass`, `cat`, `cow`, `dog`, `gnu`, `man`, `pig`}

PHP

<?php
class PilesHeap extends SplMinHeap {
    public function compare($pile1, $pile2) {
        return parent::compare($pile1->top(), $pile2->top());
    }
}

function patience_sort(&$n) {
    $piles = array();
    // sort into piles
    foreach ($n as $x) {
        // binary search
        $low = 0; $high = count($piles)-1;
        while ($low <= $high) {
            $mid = (int)(($low + $high) / 2);
            if ($piles[$mid]->top() >= $x)
                $high = $mid - 1;
            else
                $low = $mid + 1;
        }
        $i = $low;
        if ($i == count($piles))
            $piles[] = new SplStack();
        $piles[$i]->push($x);
    }

    // priority queue allows us to merge piles efficiently
    $heap = new PilesHeap();
    foreach ($piles as $pile)
        $heap->insert($pile);
    for ($c = 0; $c < count($n); $c++) {
        $smallPile = $heap->extract();
        $n[$c] = $smallPile->pop();
        if (!$smallPile->isEmpty())
        $heap->insert($smallPile);
    }
    assert($heap->isEmpty());
}

$a = array(4, 65, 2, -31, 0, 99, 83, 782, 1);
patience_sort($a);
print_r($a);
?>
Output:
Array
(
    [0] => -31
    [1] => 0
    [2] => 1
    [3] => 2
    [4] => 4
    [5] => 65
    [6] => 83
    [7] => 99
    [8] => 782
)

PicoLisp

(de leftmost (Lst N H)
   (let L 1
      (while (<= L H)
         (use (X)
            (setq X (/ (+ L H) 2))
         (if (>= (caar (nth Lst X)) N)
               (setq H (dec X))
               (setq L (inc X)) ) ) )
      L ) )

(de patience (Lst)
   (let (L (cons (cons (car Lst)))  C 1  M NIL)
      (for N (cdr Lst)
         (let I (leftmost L N C)
            (and
               (> I C)
               (conc L (cons NIL))
               (inc 'C) )
            (push (nth L I) N) ) )
      (make
         (loop
            (setq M (cons 0 T))
            (for (I . Y) L
               (let? S (car Y)
                  (and
                     (< S (cdr M))
                     (setq M (cons I S)) ) ) )
            (T (=T (cdr M)))
            (link (pop (nth L (car M)))) ) ) ) )
         
(println
   (patience (4 65 2 -31 0 99 83 782 1)) )
   
(bye)

Prolog

patience_sort(UnSorted,Sorted) :-
	make_piles(UnSorted,[],Piled),
	merge_piles(Piled,[],Sorted).

make_piles([],P,P).
make_piles([N|T],[],R) :-
	make_piles(T,[[N]],R).
make_piles([N|T],[[P|Pnt]|Tp],R) :-
	N =< P,
	make_piles(T,[[N,P|Pnt]|Tp],R).
make_piles([N|T],[[P|Pnt]|Tp],R) :-
	N > P,
	make_piles(T,[[N],[P|Pnt]|Tp], R).
	
merge_piles([],M,M).
merge_piles([P|T],L,R) :-
	merge_pile(P,L,Pl),
	merge_piles(T,Pl,R).
	
merge_pile([],M,M).
merge_pile(M,[],M).
merge_pile([N|T1],[N|T2],[N,N|R]) :-
	merge_pile(T1,T2,R).
merge_pile([N|T1],[P|T2],[P|R]) :-
	N > P,
	merge_pile([N|T1],T2,R).
merge_pile([N|T1],[P|T2],[N|R]) :-
	N < P,
	merge_pile(T1,[P|T2],R).
Output:
?- patience_sort([4, 65, 2, -31, 0, 99, 83, 782, 1],Sorted).
Sorted = [-31, 0, 1, 2, 4, 65, 83, 99, 782] .

Python

Works with: Python version 2.7+ and 3.2+
(for functools.total_ordering)
from functools import total_ordering
from bisect import bisect_left
from heapq import merge

@total_ordering
class Pile(list):
    def __lt__(self, other): return self[-1] < other[-1]
    def __eq__(self, other): return self[-1] == other[-1]

def patience_sort(n):
    piles = []
    # sort into piles
    for x in n:
        new_pile = Pile([x])
        i = bisect_left(piles, new_pile)
        if i != len(piles):
            piles[i].append(x)
        else:
            piles.append(new_pile)

    # use a heap-based merge to merge piles efficiently
    n[:] = merge(*[reversed(pile) for pile in piles])

if __name__ == "__main__":
    a = [4, 65, 2, -31, 0, 99, 83, 782, 1]
    patience_sort(a)
    print a
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

Quackery

uses bsearchwith from Binary search#Quackery and merge from Merge sort#Quackery.

  [ dip [ 0 over size rot ]
    nested bsearchwith
      [ -1 peek
        dip [ -1 peek ] > ]
    drop ]                       is searchpiles ( [ n --> n )

  [ dup size dup 1 = iff
    [ drop 0 peek ] done
    2 / split
    recurse swap recurse
    merge ]                      is k-merge     (   [ --> [ )

  [ 1 split dip nested
    witheach
      [ 2dup dip dup
        searchpiles
        over size over = iff
          [ 2drop
            nested nested join ]
        else
          [ dup dip
              [ peek swap join
                swap ]
            poke ] ]
    k-merge ]                    is patience-sort ( [ --> [ )


  ' [ 0 1 2 3 4 5 6 7 8 9 ]
  shuffle dup echo cr 
  patience-sort echo
Output:
[ 6 9 2 3 1 7 8 4 0 5 ]
[ 0 1 2 3 4 5 6 7 8 9 ]

Racket

#lang racket/base
(require racket/match racket/list)

;; the car of a pile is the "bottom", i.e. where we place a card
(define (place-greedily ps-in c <?)
  (let inr ((vr null) (ps ps-in))
    (match ps
      [(list) (reverse (cons (list c) vr))]
      [(list (and psh (list ph _ ...)) pst ...)
       #:when (<? c ph) (append (reverse (cons (cons c psh) vr)) pst)]
      [(list psh pst ...) (inr (cons psh vr) pst)])))

(define (patience-sort cs-in <?)
  ;; Scatter
  (define piles
    (let scatter ((cs cs-in) (ps null))
      (match cs [(list) ps] [(cons a d) (scatter d (place-greedily ps a <?))])))
  ;; Gather
  (let gather ((rv null) (ps piles))
    (match ps
      [(list) (reverse rv)]
      [(list psh pst ...)
       (let scan ((least psh) (seens null) (unseens pst))
         (define least-card (car least))
         (match* (unseens least)
           [((list) (list l)) (gather (cons l rv) seens)]
           [((list) (cons l lt)) (gather (cons l rv) (cons lt seens))]
           [((cons (and ush (cons u _)) ust) (cons l _))
            #:when (<? l u) (scan least (cons ush seens) ust)]
           [((cons ush ust) least) (scan ush (cons least seens) ust)]))])))

(patience-sort (shuffle (for/list ((_ 10)) (random 7))) <)
Output:
'(1 1 2 2 2 3 4 4 4 5)

Raku

(formerly Perl 6)

Works with: rakudo version 2015-10-22
multi patience(*@deck) {
    my @stacks;
    for @deck -> $card {
        with @stacks.first: $card before *[*-1] -> $stack {
            $stack.push: $card;
        }
        else {
            @stacks.push: [$card];
        }
    }
    gather while @stacks {
        take .pop given min :by(*[*-1]), @stacks;
        @stacks .= grep: +*;
    }
}

say ~patience ^10 . pick(*);
Output:
0 1 2 3 4 5 6 7 8 9

REXX

The items to be sorted can be any form of REXX number, not just integers;   the items may also be character strings.

Duplicates are also sorted correctly.

/*REXX program sorts a list of things (or items) using the  patience sort  algorithm.   */
parse arg xxx;     say ' input: '      xxx       /*obtain a list of things from the C.L.*/
n= words(xxx);     #= 0;       !.= 1             /*N:  # of things;  #:  number of piles*/
@.=                                              /* [↓]  append or create a pile  (@.j) */
   do i=1  for n;              q= word(xxx, i)   /* [↓]  construct the piles of things. */
                do j=1  for #                    /*add the   Q   thing (item) to a pile.*/
                if q>word(@.j,1)  then iterate   /*Is this item greater?   Then skip it.*/
                @.j= q  @.j;           iterate i /*add this item to the top of the pile.*/
                end   /*j*/                      /* [↑]  find a pile, or make a new pile*/
   #= # + 1                                      /*increase the pile count.             */
   @.#= q                                        /*define a new pile.                   */
   end                /*i*/                      /*we are done with creating the piles. */
$=                                               /* [↓]   build a thingy list from piles*/
   do k=1  until  words($)==n                    /*pick off the smallest from the piles.*/
   _=                                            /*this is the smallest thingy so far···*/
          do m=1  for  #;     z= word(@.m, !.m)  /*traipse through many piles of items. */
          if z==''  then iterate                 /*Is this pile null?    Then skip pile.*/
          if _==''  then _= z                    /*assume this one is the low pile value*/
          if _>=z   then do;  _= z;  p= m;  end  /*found a low value in a pile of items.*/
          end   /*m*/                            /*the traipsing is done, we found a low*/
   $= $ _                                        /*add to the output thingy  ($)  list. */
   !.p= !.p + 1                                  /*bump the thingy pointer in pile  P.  */
   end          /*k*/                            /* [↑]  each iteration finds a low item*/
                                                 /* [↓]  string  $  has a leading blank.*/
say 'output: '       strip($)                    /*stick a fork in it,  we're all done. */
output   when using the input of:   4 65 2 -31 0 99 83 782 7.88 1e1 1
 input:  4 65 2 -31 0 99 83 782 7.88 1e1 1
output:  -31 0 1 2 4 7.88 1e1 65 83 99 782
output   when using the input of:   dog cow cat ape ant man pterodactyl
 input:  dog cow cat ape ant man pterodactyl
output:  ant ape cat cow dog man pterodactyl

Ruby

class Array
  def patience_sort
    piles = []
    each do |i|
      if (idx = piles.index{|pile| pile.last <= i})
        piles[idx] << i
      else
        piles << [i]    #create a new pile
      end
    end
    # merge piles
    result = []
    until piles.empty?
      first = piles.map(&:first)
      idx = first.index(first.min)
      result << piles[idx].shift
      piles.delete_at(idx) if piles[idx].empty?
    end
    result
  end
end

a = [4, 65, 2, -31, 0, 99, 83, 782, 1]
p a.patience_sort
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

Scala

Library: Scala Concise
Works with: Scala version 2.13
import scala.collection.mutable

object PatienceSort extends App {
  def sort[A](source: Iterable[A])(implicit bound: A => Ordered[A]): Iterable[A] = {
    val  piles = mutable.ListBuffer[mutable.Stack[A]]()

    def PileOrdering: Ordering[mutable.Stack[A]] =
      (a: mutable.Stack[A], b: mutable.Stack[A]) => b.head.compare(a.head)

    // Use a priority queue, to simplify extracting minimum elements.
    val pq = new mutable.PriorityQueue[mutable.Stack[A]]()(PileOrdering)

    // Create ordered piles of elements
    for (elem <- source) {
      // Find leftmost "possible" pile
      // If there isn't a pile available, add a new one.
      piles.find(p => p.head >= elem) match {
        case Some(p) => p.push(elem)
        case _ => piles += mutable.Stack(elem)
      }
    }

    pq ++= piles

    // Return a new list, by taking the smallest stack head
    // until all stacks are empty.
    for (_ <- source) yield {
      val smallestList = pq.dequeue
      val smallestVal = smallestList.pop

      if (smallestList.nonEmpty) pq.enqueue(smallestList)
      smallestVal
    }
  }

  println(sort(List(4, 65, 2, -31, 0, 99, 83, 782, 1)))
}

Scheme

Works with: Gauche Scheme version 0.9.11-p1


The program is in R7RS Small Scheme plus some SRFIs. You can run the program also under CHICKEN Scheme 5.3.0 if you have the necessary eggs installed. For CHICKEN you will have to compile with the "-R r7rs" option.

For the k-way merge, I implemented the tournament tree algorithm.


(define-library (rosetta-code k-way-merge)

  (export k-way-merge)

  (import (scheme base))
  (import (scheme case-lambda))
  (import (only (srfi 1) car+cdr))
  (import (only (srfi 1) reverse!))
  (import (only (srfi 132) list-merge))
  (import (only (srfi 151) bitwise-xor))

  (begin

    ;;
    ;; The algorithm employed here is "tournament tree" as in the
    ;; following article, which is based on Knuth, volume 3.
    ;;
    ;;   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 a Scheme vector, and one can find an
    ;; opponent quickly by simply toggling the least significant bit
    ;; of a competitor's array index.
    ;;

    (define // truncate-quotient)

    (define-record-type <infinity>
      (make-infinity)
      infinity?)

    (define infinity (make-infinity))

    (define (next-power-of-two n)
      ;; This need not be a fast implementation. It can assume n >= 3,
      ;; because one can use an ordinary 2-way merge for n = 2.
      (let loop ((pow2 4))
        (if (<= n pow2)
            pow2
            (loop (+ pow2 pow2)))))

    (define (play-game <? x y)
      (cond ((infinity? x) #f)
            ((infinity? y) #t)
            (else (not (<? y x)))))

    (define (build-tree <? heads)
      ;; We do not use vector indices of zero. Thus our indexing is
      ;; 1-based.
      (let* ((total-external-nodes (next-power-of-two
                                    (vector-length heads)))
             (total-nodes (- (* 2 total-external-nodes) 1))
             (winners (make-vector (+ total-nodes 1))))
        (do ((i 0 (+ i 1)))
            ((= i total-external-nodes))
          (let ((j (+ total-external-nodes i)))
            (if (< i (vector-length heads))
                (let ((entry (cons (vector-ref heads i) i)))
                  (vector-set! winners j entry))
                (let ((entry (cons infinity i)))
                  (vector-set! winners j entry)))))
        (let loop ((istart total-external-nodes))
          (do ((i istart (+ i 2)))
              ((= i (+ istart istart)))
            (let* ((i1 i)
                   (i2 (bitwise-xor i 1))
                   (elem1 (car (vector-ref winners i1)))
                   (elem2 (car (vector-ref winners i2)))
                   (wins1? (play-game <? elem1 elem2))
                   (iwinner (if wins1? i1 i2))
                   (winner (vector-ref winners iwinner))
                   (iparent (// i 2)))
              (vector-set! winners iparent winner)))
          (if (= istart 2)
              winners
              (loop (// istart 2))))))

    (define (replay-games <? winners i)
      (let loop ((i i))
        (unless (= i 1)
          (let* ((i1 i)
                 (i2 (bitwise-xor i 1))
                 (elem1 (car (vector-ref winners i1)))
                 (elem2 (car (vector-ref winners i2)))
                 (wins1? (play-game <? elem1 elem2))
                 (iwinner (if wins1? i1 i2))
                 (winner (vector-ref winners iwinner))
                 (iparent (// i 2)))
            (vector-set! winners iparent winner)
            (loop iparent)))))

    (define (get-next lst)
      (if (null? lst)
          (values infinity lst)      ; End of list. Return a sentinel.
          (car+cdr lst)))

    (define (merge-lists <? lists)
      (let* ((heads (list->vector (map car lists)))
             (tails (list->vector (map cdr lists))))
        (let ((winners (build-tree <? heads)))
          (let loop ((outputs '()))
            (let-values (((winner-value winner-index)
                          (car+cdr (vector-ref winners 1))))
              (if (infinity? winner-value)
                  (reverse! outputs)
                  (let-values
                      (((hd tl)
                        (get-next (vector-ref tails winner-index))))
                    (vector-set! tails winner-index tl)
                    (let ((entry (cons hd winner-index))
                          (i (+ (// (vector-length winners) 2)
                                winner-index)))
                      (vector-set! winners i entry)
                      (replay-games <? winners i)
                      (loop (cons winner-value outputs))))))))))

    (define k-way-merge
      (case-lambda
        ((<? lst1) lst1)
        ((<? lst1 lst2) (list-merge <? lst1 lst2))
        ((<? . lists) (merge-lists <? lists))))

    )) ;; library (rosetta-code k-way-merge)

(define-library (rosetta-code patience-sort)

  (export patience-sort)

  (import (scheme base))
  (import (rosetta-code k-way-merge))

  (begin

    (define (find-pile <? x num-piles piles)
      ;;
      ;; Do a Bottenbruch search for the leftmost pile whose top is
      ;; greater than or equal to x. The search starts at 0 and ends
      ;; at (- num-piles 1). 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
      ;;
      (let loop ((j 0)
                 (k (- num-piles 1)))
        (if (= j k)
            (if (or (not (= j (- num-piles 1)))
                    (not (<? (car (vector-ref piles j)) x)))
                j                      ; x fits onto one of the piles.
                (+ j 1))               ; x needs a new pile.
            (let ((i (floor-quotient (+ j k) 2)))
              (if (<? (car (vector-ref piles i)) x)
                  ;; x is greater than the element at i.
                  (loop (+ i 1) k)
                  (loop j i))))))

    (define (resize-table table-size num-piles piles)
      ;; If necessary, allocate a new table of larger size.
      (if (not (= num-piles table-size))
          (values table-size piles)
          (let* ((new-size (* table-size 2))
                 (new-piles (make-vector new-size)))
            (vector-copy! new-piles 0 piles)
            (values new-size new-piles))))

    (define initial-table-size 64)

    (define (deal <? lst)
      (let loop ((lst lst)
                 (table-size initial-table-size)
                 (num-piles 0)
                 (piles (make-vector initial-table-size)))
        (cond ((null? lst) (values num-piles piles))
              ((zero? num-piles)
               (vector-set! piles 0 (list (car lst)))
               (loop (cdr lst) table-size 1 piles))
              (else
               (let* ((x (car lst))
                      (i (find-pile <? x num-piles piles)))
                 (if (= i num-piles)
                     (let-values (((table-size piles)
                                   (resize-table table-size num-piles
                                                 piles)))
                       ;; Start a new pile at the far right.
                       (vector-set! piles num-piles (list x))
                       (loop (cdr lst) table-size (+ num-piles 1)
                             piles))
                     (begin
                       (vector-set! piles i
                                    (cons x (vector-ref piles i)))
                       (loop (cdr lst) table-size num-piles
                             piles))))))))

    (define (patience-sort <? lst)
      (let-values (((num-piles piles) (deal <? lst)))
        (apply k-way-merge
               (cons <? (vector->list piles 0 num-piles)))))

    )) ;; library (rosetta-code patience-sort)

;;--------------------------------------------------------------------
;;
;; A little demonstration.
;;

(import (scheme base))
(import (scheme write))
(import (rosetta-code patience-sort))

(define example-numbers '(22 15 98 82 22 4 58 70 80 38 49 48 46 54 93
                             8 54 2 72 84 86 76 53 37 90))
(display "unsorted   ")
(write example-numbers)
(newline)
(display "sorted     ")
(write (patience-sort < example-numbers))
(newline)

;;--------------------------------------------------------------------
Output:
$ gosh patience_sort_task.scm
unsorted   (22 15 98 82 22 4 58 70 80 38 49 48 46 54 93 8 54 2 72 84 86 76 53 37 90)
sorted     (2 4 8 15 22 22 37 38 46 48 49 53 54 54 58 70 72 76 80 82 84 86 90 93 98)

Sidef

func patience(deck) {
  var stacks = [];
  deck.each { |card|
    given (stacks.first { card < .last }) { |stack|
      case (defined stack) {
        stack << card
      }
      default {
        stacks << [card]
      }
    }
  }

  gather {
    while (stacks) {
      take stacks.min_by { .last }.pop
      stacks.grep!{ !.is_empty }
    }
  }
}

var a = [4, 65, 2, -31, 0, 99, 83, 782, 1]
say patience(a)
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]

Standard ML

Works with: SML/NJ
structure PilePriority = struct
  type priority = int
  fun compare (x, y) = Int.compare (y, x) (* we want min-heap *)
  type item = int list
  val priority = hd
end

structure PQ = LeftPriorityQFn (PilePriority)

fun sort_into_piles n =
  let
    val piles = DynamicArray.array (length n, [])
    fun bsearch_piles x =
      let
        fun aux (lo, hi) =
          if lo > hi then
            lo
          else
            let
              val mid = (lo + hi) div 2
            in
              if hd (DynamicArray.sub (piles, mid)) < x then
                aux (mid+1, hi)
              else
                aux (lo, mid-1)
            end
      in
        aux (0, DynamicArray.bound piles)
      end
    fun f x =
      let
        val i = bsearch_piles x 
      in
        DynamicArray.update (piles, i, x :: DynamicArray.sub (piles, i))
      end
  in
    app f n;
    piles
  end

fun merge_piles piles =
  let
    val heap = DynamicArray.foldl PQ.insert PQ.empty piles
    fun f (heap, acc) =
      case PQ.next heap of
        NONE => acc
      | SOME (x::xs, heap') =>
        f ((if null xs then heap' else PQ.insert (xs, heap')),
           x::acc)
  in
    rev (f (heap, []))
  end

fun patience_sort n =
  merge_piles (sort_into_piles n)

Usage:

- patience_sort [4, 65, 2, ~31, 0, 99, 83, 782, 1];
val it = [~31,0,1,2,4,65,83,99,782] : int list

Tcl

Works with: Tcl version 8.6

This uses the -bisect option to lsearch in order to do an efficient binary search (in combination with -index end, which means that the search is indexed by the end of the sublist).

package require Tcl 8.6

proc patienceSort {items} {
    # Make the piles
    set piles {}
    foreach item $items {
	set p [lsearch -bisect -index end $piles $item]
	if {$p == -1} {
	    lappend piles [list $item]
	} else {
	    lset piles $p end+1 $item
	}
    }
    # Merge the piles; no suitable builtin, alas
    set indices [lrepeat [llength $piles] 0]
    set result {}
    while 1 {
	set j 0
	foreach pile $piles i $indices {
	    set val [lindex $pile $i]
	    if {$i < [llength $pile] && (![info exist min] || $min > $val)} {
		set k $j
		set next [incr i]
		set min $val
	    }
	    incr j
	}
	if {![info exist min]} break
	lappend result $min
	unset min
	lset indices $k $next
    }
    return $result
}

Demonstrating:

puts [patienceSort {4 65 2 -31 0 99 83 782 1}]
Output:
-31 0 1 2 4 65 83 99 782

Wren

Translation of: Kotlin
Library: Wren-sort
import "./sort" for Cmp

var patienceSort = Fn.new { |a|
    var size = a.count
    if (size < 2) return
    var cmp = Cmp.default(a[0])
    var piles = []
    for (e in a) {
        var outer = false
        for (pile in piles) {
            if (cmp.call(pile[-1], e) > 0) {
                pile.add(e)
                outer = true
                break
            }
        }
        if (!outer) piles.add([e])
    }
    for (i in 0...size) {
        var min = piles[0][-1]
        var minPileIndex = 0
        for (j in 1...piles.count) {
            if (cmp.call(piles[j][-1], min) < 0) {
                min = piles[j][-1]
                minPileIndex = j
            }
        }
        a[i] = min
        var minPile = piles[minPileIndex]
        minPile.removeAt(-1)
        if (minPile.count == 0) piles.removeAt(minPileIndex)
    }
}

var ia = [4, 65, 2, -31, 0, 99, 83, 782, 1]
patienceSort.call(ia)
System.print(ia)

var ca = ["n", "o", "n", "z", "e", "r", "o", "s", "u", "m"]
patienceSort.call(ca)
System.print(ca)

var sa = ["dog", "cow", "cat", "ape", "ant", "man", "pig", "ass", "gnu"]
patienceSort.call(sa)
System.print(sa)
Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
[e, m, n, n, o, o, r, s, u, z]
[ant, ape, ass, cat, cow, dog, gnu, man, pig]

zkl

fcn patienceSort(ns){
   piles:=L();
   foreach n in (ns){ newPile:=True;   // create list of sorted lists
      foreach p in (piles){
	 if(n>=p[-1]) { p.append(n); newPile=False; break; }
      }
      if(newPile)piles.append(L(n));
   }
   // merge sort the piles
   r:=Sink(List); while(piles){
      mins:=piles.apply("get",0).enumerate();
      min :=mins.reduce(fcn(a,b){ (a[1]<b[1]) and a or b },mins[0])[0];
      r.write(piles[min].pop(0));
      if(not piles[min]) piles.del(min);
   }
   r.close();
}
T(T(3,2,6,4,3,5,1),
  T(4,65,2,-31,0,99,83,782,1), 
  T(0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15),
  "foobar")
.pump(Console.println,patienceSort);
Output:
L(1,2,3,3,4,5,6)
L(-31,0,1,2,4,65,83,99,782)
L(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)
L("a","b","f","o","o","r")