module Data.Permutation (
Permutation,
permutation,
identity,
inverse,
size,
apply,
applyWith,
invertWith,
fromForeignPtr,
toForeignPtr,
toList,
fromList,
withPermutationPtr,
unsafePermutation,
unsafeApply,
) where
import Control.Monad ( foldM, liftM )
import Data.IntSet ( IntSet )
import qualified Data.IntSet as IntSet
import Foreign ( Ptr, ForeignPtr, mallocForeignPtrArray,
withForeignPtr, pokeArray, peekArray,
advancePtr, peek, peekElemOff, pokeElemOff )
import System.IO.Unsafe ( unsafePerformIO )
#if defined(__GLASGOW_HASKELL__)
import GHC.Base ( realWorld# )
import GHC.IOBase ( IO(IO) )
#endif
inlinePerformIO :: IO a -> a
#if defined(__GLASGOW_HASKELL__)
inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
#else
inlinePerformIO = unsafePerformIO
#endif
data Permutation =
Perm !Int
!(ForeignPtr Int)
!Int
toForeignPtr :: Permutation -> (Int, ForeignPtr Int, Int)
toForeignPtr (Perm n f o) = (n, f, o)
fromForeignPtr :: Int -> ForeignPtr Int -> Int -> Permutation
fromForeignPtr = Perm
size :: Permutation -> Int
size (Perm n _ _) = n
withPermutationPtr :: Permutation -> (Ptr Int -> IO a) -> IO a
withPermutationPtr (Perm _ fptr off) f =
withForeignPtr fptr $ \ptr ->
f (ptr `advancePtr` off)
apply :: Permutation -> Int -> Int
apply p@(Perm n _ _) i
| i < 0 || i >= n =
error $
"applyPerm: Tried to apply permutation of size `" ++ show n ++
"' to the value `" ++ show i ++ "'."
| otherwise =
unsafeApply p i
unsafeApply :: Permutation -> Int -> Int
unsafeApply p i =
inlinePerformIO $ do
withPermutationPtr p $ flip peekElemOff i
permutation :: Int -> [Int] -> Permutation
permutation n is =
let p = unsafePermutation n is
in case isValid p of
False -> error $ "Not a valid permutation."
True -> p
unsafePermutation :: Int -> [Int] -> Permutation
unsafePermutation n is =
unsafePerformIO $ do
fptr <- mallocForeignPtrArray n
withForeignPtr fptr $ \ptr -> pokeArray ptr is
return $ fromForeignPtr n fptr 0
fromList :: [Int] -> Permutation
fromList is = permutation (length is) is
toList :: Permutation -> [Int]
toList p = unsafePerformIO $
withPermutationPtr p $ peekArray (size p)
identity :: Int -> Permutation
identity n =
unsafePerformIO $ do
fptr <- mallocForeignPtrArray n
withForeignPtr fptr $ \ptr -> pokeArray ptr [0..(n1)]
return $ fromForeignPtr n fptr 0
inverse :: Permutation -> Permutation
inverse p =
let n = size p
in
unsafePerformIO $ do
fptr <- mallocForeignPtrArray n
withForeignPtr fptr $ \ptr -> do
pokeArray ptr [0..(n1)]
invertWith (swap ptr) p
return $ fromForeignPtr n fptr 0
where
swap :: Ptr Int -> Int -> Int -> IO ()
swap ptr i j = do
x <- peekElemOff ptr i
y <- peekElemOff ptr j
pokeElemOff ptr i y
pokeElemOff ptr j x
isValid :: Permutation -> Bool
isValid p@(Perm n _ _) =
unsafePerformIO $
withPermutationPtr p $ \ptr -> do
liftM and $
mapM (\i -> peekElemOff ptr i
>>= \x -> isValidI ptr x i)
[0..(n1)]
where
isValidI :: Ptr Int -> Int -> Int -> IO Bool
isValidI ptr x i =
liftM and $
sequence [ inRange x, isUnique x ptr i ]
inRange :: Int -> IO Bool
inRange x =
return $ x >= 0 && x < n
isUnique :: Int -> Ptr Int -> Int -> IO Bool
isUnique x ptr' n'
| n' == 0 =
return True
| otherwise = do
x' <- peek ptr'
if x' == x
then return False
else isUnique x (ptr' `advancePtr` 1) (n'1)
applyWith :: (Monad m) => (Int -> Int -> m ()) -> Permutation -> m ()
applyWith swap p =
let n = size p
in foldM (flip $ doCycle swap) IntSet.empty [0..(n1)] >> return ()
where
doCycle :: (Monad m) =>
(Int -> Int -> m ()) -> Int -> IntSet -> m (IntSet)
doCycle swp i visited =
if i `IntSet.member` visited
then return visited
else let visited' = IntSet.insert i visited
next = unsafeApply p i
in doCycle' swp i i next visited'
doCycle' :: (Monad m) =>
(Int -> Int -> m ()) -> Int -> Int -> Int -> IntSet -> m (IntSet)
doCycle' swp start cur next visited
| next == start =
return visited
| otherwise =
let visited' = IntSet.insert next visited
next' = unsafeApply p next
in do
swp cur next
doCycle' swp start next next' visited'
invertWith :: (Monad m) => (Int -> Int -> m ()) -> Permutation -> m ()
invertWith swap p =
let n = size p
in foldM (flip $ doCycle swap) IntSet.empty [0..(n1)] >> return ()
where
doCycle :: Monad m =>
(Int -> Int -> m ()) -> Int -> IntSet -> m (IntSet)
doCycle swp i visited =
if i `IntSet.member` visited
then return visited
else let visited' = IntSet.insert i visited
cur = unsafeApply p i
in doCycle' swp i cur visited'
doCycle' :: Monad m => (Int -> Int -> m ()) -> Int -> Int -> IntSet -> m (IntSet)
doCycle' swp start cur visited
| cur == start =
return visited
| otherwise =
let visited' = IntSet.insert cur visited
cur' = unsafeApply p cur
in do
swp start cur
doCycle' swp start cur' visited'
instance Show Permutation where
show p = "permutation " ++ show (size p) ++ " " ++ show (toList p)
instance Eq Permutation where
(==) p q = (size p == size q) && (toList p == toList q)