{-# LANGUAGE Rank2Types #-}
import Control.Monad.ST
import Control.Monad
import Control.Applicative

import Data.Array.ST
import Data.STRef
import Data.Array
import Data.List

swap :: Ix i => STArray s i e -> i -> i -> ST s ()
swap arr ix iy = do
    x <- readArray arr ix
    y <- readArray arr iy
    writeArray arr ix y
    writeArray arr iy x

mkArray :: Ix i => (i -> e) -> (i, i) -> Array i e
mkArray f bounds = runSTArray $ do
    arr <- newArray_ bounds
    forM_ (range bounds) $ \i -> writeArray arr i (f i)
    return arr

mkArray' f bounds = array bounds [ (i, f i) | i <- range bounds ]

insertsort :: (Ix i, Ord e) => Array i e -> Array i e
insertsort arr = runSTArray $ do
    starr <- thaw arr
    forM_ rng $ \i -> do
        v1 <- readArray starr i
        r_min <- newSTRef v1
        r_minpos <- newSTRef i
        forM_ (range (i, h)) $ \j -> do
            v <- readArray starr j
            min <- readSTRef r_min
            when (v < min) $ do
                writeSTRef r_min v
                writeSTRef r_minpos j
        minpos <- readSTRef r_minpos
        swap starr i minpos
    return starr
  where
    r@(l, h) = bounds arr
    rng = range r

libsort :: (Ix i, Ord e) => Array i e -> Array i e
libsort arr = array b (zip (range b) (sort (elems arr)))
  where
    b = bounds arr

-- stmapArray :: (STArray s i e -> ST s ()) -> Array i e -> Array i e

stmapArray :: Ix i => (forall s. STArray s i e -> ST s ())
                   -> Array i e -> Array i e
stmapArray f arr = runSTArray $ do
    starr <- thaw arr
    f starr
    return starr

reverseSTArr :: Ix i => STArray s i e -> ST s ()
reverseSTArr arr = do
    rng <- range <$> getBounds arr
    let ixs = takeWhile (uncurry (<)) $ zip rng (reverse rng)
    forM_ ixs (uncurry (swap arr))

reverseArr :: Ix i => Array i a -> Array i a
reverseArr = stmapArray reverseSTArr

reverseArr' :: Ix i => Array i a -> Array i a
reverseArr' arr = foldl' (\a (i, j) -> swap a i j) arr ixs
  where
    rng = range $ bounds arr
    ixs = takeWhile (uncurry (<)) $ zip rng (reverse rng)
    swap arr ix iy = arr // [ (ix, arr ! iy), (iy, arr ! ix) ]

reverseArr'' :: Ix i => Array i a -> Array i a
reverseArr'' arr = array b (zip (range b) (reverse $ elems arr))
  where
    b = bounds arr