content: 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]
  