53 lines
1.5 KiB
Haskell
53 lines
1.5 KiB
Haskell
{-# LANGUAGE FlexibleContexts, UnicodeSyntax #-}
|
||
|
||
module Main (main, lis) where
|
||
|
||
import Control.Monad.ST ( ST, runST )
|
||
import Control.Monad ( (>>=), (=<<), foldM )
|
||
import Data.Array.ST ( Ix, STArray, readArray, writeArray, newArray )
|
||
import Data.Array.MArray ( MArray )
|
||
|
||
infix 4 ≡
|
||
|
||
(≡) :: Eq α ⇒ α → α → Bool
|
||
(≡) = (==)
|
||
|
||
(∘) = (.)
|
||
|
||
|
||
lis ∷ Ord α ⇒ [α] → [α]
|
||
lis xs = runST $ do
|
||
let lxs = length xs
|
||
pileTops ← newSTArray (min 1 lxs , lxs) []
|
||
i ← foldM (stack pileTops) 0 xs
|
||
readArray pileTops i >>= return ∘ reverse
|
||
|
||
stack ∷ (Integral ι, Ord ε, Ix ι, MArray α [ε] μ)
|
||
⇒ α ι [ε] → ι → ε → μ ι
|
||
stack piles i x = do
|
||
j ← bsearch piles x i
|
||
writeArray piles j ∘ (x:) =<< if j ≡ 1 then return []
|
||
else readArray piles (j-1)
|
||
return $ if j ≡ i+1 then i+1 else i
|
||
|
||
bsearch ∷ (Integral ι, Ord ε, Ix ι, MArray α [ε] μ)
|
||
⇒ α ι [ε] → ε → ι → μ ι
|
||
bsearch piles x = go 1
|
||
where go lo hi | lo > hi = return lo
|
||
| otherwise =
|
||
do (y:_) ← readArray piles mid
|
||
if y < x then go (succ mid) hi
|
||
else go lo (pred mid)
|
||
|
||
where mid = (lo + hi) `div` 2
|
||
|
||
newSTArray ∷ Ix ι ⇒ (ι,ι) → ε → ST σ (STArray σ ι ε)
|
||
newSTArray = newArray
|
||
|
||
|
||
main ∷ IO ()
|
||
main = do
|
||
print $ lis [3, 2, 6, 4, 5, 1]
|
||
print $ lis [0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15]
|
||
print $ lis [1, 1, 1, 1]
|