module Data.Permute.MPermute (
MPermute,
newPermute,
newPermute_,
newListPermute,
newSwapsPermute,
newCopyPermute,
copyPermute,
setIdentity,
getElem,
setElem,
swapElems,
getSize,
getElems,
setElems,
isValid,
getInverse,
copyInverse,
setNext,
setPrev,
getSwaps,
getInvSwaps,
getSort,
getSortBy,
getOrder,
getOrderBy,
getRank,
getRankBy,
freeze,
unsafeFreeze,
thaw,
unsafeThaw,
unsafeNewListPermute,
unsafeNewSwapsPermute,
unsafeGetElem,
unsafeSetElem,
unsafeSwapElems,
) where
import Control.Monad
import Control.Monad.ST
import Data.Function( on )
import qualified Data.List as List
import System.IO.Unsafe( unsafeInterleaveIO )
import Data.Permute.Base
import Data.Permute.IOBase
class (Monad m) => MPermute p m | p -> m, m -> p where
getSize :: p -> m Int
newPermute :: Int -> m p
newPermute_ :: Int -> m p
unsafeGetElem :: p -> Int -> m Int
unsafeSetElem :: p -> Int -> Int -> m ()
unsafeSwapElems :: p -> Int -> Int -> m ()
getElems :: p -> m [Int]
setElems :: p -> [Int] -> m ()
unsafeFreeze :: p -> m Permute
unsafeThaw :: Permute -> m p
unsafeInterleaveM :: m a -> m a
newListPermute :: (MPermute p m) => Int -> [Int] -> m p
newListPermute n is = do
p <- unsafeNewListPermute n is
valid <- isValid p
when (not valid) $ fail "invalid permutation"
return p
unsafeNewListPermute :: (MPermute p m) => Int -> [Int] -> m p
unsafeNewListPermute n is = do
p <- newPermute_ n
setElems p is
return p
newSwapsPermute :: (MPermute p m) => Int -> [(Int,Int)] -> m p
newSwapsPermute = newSwapsPermuteHelp swapElems
unsafeNewSwapsPermute :: (MPermute p m) => Int -> [(Int,Int)] -> m p
unsafeNewSwapsPermute = newSwapsPermuteHelp unsafeSwapElems
newSwapsPermuteHelp :: (MPermute p m) => (p -> Int -> Int -> m ())
-> Int -> [(Int,Int)] -> m p
newSwapsPermuteHelp swap n ss = do
p <- newPermute n
mapM_ (uncurry $ swap p) ss
return p
newCopyPermute :: (MPermute p m) => p -> m p
newCopyPermute p = do
n <- getSize p
p' <- newPermute_ n
copyPermute p' p
return p'
copyPermute :: (MPermute p m) => p -> p -> m ()
copyPermute dst src =
getElems src >>= setElems dst
setIdentity :: (MPermute p m) => p -> m ()
setIdentity p = do
n <- getSize p
setElems p [0 .. n1]
getElem :: (MPermute p m) => p -> Int -> m Int
getElem p i = do
n <- getSize p
when (i < 0 || i >= n) $ fail "getElem: invalid index"
unsafeGetElem p i
setElem :: (MPermute p m) => p -> Int -> Int -> m ()
setElem p i x = do
n <- getSize p
when (i < 0 || i >= n) $ fail "getElem: invalid index"
unsafeSetElem p i x
swapElems :: (MPermute p m) => p -> Int -> Int -> m ()
swapElems p i j = do
n <- getSize p
when (i < 0 || i >= n || j < 0 || j >= n) $ fail "swapElems: invalid index"
unsafeSwapElems p i j
isValid :: (MPermute p m) => p -> m Bool
isValid p = do
n <- getSize p
valid <- liftM and $ validIndices n
return $! valid
where
j `existsIn` i = do
seen <- liftM (take i) $ getElems p
return $ (any (==j)) seen
isValidIndex n i = do
i' <- unsafeGetElem p i
valid <- return $ i' >= 0 && i' < n
unique <- liftM not (i' `existsIn` i)
return $ valid && unique
validIndices n = validIndicesHelp n 0
validIndicesHelp n i
| i == n = return []
| otherwise = unsafeInterleaveM $ do
a <- isValidIndex n i
as <- validIndicesHelp n (i+1)
return (a:as)
getInverse :: (MPermute p m) => p -> m p
getInverse p = do
n <- getSize p
q <- newPermute_ n
copyInverse q p
return $! q
copyInverse :: (MPermute p m) => p -> p -> m ()
copyInverse dst src = do
n <- getSize src
n' <- getSize dst
when (n /= n') $ fail "permutation size mismatch"
forM_ [0 .. n1] $ \i -> do
i' <- unsafeGetElem src i
unsafeSetElem dst i' i
setNext :: (MPermute p m) => p -> m Bool
setNext = setNextBy compare
setPrev :: (MPermute p m) => p -> m Bool
setPrev = setNextBy (flip compare)
setNextBy :: (MPermute p m) => (Int -> Int -> Ordering) -> p -> m Bool
setNextBy cmp p = do
n <- getSize p
if n > 1
then do
findLastAscent (n2) >>=
maybe (return False) (\i -> do
i' <- unsafeGetElem p i
i1' <- unsafeGetElem p (i+1)
(k,k') <- findSmallestLargerThan n i' (i+2) (i+1) i1'
unsafeSetElem p i k'
unsafeSetElem p k i'
reverseElems (i+1) (n1)
return True
)
else
return False
where
i `lt` j = cmp i j == LT
i `gt` j = cmp i j == GT
findLastAscent i = do
ascent <- isAscent i
if ascent then return (Just i) else recurse
where
recurse = if i /= 0 then findLastAscent (i1) else return Nothing
findSmallestLargerThan n i' j k k'
| j < n = do
j' <- unsafeGetElem p j
if j' `gt` i' && j' `lt` k'
then findSmallestLargerThan n i' (j+1) j j'
else findSmallestLargerThan n i' (j+1) k k'
| otherwise =
return (k,k')
isAscent i = liftM2 lt (unsafeGetElem p i) (unsafeGetElem p (i+1))
reverseElems i j
| i >= j = return ()
| otherwise = do
unsafeSwapElems p i j
reverseElems (i+1) (j1)
getSwaps :: (MPermute p m) => p -> m [(Int,Int)]
getSwaps = getSwapsHelp False
getInvSwaps :: (MPermute p m) => p -> m [(Int,Int)]
getInvSwaps = getSwapsHelp True
getSwapsHelp :: (MPermute p m) => Bool -> p -> m [(Int,Int)]
getSwapsHelp inv p = do
n <- getSize p
liftM concat $ go n 0
where
go n i | i == n = return []
| otherwise = unsafeInterleaveM $ do
i' <- unsafeGetElem p i
least <- isLeast i i'
c <- if least
then doCycle i i i'
else return []
cs <- go n (i+1)
return (c:cs)
isLeast i k
| k > i = do
k' <- unsafeGetElem p k
isLeast i k'
| k < i = return False
| otherwise = return True
doCycle start i i'
| i' == start = return []
| otherwise = unsafeInterleaveM $ do
i'' <- unsafeGetElem p i'
let s = if inv then (start,i') else (i,i')
ss <- doCycle start i' i''
return (s:ss)
freeze :: (MPermute p m) => p -> m Permute
freeze p = unsafeFreeze =<< newCopyPermute p
thaw :: (MPermute p m) => Permute -> m p
thaw p = newCopyPermute =<< unsafeThaw p
getSort :: (Ord a, MPermute p m) => Int -> [a] -> m ([a], p)
getSort = getSortBy compare
getSortBy :: (MPermute p m) => (a -> a -> Ordering) -> Int -> [a] -> m ([a], p)
getSortBy cmp n xs =
let ys = take n xs
(is,ys') = (unzip . List.sortBy (cmp `on` snd) . zip [0..]) ys
in liftM ((,) ys') $ unsafeNewListPermute n is
getOrder :: (Ord a, MPermute p m) => Int -> [a] -> m p
getOrder = getOrderBy compare
getOrderBy :: (MPermute p m) => (a -> a -> Ordering) -> Int -> [a] -> m p
getOrderBy cmp n xs =
liftM snd $ getSortBy cmp n xs
getRank :: (Ord a, MPermute p m) => Int -> [a] -> m p
getRank = getRankBy compare
getRankBy :: (MPermute p m) => (a -> a -> Ordering) -> Int -> [a] -> m p
getRankBy cmp n xs = do
p <- getOrderBy cmp n xs
getInverse p
instance MPermute (STPermute s) (ST s) where
getSize = getSizeSTPermute
newPermute = newSTPermute
newPermute_ = newSTPermute_
unsafeGetElem = unsafeGetElemSTPermute
unsafeSetElem = unsafeSetElemSTPermute
unsafeSwapElems = unsafeSwapElemsSTPermute
getElems = getElemsSTPermute
setElems = setElemsSTPermute
unsafeFreeze = unsafeFreezeSTPermute
unsafeThaw = unsafeThawSTPermute
unsafeInterleaveM = unsafeInterleaveST
instance MPermute IOPermute IO where
getSize = getSizeIOPermute
newPermute = newIOPermute
newPermute_ = newIOPermute_
unsafeGetElem = unsafeGetElemIOPermute
unsafeSetElem = unsafeSetElemIOPermute
unsafeSwapElems = unsafeSwapElemsIOPermute
getElems = getElemsIOPermute
setElems = setElemsIOPermute
unsafeFreeze = unsafeFreezeIOPermute
unsafeThaw = unsafeThawIOPermute
unsafeInterleaveM = unsafeInterleaveIO