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