Initial data commit

Task/Sorting-algorithms-Patience-sort/Haskell/sorting-algorithms-patience-sort.hs

@@ -0,0 +1,48 @@
+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]