Task: Sorting algorithms_Patience sort


C++: #include <iostream>
#include <vector>
#include <stack>
#include <iterator>
#include <algorithm>
#include <cassert>

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

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


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

  std::vector<Pile> piles;
  
  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);
  }

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









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(:)

    
    
    

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

    
    
    
    
    
    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

      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      
      

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

    
    
    
    
    
    
    
    
    
    
    
    
    

    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)          
       if (next /= 0) piles(i) = links(next) 
       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
         
         winners(2, total_external_nodes - 1 + i) = i
      end do

      
      winners(1, total_external_nodes :                  &
           &     total_external_nodes + num_piles - 1) = &
           &  piles(1:num_piles)

      do i = 1, num_piles
         
         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

    
    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