Sorting algorithms/Patience sort
![Task](http://static.miraheze.org/rosettacodewiki/thumb/b/ba/Rcode-button-task-crushed.png/64px-Rcode-button-task-crushed.png)
You are encouraged to solve this task according to the task description, using any language you may know.
Sorting Algorithm
This is a sorting algorithm. It may be applied to a set of data in order to sort it.
For comparing various sorts, see compare sorts.
For other sorting algorithms, see sorting algorithms, or:
Heap sort | Merge sort | Patience sort | Quick sort
O(n log2n) sorts
Shell Sort
O(n2) sorts
Bubble sort |
Cocktail sort |
Cocktail sort with shifting bounds |
Comb sort |
Cycle sort |
Gnome sort |
Insertion sort |
Selection sort |
Strand sort
other sorts
Bead sort |
Bogo sort |
Common sorted list |
Composite structures sort |
Custom comparator sort |
Counting sort |
Disjoint sublist sort |
External sort |
Jort sort |
Lexicographical sort |
Natural sorting |
Order by pair comparisons |
Order disjoint list items |
Order two numerical lists |
Object identifier (OID) sort |
Pancake sort |
Quickselect |
Permutation sort |
Radix sort |
Ranking methods |
Remove duplicate elements |
Sleep sort |
Stooge sort |
[Sort letters of a string] |
Three variable sort |
Topological sort |
Tree sort
Sort an array of numbers (of any convenient size) into ascending order using Patience sorting.
- Related task
11l
<lang 11l>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)</lang>
- 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
<lang AArch64 Assembly> /* 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" </lang>
Ada
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.
<lang ada>----------------------------------------------------------------------
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;
</lang>
- 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
<lang 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</lang>
- Output:
<lang applescript>{-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}</lang>
ARM Assembly
<lang ARM Assembly> /* 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" </lang>
ATS
A patience sort for arrays of non-linear elements
The sort routine returns an array of indices into the original array, which is left unmodified.
<lang ats>(*------------------------------------------------------------------*)
- 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} .. (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} .. (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
(*------------------------------------------------------------------*)</lang>
- 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 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.
<lang ats>//-------------------------------------------------------------------- // // 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
(*------------------------------------------------------------------*)</lang>
- 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
<lang 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
}</lang> Examples:<lang AutoHotkey>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</lang>
- 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 <lang C>
- 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; } </lang> 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++
<lang cpp>#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;
}</lang>
- Output:
-31, 0, 1, 2, 4, 65, 83, 99, 782,
Clojure
<lang 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])) </lang>
- Output:
[-31 0 1 2 4 65 83 99 782]
D
<lang d>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;
}</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
Elixir
<lang 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]</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
Fortran
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.
<lang fortran>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</lang>
- 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. <lang go>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)
}</lang>
- Output:
[-31 0 1 2 4 65 83 99 782]
Haskell
<lang 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]</lang>
- Output:
[-31,0,1,2,4,65,83,99,782]
Icon
<lang icon>#---------------------------------------------------------------------
- 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
- ---------------------------------------------------------------------</lang>
- 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. <lang J> 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 </lang>
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
<lang 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));
}
}</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
JavaScript
<lang 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])); </lang>
- Output:
[-30, -20, 1, 6, 9, 10, 18]
jq
Adapted from Wren
Works with gojq, the Go implementation of jq <lang 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</lang>
- 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
<lang 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)))
</lang>
- Output:
[186, 243, 255, 257, 427, 486, 513, 613, 657, 734, 866, 907]
Kotlin
<lang scala>// 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())
}</lang>
- 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
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.
<lang mercury>:- 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:</lang>
- 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
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.
<lang modula2>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.</lang>
- 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
<lang 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</lang>
- 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
<lang 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</lang> 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
<lang Pascal>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.</lang>
- 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
<lang Perl>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); </lang>
- 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
<lang 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); ?></lang>
- Output:
Array ( [0] => -31 [1] => 0 [2] => 1 [3] => 2 [4] => 4 [5] => 65 [6] => 83 [7] => 99 [8] => 782 )
PicoLisp
<lang 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)</lang>
Prolog
<lang 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).</lang>
- Output:
?- patience_sort([4, 65, 2, -31, 0, 99, 83, 782, 1],Sorted). Sorted = [-31, 0, 1, 2, 4, 65, 83, 99, 782] .
Python
(for functools.total_ordering)
<lang python>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</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
Quackery
uses bsearchwith
from Binary search#Quackery and merge
from Merge sort#Quackery.
<lang 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</lang>
- Output:
[ 6 9 2 3 1 7 8 4 0 5 ] [ 0 1 2 3 4 5 6 7 8 9 ]
Racket
<lang 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))) <)</lang>
- Output:
'(1 1 2 2 2 3 4 4 4 5)
Raku
(formerly Perl 6)
<lang perl6>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(*);</lang>
- 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. <lang rexx>/*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. */</lang>
- 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
<lang 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</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
Scala
<lang Scala>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)))
}</lang>
Scheme
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.
<lang scheme>(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)
- --------------------------------------------------------------------</lang>
- 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
<lang ruby>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)</lang>
- Output:
[-31, 0, 1, 2, 4, 65, 83, 99, 782]
Standard ML
<lang sml>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)</lang>
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
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).
<lang tcl>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
}</lang> Demonstrating: <lang tcl>puts [patienceSort {4 65 2 -31 0 99 83 782 1}]</lang>
- Output:
-31 0 1 2 4 65 83 99 782
Wren
<lang ecmascript>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)</lang>
- 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
<lang 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();
}</lang> <lang zkl>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);</lang>
- 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")
- Programming Tasks
- Sorting Algorithms
- Sorting
- 11l
- AArch64 Assembly
- Ada
- AppleScript
- ARM Assembly
- ATS
- AutoHotkey
- C
- C++
- Clojure
- D
- Elixir
- Fortran
- Go
- Haskell
- Icon
- J
- Java
- JavaScript
- Jq
- Julia
- Kotlin
- Mercury
- Modula-2
- Nim
- OCaml
- Pascal
- Perl
- Phix
- PHP
- PicoLisp
- Prolog
- Python
- Quackery
- Racket
- Raku
- REXX
- Ruby
- Scala
- Scala Concise
- Scala Time complexity O(n log n)
- Scheme
- Sidef
- Standard ML
- Tcl
- Wren
- Wren-sort
- Zkl