permutation-0.5.0.5/0000755000000000000000000000000012457565375012437 5ustar0000000000000000permutation-0.5.0.5/NEWS0000644000000000000000000000024712457565375013141 0ustar0000000000000000Changes in 0.5.0: * GHC 7.8.1 compatability Changes in 0.4.1: * added indexOf/getIndexOf Changes in 0.4: * Amir Livne Bar-on implemented cycle-related functions permutation-0.5.0.5/permutation.cabal0000644000000000000000000000501012457565375015766 0ustar0000000000000000name: permutation version: 0.5.0.5 homepage: https://github.com/spacekitteh/permutation synopsis: A library for permutations and combinations. description: This library includes data types for storing permutations and combinations. It implements pure and impure types, the latter of which can be modified in-place. The library uses aggressive inlining and MutableByteArray#s internally, so it is very efficient. . The main utility of the library is converting between the linear representation of a permutation and a sequence of swaps. This allows, for instance, applying a permutation or its inverse to an array with O(1) memory use. . Much of the interface for the library is based on the permutation and combination functions in the GNU Scientific Library (GSL). . category: Data Structures, Math license: BSD3 license-file: LICENSE copyright: (c) 2008. Patrick Perry author: Patrick Perry maintainer: Sophie Taylor cabal-version: >= 1.2.3 build-type: Custom tested-with: GHC ==7.8.1 extra-source-files: examples/Enumerate.hs tests/Test/Choose.hs tests/Test/Permute.hs tests/Driver.hs tests/Main.hs tests/Choose.hs tests/STChoose.hs tests/Permute.hs tests/STPermute.hs tests/Makefile NEWS library hs-source-dirs: lib exposed-modules: Data.Choose Data.Choose.MChoose Data.Choose.IO Data.Choose.ST Data.Permute Data.Permute.MPermute Data.Permute.IO Data.Permute.ST other-modules: Data.IntArray Data.Choose.Base Data.Choose.IOBase Data.Permute.Base Data.Permute.IOBase build-depends: base < 5 && >=4, QuickCheck extensions: BangPatterns, FlexibleContexts, FunctionalDependencies, MagicHash, MultiParamTypeClasses, Rank2Types, UnboxedTuples, CPP ghc-options: -Wall -O3 if impl(ghc >= 6.9) build-depends: ghc-prim permutation-0.5.0.5/Setup.lhs0000644000000000000000000000060312457565375014246 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > import System.Cmd > import System.Exit ( ExitCode(..) ) > > testing _ _ _ _ = do > err <- system "make -C tests" > system "make -s -C tests clean" > if err /= ExitSuccess > then ioError $ userError $ "failed" > else return () > > main = defaultMainWithHooks simpleUserHooks > {runTests=testing} permutation-0.5.0.5/LICENSE0000644000000000000000000000271012457565375013444 0ustar0000000000000000Copyright (c) Patrick Perry 2008 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. permutation-0.5.0.5/tests/0000755000000000000000000000000012457565375013601 5ustar0000000000000000permutation-0.5.0.5/tests/Permute.hs0000644000000000000000000001656512457565375015573 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} module Permute ( tests_Permute ) where import Control.Monad.ST import Data.Array.ST import Data.List( foldl' ) import qualified Data.List as List import Data.Maybe( fromJust ) import qualified Data.Set as Set import Data.Permute import Driver import Test.QuickCheck import Test.Permute() import qualified Test.Permute as Test prop_size_permute (Nat n) = size (permute n) == n prop_elems_permute (Nat n) = elems (permute n) == [0..(n-1)] prop_size_listPermute (ListPermute n is) = size (listPermute n is) == n prop_elems_listPermute (ListPermute n is) = elems (listPermute n is) == is prop_size_swapsPermute (SwapsPermute n ss) = size (swapsPermute n ss) == n prop_elems_swapsPermute (SwapsPermute n ss) = elems (swapsPermute n ss) == map at [0..(n-1)] where at i = foldl' doSwap i $ reverse ss doSwap k (i,j) | k == i = j | k == j = i | otherwise = k prop_size_cyclesPermute (CyclesPermute n cs) = size (cyclesPermute n cs) == n prop_elems_cyclesPermute (CyclesPermute n cs) = elems (cyclesPermute n cs) == map at [0..(n-1)] where at i = foldl' doCycle i cs doCycle k cyc = case List.findIndex (k==) cyc of Nothing -> k Just ind -> cycle cyc !! (ind + 1) prop_at = prop_at_help at prop_unsafeAt = prop_at_help unsafeAt prop_at_help a = forAll arbitrary $ \(Index n i) -> forAll (Test.permute n) $ \p -> a p i == (elems p) !! i prop_indexOf = forAll arbitrary $ \(Index n x) -> forAll (Test.permute n) $ \p -> at p (indexOf p x) == x prop_size_inverse (p :: Permute) = size (inverse p) == size p prop_elems_inverse (p :: Permute) = all (\i -> is' !! (at p i) == i) [0..(n-1)] where n = size p is' = elems (inverse p) prop_swaps (Nat n) = forAll (Test.permute n) $ \p -> forAll (vector n) $ \xs -> let xs' = applySwaps (swaps p) xs in all (\i -> xs' !! i == xs !! (at p i)) [0..(n-1)] prop_invSwaps (Nat n) = forAll (Test.permute n) $ \p -> forAll (vector n) $ \xs -> let xs' = applySwaps (invSwaps p) xs in all (\i -> xs' !! (at p i) == xs !! i) [0..(n-1)] prop_swaps_inverse (Nat n) = forAll (Test.permute n) $ \p -> forAll (vector n) $ \xs -> applySwaps (swaps $ inverse p) xs == (applySwaps (invSwaps p) xs) prop_invSwaps_inverse (Nat n) = forAll (Test.permute n) $ \p -> forAll (vector n) $ \xs -> applySwaps (invSwaps $ inverse p) xs == (applySwaps (swaps p) xs) prop_prev_permute (Nat n) = prev (permute n) == Nothing prop_next_last (Nat n) = next (listPermute n $ reverse [0..(n-1)]) == Nothing prop_next_prev (p :: Permute) = case prev p of Just p' -> p == (fromJust $ next p') Nothing -> p == permute n where n = size p prop_prev_next (p :: Permute) = case next p of Just p' -> p == (fromJust $ prev p') Nothing -> p == (listPermute n $ reverse [0..(n-1)]) where n = size p prop_fst_sort (Sort n xs) = let ys = take n xs in (fst . sort n) xs == (List.sort ys) prop_snd_sort (Sort n xs) = let ys = take n xs in applySwaps (swaps $ snd $ sort n xs) ys == (List.sort ys) prop_fst_sortBy (SortBy cmp n xs) = let ys = take n xs in (fst . sortBy cmp n) xs == (List.sortBy cmp ys) prop_snd_sortBy (SortBy cmp n xs) = let ys = take n xs in applySwaps (swaps $ snd $ sortBy cmp n xs) ys == (List.sortBy cmp ys) prop_order (Sort n xs) = let ys = take n xs in applySwaps (swaps $ order n xs) ys == (List.sort ys) prop_orderBy (SortBy cmp n xs) = let ys = take n xs in applySwaps (swaps $ orderBy cmp n xs) ys == (List.sortBy cmp ys) prop_rank (Sort n xs) = let ys = take n xs in applySwaps (invSwaps $ rank n xs) ys == (List.sort ys) prop_rankBy (SortBy cmp n xs) = let ys = take n xs in applySwaps (invSwaps $ rankBy cmp n xs) ys == (List.sortBy cmp ys) prop_swapsPermute_swaps (p :: Permute) = swapsPermute (size p) (swaps p) == p prop_isEven_permute (Nat n) = isEven (permute n) prop_isEven_swaps (p :: Permute) = isEven p == even (length (swaps p)) prop_cyclesPermute_cycles (p :: Permute) = cyclesPermute (size p) (cycles p) == p prop_cycles_cycleFrom (p :: Permute) = let n = size p cycles1 = Set.fromList (map Set.fromList (cycles p)) cycles2 = Set.fromList [Set.fromList (cycleFrom p i) | i <- [0..(n-1)]] in cycles1 == cycles2 prop_cycles_wholerange (p :: Permute) = let n = size p in List.sort (concat (cycles p)) == [0..(n-1)] prop_period_permute (Nat n) = period (permute n) == 1 prop_period_onecycle (Nat n) = n >= 1 ==> period (listPermute n $ [1..(n-1)] ++ [0]) == toInteger n tests_Permute = [ ("size . permute" , mytest prop_size_permute) , ("elems . permute" , mytest prop_elems_permute) , ("size . listPermute" , mytest prop_size_listPermute) , ("elems . listPermute" , mytest prop_elems_listPermute) , ("size . swapsPermute" , mytest prop_size_swapsPermute) , ("elems . swapsPermute" , mytest prop_elems_swapsPermute) , ("size . cyclesPermute" , mytest prop_size_cyclesPermute) , ("elems . cyclesPermute" , mytest prop_elems_cyclesPermute) , ("at" , mytest prop_at) , ("unsafeAt" , mytest prop_unsafeAt) , ("indexOf" , mytest prop_indexOf) , ("size . inverse" , mytest prop_size_inverse) , ("elems . inverse" , mytest prop_elems_inverse) , ("swaps" , mytest prop_swaps) , ("invSwaps" , mytest prop_invSwaps) , ("swaps . inverse" , mytest prop_swaps_inverse) , ("invSwaps . inverse" , mytest prop_invSwaps_inverse) , ("prev . permute" , mytest prop_prev_permute) , ("next (last permutation)" , mytest prop_next_last) , ("next . prev" , mytest prop_next_prev) , ("prev . next" , mytest prop_prev_next) , ("fst . sort" , mytest prop_fst_sort) , ("snd . sort" , mytest prop_snd_sort) , ("fst . sortBy" , mytest prop_fst_sortBy) , ("snd . sortBy" , mytest prop_snd_sortBy) , ("order" , mytest prop_order) , ("orderBy" , mytest prop_orderBy) , ("rank" , mytest prop_rank) , ("rankBy" , mytest prop_rankBy) , ("swapsPermute . swaps" , mytest prop_swapsPermute_swaps) , ("isEven . permute" , mytest prop_isEven_permute) , ("isEven == even . swaps" , mytest prop_isEven_swaps) , ("cyclesPermute . cycles" , mytest prop_cyclesPermute_cycles) , ("cycles == all cycleFrom" , mytest prop_cycles_cycleFrom) , ("concat . cycles == [0..n]" , mytest prop_cycles_wholerange) , ("period . permute" , mytest prop_period_permute) , ("period [1..n,0] == n" , mytest prop_period_onecycle) ] applySwaps :: [(Int,Int)] -> [Int] -> [Int] applySwaps ss xs = runST $ do arr <- newListArray (0,length xs - 1) xs :: ST s (STUArray s Int Int) mapM_ (swap arr) ss getElems arr where swap arr (i,j) = do i' <- readArray arr i j' <- readArray arr j writeArray arr j i' writeArray arr i j' permutation-0.5.0.5/tests/STPermute.hs0000644000000000000000000001505412457565375016032 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module STPermute ( tests_STPermute, smoke_STPermute ) where import Control.Monad import Control.Monad.ST import Data.Permute import Data.Permute.ST import Driver import Debug.Trace import Test.QuickCheck import Text.Printf import Test.Permute() import qualified Test.Permute as Test newPermute_S n = permute n prop_NewPermute (Nat n) = newPermute n `equivalent` newPermute_S n newListPermute_S n is = listPermute n is prop_NewListPermute (ListPermute n is) = newListPermute n is `equivalent` newListPermute_S n is newSwapsPermute_S n ss = swapsPermute n ss prop_NewSwapsPermute (SwapsPermute n ss) = newSwapsPermute n ss `equivalent` newSwapsPermute_S n ss prop_UnsafeNewSwapsPermute (SwapsPermute n ss) = unsafeNewSwapsPermute n ss `equivalent` newSwapsPermute_S n ss newCyclesPermute_S n cs = cyclesPermute n cs prop_NewCyclesPermute (CyclesPermute n cs) = newCyclesPermute n cs `equivalent` newCyclesPermute_S n cs prop_UnsafeNewCyclesPermute (CyclesPermute n cs) = unsafeNewCyclesPermute n cs `equivalent` newCyclesPermute_S n cs newCopyPermute_S p = (p, p) prop_NewCopyPermute = implements (\p -> newCopyPermute p >>= unsafeFreeze) (\p -> newCopyPermute_S p) copyPermute_S p q = ((), q, q) prop_CopyPermute = copyPermute `implements2` copyPermute_S setIdentity_S p = ((), permute (size p)) prop_SetIdentity = setIdentity `implements` setIdentity_S getElem_S p i = ((elems p) !! i, p) prop_GetElem (Index n i) = implementsFor n (\p -> getElem p i) (\p -> getElem_S p i) prop_UnsafeGetElem (Index n i) = implementsFor n (\p -> unsafeGetElem p i) (\p -> getElem_S p i) swapElems_S p i j = ((), p') where (n,is) = (size p, elems p) at k | k == i = is !! j | k == j = is !! i | otherwise = is !! k p' = listPermute n $ map at [0..(n-1)] prop_SwapElems (Swap n i j) = implementsFor n (\p -> swapElems p i j) (\p -> swapElems_S p i j) prop_UnsafeSwapElems (Swap n i j) = implementsFor n (\p -> unsafeSwapElems p i j) (\p -> swapElems_S p i j) getSize_S p = (length (elems p), p) prop_GetSize = getSize `implements` getSize_S getElems_S p = (elems p, p) prop_GetElems = getElems `implements` getElems_S prop_IsValid_Strict = runST $ do p <- newPermute 10 setElem p 0 1 valid <- isValid p setElem p 0 0 return $ valid == False prop_GetSwaps_Lazy1 = runST $ do p <- newPermute 10 ss <- getSwaps p swapElems p 0 1 return $ length ss == 1 prop_GetSwaps_Lazy2 = runST $ do p <- newPermute 10 ss <- getSwaps p swapElems p 0 1 swapElems p 3 4 head ss `seq` swapElems p 3 4 return $ length ss == 1 tests_STPermute = [ ("newPermute" , mytest prop_NewPermute) , ("newListPermute" , mytest prop_NewListPermute) , ("newSwapsPermute" , mytest prop_NewSwapsPermute) , ("unsafeNewSwapsPermute" , mytest prop_UnsafeNewSwapsPermute) , ("newCyclesPermute" , mytest prop_NewCyclesPermute) , ("unsafeNewCyclesPermute" , mytest prop_UnsafeNewCyclesPermute) , ("newCopyPermute" , mytest prop_NewCopyPermute) , ("copyPermute" , mytest prop_CopyPermute) , ("setIdentity" , mytest prop_SetIdentity) , ("getElem" , mytest prop_GetElem) , ("unsafeGetElem" , mytest prop_UnsafeGetElem) , ("swapElems" , mytest prop_SwapElems) , ("unsafeSwapElems" , mytest prop_UnsafeSwapElems) , ("getSize" , mytest prop_GetSize) , ("getElems" , mytest prop_GetElems) ] smoke_STPermute = [ ("isValid is strict" , mytest prop_IsValid_Strict) , ("getSwaps is lazy (test 1)" , mytest prop_GetSwaps_Lazy1) , ("getSwaps is lazy (test 2)" , mytest prop_GetSwaps_Lazy2) ] ------------------------------------------------------------------------ -- -- The specification language -- abstract :: STPermute s -> ST s Permute abstract = freeze commutes :: (Eq a, Show a) => STPermute s -> (STPermute s -> ST s a) -> (Permute -> (a,Permute)) -> ST s Bool commutes p a f = do old <- abstract p r <- a p new <- abstract p let s = f old s' = (r,new) passed = s == s' when (not passed) $ trace (printf ("expected `%s' but got `%s'") (show s) (show s')) return () return passed equivalent :: (forall s . ST s (STPermute s)) -> Permute -> Bool equivalent p s = runST $ do p' <- (p >>= abstract) when (not $ p' == s) $ trace (printf ("expected `%s' but got `%s'") (show s) (show p')) return () return (p' == s) implements :: (Eq a, Show a) => (forall s . STPermute s -> ST s a) -> (Permute -> (a,Permute)) -> Property a `implements` f = forAll arbitrary $ \(Nat n) -> implementsFor n a f implementsFor :: (Eq a, Show a) => Int -> (forall s . STPermute s -> ST s a) -> (Permute -> (a,Permute)) -> Property implementsFor n a f = forAll (Test.permute n) $ \p -> runST $ do p' <- unsafeThaw p commutes p' a f implementsIf :: (Eq a, Show a) => (forall s . STPermute s -> ST s Bool) -> (forall s . STPermute s -> ST s a) -> (Permute -> (a, Permute)) -> Property implementsIf pre a f = forAll arbitrary $ \p -> runST ( do p' <- thaw p pre p') ==> runST ( do p' <- unsafeThaw p commutes p' a f ) commutes2 :: (Eq a, Show a) => STPermute s -> STPermute s -> (STPermute s -> STPermute s -> ST s a) -> (Permute -> Permute -> (a,Permute,Permute)) -> ST s Bool commutes2 p q a f = do oldp <- abstract p oldq <- abstract q r <- a p q newp <- abstract p newq <- abstract q let s = f oldp oldq s' = (r,newp,newq) passed = s == s' when (not passed) $ trace (printf ("expected `%s' but got `%s'") (show s) (show s')) return () return passed implements2 :: (Eq a, Show a) => (forall s . STPermute s -> STPermute s -> ST s a) -> (Permute -> Permute -> (a,Permute,Permute)) -> Property implements2 a f = forAll arbitrary $ \(Nat n) -> forAll (Test.permute n) $ \p -> forAll (Test.permute n) $ \q -> runST $ do p' <- unsafeThaw p q' <- unsafeThaw q commutes2 p' q' a f permutation-0.5.0.5/tests/Choose.hs0000644000000000000000000000546012457565375015362 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} module Choose ( tests_Choose ) where import Control.Monad.ST import Data.Array.ST import Data.List( foldl' ) import qualified Data.List as List import Data.Maybe( fromJust ) import Data.Choose import Driver import Test.QuickCheck hiding (choose) import Test.Choose() import qualified Test.Choose as Test prop_possible_choose (Index n' k) = let n = n'-1 in possible (choose n k) == n prop_size_choose (Index n' k) = let n = n'-1 in size (choose n k) == k prop_elems_choose (Index n' k) = let n = n'-1 in elems (choose n k) == [0 .. k-1] prop_possible_listChoose (ListChoose n k is) = possible (listChoose n k is) == n prop_size_listChoose (ListChoose n k is) = size (listChoose n k is) == k prop_elems_listChoose (ListChoose n k is) = elems (listChoose n k is) == is prop_at = prop_at_help at prop_unsafeAt = prop_at_help unsafeAt prop_at_help a = forAll arbitrary $ \(Index k i) -> forAll arbitrary $ \(Nat nk) -> forAll (Test.choose (nk+k) k) $ \c -> a c i == (elems c) !! i prop_possible_complement (c :: Choose) = possible (complement c) == possible c prop_size_complement (c :: Choose) = size (complement c) == possible c - size c prop_elems_complement (c :: Choose) = all (not . (`elem` is)) is' where is = elems c is' = elems (complement c) prop_prev_choose (Index n1 k) = let n = n1-1 in prev (choose n k) == Nothing prop_next_last (Index n1 k) = let n = n1-1 in next (listChoose n k $ [(n-k)..(n-1)]) == Nothing prop_next_prev (c :: Choose) = case prev c of Just c' -> c == (fromJust $ next c') Nothing -> c == choose n k where n = possible c k = size c prop_prev_next (c :: Choose) = case next c of Just c' -> c == (fromJust $ prev c') Nothing -> c == (listChoose n k $ [(n-k)..(n-1)]) where n = possible c k = size c tests_Choose = [ ("possible . choose" , mytest prop_possible_choose) , ("size . choose" , mytest prop_size_choose) , ("elems . choose" , mytest prop_elems_choose) , ("possible . listChoose" , mytest prop_possible_listChoose) , ("size . listChoose" , mytest prop_size_listChoose) , ("elems . listChoose" , mytest prop_elems_listChoose) , ("at" , mytest prop_at) , ("unsafeAt" , mytest prop_unsafeAt) , ("possible . complement" , mytest prop_possible_complement) , ("size . complement" , mytest prop_size_complement) , ("elems . complement" , mytest prop_elems_complement) , ("prev . choose" , mytest prop_prev_choose) , ("next (last choose)" , mytest prop_next_last) , ("next . prev" , mytest prop_next_prev) , ("prev . next" , mytest prop_prev_next) ] permutation-0.5.0.5/tests/Driver.hs0000644000000000000000000001435312457565375015376 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Driver -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Driver ( Natural(..), Index(..), ListChoose(..), ListPermute(..), SwapsPermute(..), CyclesPermute(..), Sort(..), SortBy(..), Swap(..), mytest, mycheck, mytests, done, ) where import Control.Monad import Data.List import Data.Ord import System.IO import System.Random import Test.QuickCheck import Text.Printf import Text.Show.Functions newtype Natural = Nat Int deriving (Eq,Show) instance Arbitrary Natural where arbitrary = do n <- arbitrary return $ Nat (abs n) coarbitrary = undefined data Index = Index Int Int deriving (Eq,Show) instance Arbitrary Index where arbitrary = do (Nat n) <- arbitrary i <- choose (0, n) return $ Index (n + 1) i coarbitrary = undefined data ListChoose = ListChoose Int Int [Int] deriving (Eq,Show) instance Arbitrary ListChoose where arbitrary = do (Nat n) <- arbitrary k <- choose (0,n) xs <- vector n :: Gen [Int] return . ListChoose n k $ sort $ take k $ (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..] coarbitrary = undefined data ListPermute = ListPermute Int [Int] deriving (Eq,Show) instance Arbitrary ListPermute where arbitrary = do (Nat n) <- arbitrary xs <- vector n :: Gen [Int] return . ListPermute n $ (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..] coarbitrary = undefined data SwapsPermute = SwapsPermute Int [(Int,Int)] deriving (Eq,Show) instance Arbitrary SwapsPermute where arbitrary = do (Nat n) <- arbitrary let n' = n + 1 (Nat k) <- arbitrary ss <- replicateM k (swap n') return $ SwapsPermute n' ss coarbitrary = undefined swap n = do i <- choose (0,n-1) j <- choose (0,n-1) return (i,j) data CyclesPermute = CyclesPermute Int [[Int]] deriving (Eq,Show) instance Arbitrary CyclesPermute where arbitrary = do (Nat n) <- arbitrary cs <- exhaust randomCycle null [0..n] cs' <- cutSomeSingletons cs return $ CyclesPermute (n+1) cs' coarbitrary = undefined exhaust :: Monad m => (a -> m (b, a)) -> (a -> Bool) -> a -> m [b] exhaust _ p x | p x = return [] exhaust f p x = do (r, y) <- f x rs <- exhaust f p y return (r:rs) cutSomeSingletons [] = return [] cutSomeSingletons ([x]:xs) = do is <- elements [True, False] if is then liftM ([x]:) $ cutSomeSingletons xs else cutSomeSingletons xs cutSomeSingletons (x:xs) = liftM (x:) $ cutSomeSingletons xs randomCycle xs = do first <- elements xs complete first (xs \\ [first]) where complete first rest = do next <- elements (first:rest) if next == first then return ([first], rest) else do (more, leftover) <- complete first (rest \\ [next]) return ((next:more), leftover) data Swap = Swap Int Int Int deriving (Eq,Show) instance Arbitrary Swap where arbitrary = do (Index n i) <- arbitrary j <- choose (0,n-1) return $ Swap n i j coarbitrary = undefined instance Arbitrary Ordering where arbitrary = elements [ LT, GT, EQ ] coarbitrary = coarbitrary . fromEnum data Sort = Sort Int [Int] deriving (Eq,Show) instance Arbitrary Sort where arbitrary = do (Index n i) <- arbitrary xs <- vector n return $ Sort i xs coarbitrary = undefined data SortBy = SortBy (Int -> Int -> Ordering) Int [Int] deriving (Show) instance Arbitrary SortBy where arbitrary = do cmp <- arbitrary (Sort n xs) <- arbitrary return $ SortBy cmp n xs coarbitrary = undefined ------------------------------------------------------------------------ -- -- QC driver ( taken from xmonad-0.6 ) -- debug = False mytest :: Testable a => a -> Int -> IO (Bool, Int) mytest a n = mycheck defaultConfig { configMaxTest=n , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] } a -- , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a mycheck :: Testable a => Config -> a -> IO (Bool, Int) mycheck config a = do rnd <- newStdGen mytests config (evaluate a) rnd 0 0 [] mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int) mytests config gen rnd0 ntest nfail stamps | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest) | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest) | otherwise = do putStr (configEvery config ntest (arguments result)) >> hFlush stdout case ok result of Nothing -> mytests config gen rnd1 ntest (nfail+1) stamps Just True -> mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) Just False -> putStr ( "Falsifiable after " ++ show ntest ++ " tests:\n" ++ unlines (arguments result) ) >> hFlush stdout >> return (False, ntest) where result = generate (configSize config ntest) rnd2 gen (rnd1,rnd2) = split rnd0 done :: String -> Int -> [[String]] -> IO () done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) where table = display . map entry . reverse . sort . map pairLength . group . sort . filter (not . null) $ stamps display [] = ".\n" display [x] = " (" ++ x ++ ").\n" display xs = ".\n" ++ unlines (map (++ ".") xs) pairLength xss@(xs:_) = (length xss, xs) entry (n, xs) = percentage n ntest ++ " " ++ concat (intersperse ", " xs) percentage n m = show ((100 * n) `div` m) ++ "%" ------------------------------------------------------------------------ permutation-0.5.0.5/tests/Makefile0000644000000000000000000000065212457565375015244 0ustar0000000000000000all: ghc -O -i. -i../lib Main.hs --make -o test-permutation ./test-permutation hpc: ghc -fforce-recomp -i. -i../lib -fhpc --make Main.hs -o test-permutation rm -f test-permutation.tix ./test-permutation hpc markup test-permutation clean: find ../lib . -name '*.hi' | xargs rm -f find ../lib . -name '*.o' | xargs rm -f find . -name '*.html' | xargs rm -f rm -f test-permutation test-permutation.tix rm -rf .hpc permutation-0.5.0.5/tests/STChoose.hs0000644000000000000000000001206112457565375015624 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module STChoose ( tests_STChoose, smoke_STChoose ) where import Control.Monad import Control.Monad.ST import Data.Choose import Data.Choose.ST import Driver import Debug.Trace import Test.QuickCheck hiding ( choose ) import qualified Test.QuickCheck as QC import Text.Printf import Test.Choose() import qualified Test.Choose as Test newChoose_S n k = choose n k prop_NewChoose (Index n k) = let n' = n-1 in newChoose n' k `equivalent` newChoose_S n' k newListChoose_S n k is = listChoose n k is prop_NewListChoose (ListChoose n k is) = newListChoose n k is `equivalent` newListChoose_S n k is newCopyChoose_S c = (c, c) prop_NewCopyChoose = implements (\c -> newCopyChoose c >>= unsafeFreeze) (\c -> newCopyChoose_S c) copyChoose_S dst src = ((), src, src) prop_CopyChoose = copyChoose `implements2` copyChoose_S setFirst_S c = ((), choose (possible c) (size c)) prop_SetFirst = setFirst `implements` setFirst_S getElem_S c i = (c `at` i, c) prop_GetElem (Index k i) = forAll arbitrary $ \(Nat n) -> implementsFor (n+k) k (\c -> getElem c i) (\c -> getElem_S c i) prop_UnsafeGetElem (Index k i) = forAll arbitrary $ \(Nat n) -> implementsFor (n+k) k (\c -> unsafeGetElem c i) (\c -> getElem_S c i) getPossible_S c = (possible c, c) prop_GetPossible = getPossible `implements` getPossible_S getSize_S c = (length (elems c), c) prop_GetSize = getSize `implements` getSize_S getElems_S c = (elems c, c) prop_GetElems = getElems `implements` getElems_S prop_IsValid_Strict = runST $ do c <- newChoose 10 3 setElem c 0 1 valid <- isValid c setElem c 0 0 return $ valid == False tests_STChoose = [ ("newChoose" , mytest prop_NewChoose) , ("newListChoose" , mytest prop_NewListChoose) , ("newCopyChoose" , mytest prop_NewCopyChoose) , ("setFirst" , mytest prop_SetFirst) , ("getElem" , mytest prop_GetElem) , ("unsafeGetElem" , mytest prop_UnsafeGetElem) , ("getPossible" , mytest prop_GetPossible) , ("getSize" , mytest prop_GetSize) , ("getElems" , mytest prop_GetElems) ] smoke_STChoose = [ ("isValid is strict" , mytest prop_IsValid_Strict) ] ------------------------------------------------------------------------ -- -- The specification language -- abstract :: STChoose s -> ST s Choose abstract = freeze commutes :: (Eq a, Show a) => STChoose s -> (STChoose s -> ST s a) -> (Choose -> (a,Choose)) -> ST s Bool commutes c a f = do old <- abstract c r <- a c new <- abstract c let s = f old s' = (r,new) passed = s == s' when (not passed) $ trace (printf ("expected `%s' but got `%s'") (show s) (show s')) return () return passed equivalent :: (forall s . ST s (STChoose s)) -> Choose -> Bool equivalent c s = runST $ do c' <- (c >>= abstract) when (not $ c' == s) $ trace (printf ("expected `%s' but got `%s'") (show s) (show c')) return () return (c' == s) implements :: (Eq a, Show a) => (forall s . STChoose s -> ST s a) -> (Choose -> (a,Choose)) -> Property a `implements` f = forAll arbitrary $ \(Nat n) -> forAll (QC.choose (0,n)) $ \k -> implementsFor n k a f implementsFor :: (Eq a, Show a) => Int -> Int -> (forall s . STChoose s -> ST s a) -> (Choose -> (a,Choose)) -> Property implementsFor n k a f = forAll (Test.choose n k) $ \c -> runST $ do c' <- unsafeThaw c commutes c' a f implementsIf :: (Eq a, Show a) => (forall s . STChoose s -> ST s Bool) -> (forall s . STChoose s -> ST s a) -> (Choose -> (a, Choose)) -> Property implementsIf pre a f = forAll arbitrary $ \c -> runST ( do c' <- thaw c pre c') ==> runST ( do c' <- unsafeThaw c commutes c' a f ) commutes2 :: (Eq a, Show a) => STChoose s -> STChoose s -> (STChoose s -> STChoose s -> ST s a) -> (Choose -> Choose -> (a,Choose,Choose)) -> ST s Bool commutes2 c1 c2 a f = do oldc1 <- abstract c1 oldc2 <- abstract c2 r <- a c1 c2 newc1 <- abstract c1 newc2 <- abstract c2 let s = f oldc1 oldc2 s' = (r,newc1,newc2) passed = s == s' when (not passed) $ trace (printf ("expected `%s' but got `%s'") (show s) (show s')) return () return passed implements2 :: (Eq a, Show a) => (forall s . STChoose s -> STChoose s -> ST s a) -> (Choose -> Choose -> (a,Choose,Choose)) -> Property implements2 a f = forAll arbitrary $ \(Nat n) -> forAll (QC.choose (0,n)) $ \k -> forAll (Test.choose n k) $ \c1 -> forAll (Test.choose n k) $ \c2 -> runST $ do c1' <- unsafeThaw c1 c2' <- unsafeThaw c2 commutes2 c1' c2' a f permutation-0.5.0.5/tests/Main.hs0000644000000000000000000000265712457565375015033 0ustar0000000000000000 import Control.Monad import System.Environment import Text.Printf import Driver import Choose import Permute import STChoose import STPermute main :: IO () main = do args <- getArgs let n = if null args then 100 else read (head args) (smokeResults, smokePassed) <- liftM unzip $ foldM ( \prev (name,subtests) -> do printf "\n%s\n" name printf "%s\n" $ replicate (length name) '-' cur <- mapM (\(s,a) -> printf "%-30s: " s >> a 1) subtests return (prev ++ cur) ) [] smoke (results, passed) <- liftM unzip $ foldM ( \prev (name,subtests) -> do printf "\n%s\n" name printf "%s\n" $ replicate (length name) '-' cur <- mapM (\(s,a) -> printf "%-30s: " s >> a n) subtests return (prev ++ cur) ) [] tests printf "\nPassed %d tests!\n\n" (sum $ smokePassed ++ passed) when (not . and $ smokeResults ++ results) $ fail "\nNot all tests passed!" where smoke = [ ("STChoose" , smoke_STChoose) , ("STPermute", smoke_STPermute) ] tests = [ ("STChoose" , tests_Choose) , ("STChoose" , tests_STChoose) , ("Permute" , tests_Permute) , ("STPermute" , tests_STPermute) ] permutation-0.5.0.5/tests/Test/0000755000000000000000000000000012457565375014520 5ustar0000000000000000permutation-0.5.0.5/tests/Test/Permute.hs0000644000000000000000000000201112457565375016467 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Test.Permute -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- An 'Arbitrary' instance and functions for generating random permutations. -- module Test.Permute ( permute ) where import Data.List ( sortBy ) import Data.Ord ( comparing ) import Test.QuickCheck import Data.Permute ( Permute ) import qualified Data.Permute as P -- | Generate a random permutation of the given size. permute :: Int -> Gen Permute permute n = do xs <- vector n :: Gen [Int] let is = (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..] return $ P.listPermute n is instance Arbitrary Permute where arbitrary = do n <- arbitrary >>= return . abs p <- permute n return $ p coarbitrary p = coarbitrary $ P.elems p permutation-0.5.0.5/tests/Test/Choose.hs0000644000000000000000000000216512457565375016300 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Test.Choose -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Test.Choose ( choose ) where import Control.Monad( liftM ) import Data.Ord( comparing ) import Data.List( sort, sortBy ) import Test.QuickCheck hiding ( choose ) import qualified Test.QuickCheck as QC import Data.Choose( Choose ) import qualified Data.Choose as C -- | @choose n k@ generates a random combination of @k@ outcomes -- from @n@ possibilities. choose :: Int -> Int -> Gen Choose choose n k = do xs <- vector n :: Gen [Int] let is = (snd . unzip) $ sortBy (comparing fst) $ zip xs [0..] return $ C.listChoose n k $ sort $ take k is instance Arbitrary Choose where arbitrary = do n <- liftM abs arbitrary k <- QC.choose (0,n) c <- choose n k return c coarbitrary c = coarbitrary $ (C.possible c, C.size c, C.elems c) permutation-0.5.0.5/lib/0000755000000000000000000000000012457565375013205 5ustar0000000000000000permutation-0.5.0.5/lib/Data/0000755000000000000000000000000012457565375014056 5ustar0000000000000000permutation-0.5.0.5/lib/Data/Permute.hs0000644000000000000000000001421612457565375016037 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Permute -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Immutable permutations. module Data.Permute ( -- * Permutations Permute, -- * Creating permutations permute, listPermute, swapsPermute, cyclesPermute, -- * Accessing permutation elements at, unsafeAt, indexOf, -- * Permutation properties size, elems, isEven, period, -- * Permutation functions inverse, next, prev, -- * Applying permutations swaps, invSwaps, cycleFrom, cycles, -- * Sorting sort, sortBy, order, orderBy, rank, rankBy, ) where import Control.Monad import Control.Monad.ST import Data.Permute.Base import Data.Permute.ST -- | Construct an identity permutation of the given size. permute :: Int -> Permute permute n = runST $ unsafeFreeze =<< newPermute n -- | Construct a permutation from a list of elements. -- @listPermute n is@ creates a permutation of size @n@ with -- the @i@th element equal to @is !! i@. For the permutation to be valid, -- the list @is@ must have length @n@ and contain the indices @0..(n-1)@ -- exactly once each. listPermute :: Int -> [Int] -> Permute listPermute n is = runST $ unsafeFreeze =<< newListPermute n is -- | Construct a permutation from a list of swaps. -- @swapsPermute n ss@ creats a permutation of size @n@ given by a -- sequence of swaps. -- If @ss@ is @[(i0,j0), (i1,j1), ..., (ik,jk)]@, the -- sequence of swaps is -- @i0 \<-> j0@, then -- @i1 \<-> j1@, and so on until -- @ik \<-> jk@. swapsPermute :: Int -> [(Int,Int)] -> Permute swapsPermute n ss = runST $ unsafeFreeze =<< newSwapsPermute n ss -- | Construct a permutation from a list of disjoint cycles. -- @cyclesPermute n cs@ creates a permutation of size @n@ which is the -- composition of the cycles @cs@. cyclesPermute :: Int -> [[Int]] -> Permute cyclesPermute n cs = runST $ unsafeFreeze =<< newCyclesPermute n cs -- | @at p i@ gets the value of the @i@th element of the permutation -- @p@. The index @i@ must be in the range @0..(n-1)@, where @n@ is the -- size of the permutation. at :: Permute -> Int -> Int at p i | i >= 0 && i < size p = unsafeAt p i | otherwise = error "Invalid index" {-# INLINE at #-} -- | @indexOf p x@ gets an index @i@ such that @at p i@ equals @x@. indexOf :: Permute -> Int -> Int indexOf p x = runST $ flip getIndexOf x =<< unsafeThaw p {-# INLINE indexOf #-} -- | Get the inverse of a permutation. inverse :: Permute -> Permute inverse p = runST $ unsafeFreeze =<< getInverse =<< unsafeThaw p -- | Return the next permutation in lexicographic order, or @Nothing@ if -- there are no further permutations. Starting with the identity permutation -- and repeatedly calling this function will iterate through all permutations -- of a given order. next :: Permute -> Maybe Permute next = nextPrevHelp setNext -- | Return the previous permutation in lexicographic order, or @Nothing@ -- if no such permutation exists. prev :: Permute -> Maybe Permute prev = nextPrevHelp setPrev nextPrevHelp :: (forall s. STPermute s -> ST s Bool) -> Permute -> Maybe Permute nextPrevHelp set p = runST $ do p' <- thaw p set p' >>= \valid -> if valid then liftM Just $ unsafeFreeze p' else return Nothing -- | Get a list of swaps equivalent to the permutation. A result of -- @[ (i0,j0), (i1,j1), ..., (ik,jk) ]@ means swap @i0 \<-> j0@, -- then @i1 \<-> j1@, and so on until @ik \<-> jk@. swaps :: Permute -> [(Int,Int)] swaps p = runST $ getSwaps =<< unsafeThaw p -- | Get a list of swaps equivalent to the inverse of permutation. invSwaps :: Permute -> [(Int,Int)] invSwaps p = runST $ getInvSwaps =<< unsafeThaw p -- | @cycleFrom p i@ gets the list of elements reachable from @i@ by -- repeated application of @p@. cycleFrom :: Permute -> Int -> [Int] cycleFrom p i = runST $ flip getCycleFrom i =<< unsafeThaw p -- | @cycles p@ returns the list of disjoin cycles in @p@. cycles :: Permute -> [[Int]] cycles p = runST $ getCycles =<< unsafeThaw p -- | Whether or not the permutation is made from an even number of swaps isEven :: Permute -> Bool isEven p = runST $ getIsEven =<< unsafeThaw p -- | @period p@ - The first power of @p@ that is the identity permutation period :: Permute -> Integer period p = runST $ getPeriod =<< unsafeThaw p -- | @sort n xs@ sorts the first @n@ elements of @xs@ and returns a -- permutation which transforms @xs@ into sorted order. The results are -- undefined if @n@ is greater than the length of @xs@. This is a special -- case of 'sortBy'. sort :: (Ord a) => Int -> [a] -> ([a], Permute) sort n xs = runST $ do (xs',mp) <- getSort n xs p <- unsafeFreeze mp return (xs',p) sortBy :: (a -> a -> Ordering) -> Int -> [a] -> ([a], Permute) sortBy cmp n xs = runST $ do (xs',mp) <- getSortBy cmp n xs p <- unsafeFreeze mp return (xs',p) -- | @order n xs@ returns a permutation which rearranges the first @n@ -- elements of @xs@ into ascending order. The results are undefined if @n@ is -- greater than the length of @xs@. This is a special case of 'orderBy'. order :: (Ord a) => Int -> [a] -> Permute order n xs = runST $ unsafeFreeze =<< getOrder n xs orderBy :: (a -> a -> Ordering) -> Int -> [a] -> Permute orderBy cmp n xs = runST $ unsafeFreeze =<< getOrderBy cmp n xs -- | @rank n xs@ eturns a permutation, the inverse of which rearranges the -- first @n@ elements of @xs@ into ascending order. The returned permutation, -- @p@, has the property that @p[i]@ is the rank of the @i@th element of @xs@. -- The results are undefined if @n@ is greater than the length of @xs@. -- This is a special case of 'rankBy'. rank :: (Ord a) => Int -> [a] -> Permute rank n xs = runST $ unsafeFreeze =<< getRank n xs rankBy :: (a -> a -> Ordering) -> Int -> [a] -> Permute rankBy cmp n xs = runST $ unsafeFreeze =<< getRankBy cmp n xs permutation-0.5.0.5/lib/Data/IntArray.hs0000644000000000000000000001144712457565375016152 0ustar0000000000000000 {-# LANGUAGE MagicHash, UnboxedTuples, CPP #-} {-# OPTIONS_GHC -funbox-strict-fields #-} ----------------------------------------------------------------------------- -- | -- Module : Data.IntArray -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Data.IntArray ( IntArray, STIntArray, numElements, unsafeAt, elems, newArray_, sameSTIntArray, numElementsSTIntArray, getNumElements, unsafeRead, unsafeWrite, unsafeSwap, readElems, writeElems, unsafeFreeze, unsafeThaw, ) where import GHC.Base( Int(..) ) import GHC.Prim import GHC.ST import Foreign( sizeOf ) #if __GLASGOW_HASKELL__ >= 708 import GHC.Exts (isTrue#) isTrue = isTrue# #else isTrue = id #endif {-# INLINE isTrue #-} ----------------------------- Immutable arrays ----------------------------- data IntArray = IntArray !Int (ByteArray#) {-# INLINE numElements #-} numElements :: IntArray -> Int numElements (IntArray n _) = n {-# INLINE unsafeAt #-} unsafeAt :: IntArray -> Int -> Int unsafeAt (IntArray _ arr#) (I# i#) = case indexIntArray# arr# i# of { e# -> I# e# } {-# INLINE elems #-} elems :: IntArray -> [Int] elems arr@(IntArray n _) = [ unsafeAt arr i | i <- [0 .. n-1]] ------------------------------ Mutable arrays ------------------------------ data STIntArray s = STIntArray !Int (MutableByteArray# s) {-# INLINE newArray_ #-} newArray_ :: Int -> ST s (STIntArray s) newArray_ n@(I# n#) = ST $ \s1# -> case newByteArray# (n# *# sizeOfInt) s1# of { (# s2#, marr# #) -> (# s2#, STIntArray n marr# #) } where sizeOfInt = case sizeOf (0 :: Int) of (I# s#) -> s# {-# INLINE sameSTIntArray #-} sameSTIntArray :: STIntArray s -> STIntArray s -> Bool sameSTIntArray (STIntArray _ marr1#) (STIntArray _ marr2#) = isTrue (sameMutableByteArray# marr1# marr2#) {-# INLINE numElementsSTIntArray #-} numElementsSTIntArray :: STIntArray s -> Int numElementsSTIntArray (STIntArray n _) = n {-# INLINE getNumElements #-} getNumElements :: STIntArray s -> ST s Int getNumElements arr = return $! numElementsSTIntArray arr {-# INLINE unsafeRead #-} unsafeRead :: STIntArray s -> Int -> ST s Int unsafeRead (STIntArray _ marr#) (I# i#) = ST $ \s1# -> case readIntArray# marr# i# s1# of { (# s2#, e# #) -> let e = I# e# in (# s2#, e #) } {-# INLINE unsafeWrite #-} unsafeWrite :: STIntArray s -> Int -> Int -> ST s () unsafeWrite (STIntArray _ marr#) (I# i#) (I# e#) = ST $ \s1# -> case writeIntArray# marr# i# e# s1# of { s2# -> (# s2#, () #) } {-# INLINE unsafeSwap #-} unsafeSwap :: STIntArray s -> Int -> Int -> ST s () unsafeSwap (STIntArray _ marr#) (I# i#) (I# j#) = ST $ \s1# -> let doSwap = case readIntArray# marr# i# s1# of { (# s2#, e# #) -> case readIntArray# marr# j# s2# of { (# s3#, f# #) -> case writeIntArray# marr# i# f# s3# of { s4# -> writeIntArray# marr# j# e# s4# }}} in if isTrue (i# ==# j#) then (# s1#, () #) else case doSwap of { s2# -> (# s2#, () #) } {-# INLINE readElems #-} readElems :: STIntArray s -> ST s [Int] readElems (STIntArray (I# n#) marr#) = ST $ \s1# -> let inlineReadList i# | isTrue (i# ==# n#) = [] | otherwise = case readIntArray# marr# i# s1# of { (# _, e# #) -> let e = I# e# es = inlineReadList (i# +# 1#) in (e:es) } in case inlineReadList 0# of { es -> (# s1#, es #)} {-# INLINE writeElems #-} writeElems :: STIntArray s -> [Int] -> ST s () writeElems (STIntArray (I# n#) marr#) es = ST $ \s1# -> let fillFromList i# xs s2# | isTrue (i# ==# n#) = s2# | otherwise = case xs of [] -> s2# (I# y#):ys -> case writeIntArray# marr# i# y# s2# of { s3# -> fillFromList (i# +# 1#) ys s3# } in case fillFromList 0# es s1# of { s2# -> (# s2#, () #) } {-# INLINE unsafeFreeze #-} unsafeFreeze :: STIntArray s -> ST s IntArray unsafeFreeze (STIntArray n marr#) = ST $ \s1# -> case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) -> let arr = IntArray n arr# in (# s2#, arr #)} {-# INLINE unsafeThaw #-} unsafeThaw :: IntArray -> ST s (STIntArray s) unsafeThaw (IntArray n arr#) = ST $ \s1# -> let coerceArray :: State# s -> MutableByteArray# s coerceArray _ = unsafeCoerce# arr# marr# = coerceArray s1# marr = STIntArray n marr# in (# s1#, marr #) permutation-0.5.0.5/lib/Data/Choose.hs0000644000000000000000000000563112457565375015637 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Choose -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Immutable combinations. module Data.Choose ( -- * Combinations Choose, -- * Creating combinations choose, listChoose, -- * Accessing combination elements at, unsafeAt, -- * Combination properties possible, size, elems, -- * Combination functions complement, complElems, next, prev, ) where import Control.Monad import Control.Monad.ST import Data.Choose.Base import Data.Choose.ST -- | @choose n k@ returns the first combination of @k@ outcomes from @n@ -- possibilites, namely the subset @{ 0, ..., k-1 }@. choose :: Int -> Int -> Choose choose n k = runST $ unsafeFreeze =<< newChoose n k -- | Construct a combination from a list of elements. -- @listChoose n k is@ creates a combination of @k@ outcomes from @n@ -- possibilities initialized to have the @i@th element equal to @is !! i@. -- For the combination to be valid, the elements must all be unique, they -- must be in sorted order, and they all must be in the range @0 .. n-1@. listChoose :: Int -> Int -> [Int] -> Choose listChoose n k is = runST $ unsafeFreeze =<< newListChoose n k is -- | @at c i@ gets the value of the @i@th element of the combination -- @c@. The index @i@ must be in the range @0..(k-1)@, where @k@ is the -- size of the combination. at :: Choose -> Int -> Int at c i | i >= 0 && i < size c = unsafeAt c i | otherwise = error "Invalid index" {-# INLINE at #-} -- | Get the inverse of a combination complement :: Choose -> Choose complement c = runST $ unsafeFreeze =<< getComplement =<< unsafeThaw c -- | Get a list of the elements in the complement of a combination. -- If the combination is a subset of @k@ outcomes from @n@ possibilities, then -- the returned list will be sorted and of length @n-k@. complElems :: Choose -> [Int] complElems c = runST $ getComplElems =<< unsafeThaw c -- | Return the next combination in lexicographic order, or @Nothing@ if -- there are no further combinations. Starting with the first combination -- and repeatedly calling this function will iterate through all combinations -- of a given order. next :: Choose -> Maybe Choose next = nextPrevHelp setNext -- | Return the previous combination in lexicographic order, or @Nothing@ -- if such combination exists. prev :: Choose -> Maybe Choose prev = nextPrevHelp setPrev nextPrevHelp :: (forall s. STChoose s -> ST s Bool) -> Choose -> Maybe Choose nextPrevHelp set c = runST $ do c' <- thaw c set c' >>= \valid -> if valid then liftM Just $ unsafeFreeze c' else return Nothing permutation-0.5.0.5/lib/Data/Permute/0000755000000000000000000000000012457565375015477 5ustar0000000000000000permutation-0.5.0.5/lib/Data/Permute/MPermute.hs0000644000000000000000000004220512457565375017574 0ustar0000000000000000{-# LANGUAGE BangPatterns, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Permute.MPermute -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- An overloaded interface to mutable permutations. For permutation types which -- can be used with this interface, see "Data.Permute.IO" and "Data.Permute.ST". -- module Data.Permute.MPermute ( -- * Class of mutable permutation types MPermute, -- * Constructing mutable permutations newPermute, newPermute_, newListPermute, newSwapsPermute, newCyclesPermute, newCopyPermute, copyPermute, setIdentity, -- * Accessing permutation elements getElem, setElem, getIndexOf, swapElems, -- * Permutation properties getSize, getElems, setElems, isValid, getIsEven, getPeriod, -- * Permutation functions getInverse, copyInverse, setNext, setPrev, -- * Applying permutations getSwaps, getInvSwaps, getCycleFrom, getCycles, -- * Sorting getSort, getSortBy, getOrder, getOrderBy, getRank, getRankBy, -- * Converstions between mutable and immutable permutations freeze, unsafeFreeze, thaw, unsafeThaw, -- * Unsafe operations unsafeNewListPermute, unsafeNewSwapsPermute, unsafeNewCyclesPermute, unsafeGetElem, unsafeSetElem, unsafeSwapElems, ) where import Control.Monad import Control.Monad.ST #if __GLASGOW_HASKELL__ >= 708 import Control.Monad.ST.Unsafe #endif import Data.Function( on ) import qualified Data.List as List import System.IO.Unsafe( unsafeInterleaveIO ) import Data.Permute.Base import Data.Permute.IOBase --------------------------------- MPermute -------------------------------- -- | Class for representing a mutable permutation. The type is parameterized -- over the type of the monad, @m@, in which the mutable permutation will be -- manipulated. class (Monad m) => MPermute p m | p -> m, m -> p where -- | Get the size of a permutation. getSize :: p -> m Int -- | Create a new permutation initialized to be the identity. newPermute :: Int -> m p -- | Allocate a new permutation but do not initialize it. newPermute_ :: Int -> m p unsafeGetElem :: p -> Int -> m Int unsafeSetElem :: p -> Int -> Int -> m () unsafeSwapElems :: p -> Int -> Int -> m () -- | Get a lazy list of the permutation elements. The laziness makes this -- function slightly dangerous if you are modifying the permutation. getElems :: p -> m [Int] -- | Set all the values of a permutation from a list of elements. setElems :: p -> [Int] -> m () unsafeFreeze :: p -> m Permute unsafeThaw :: Permute -> m p unsafeInterleaveM :: m a -> m a -- | Construct a permutation from a list of elements. -- @newListPermute n is@ creates a permutation of size @n@ with -- the @i@th element equal to @is !! i@. For the permutation to be valid, -- the list @is@ must have length @n@ and contain the indices @0..(n-1)@ -- exactly once each. 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 {-# INLINE newListPermute #-} unsafeNewListPermute :: (MPermute p m) => Int -> [Int] -> m p unsafeNewListPermute n is = do p <- newPermute_ n setElems p is return p {-# INLINE unsafeNewListPermute #-} -- | Construct a permutation from a list of swaps. -- @newSwapsPermute n ss@ creates a permutation of size @n@ given a -- sequence of swaps. -- If @ss@ is @[(i0,j0), (i1,j1), ..., (ik,jk)]@, the -- sequence of swaps is -- @i0 \<-> j0@, then -- @i1 \<-> j1@, and so on until -- @ik \<-> jk@. newSwapsPermute :: (MPermute p m) => Int -> [(Int,Int)] -> m p newSwapsPermute = newSwapsPermuteHelp swapElems {-# INLINE newSwapsPermute #-} unsafeNewSwapsPermute :: (MPermute p m) => Int -> [(Int,Int)] -> m p unsafeNewSwapsPermute = newSwapsPermuteHelp unsafeSwapElems {-# INLINE unsafeNewSwapsPermute #-} 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 {-# INLINE newSwapsPermuteHelp #-} -- | Construct a permutation from a list of disjoint cycles. -- @newCyclesPermute n cs@ creates a permutation of size @n@ which is the -- composition of the cycles @cs@. newCyclesPermute :: (MPermute p m) => Int -> [[Int]] -> m p newCyclesPermute n cs = newSwapsPermute n $ concatMap cycleToSwaps cs {-# INLINE newCyclesPermute #-} unsafeNewCyclesPermute :: (MPermute p m) => Int -> [[Int]] -> m p unsafeNewCyclesPermute n cs = unsafeNewSwapsPermute n $ concatMap cycleToSwaps cs {-# INLINE unsafeNewCyclesPermute #-} cycleToSwaps :: [Int] -> [(Int, Int)] cycleToSwaps [] = error "Empty cycle" cycleToSwaps (i:is) = [(i,j) | j <- reverse is] {-# INLINE cycleToSwaps #-} -- | Construct a new permutation by copying another. newCopyPermute :: (MPermute p m) => p -> m p newCopyPermute p = do n <- getSize p p' <- newPermute_ n copyPermute p' p return p' {-# INLINE newCopyPermute #-} -- | @copyPermute dst src@ copies the elements of the permutation @src@ -- into the permutation @dst@. The two permutations must have the same -- size. copyPermute :: (MPermute p m) => p -> p -> m () copyPermute dst src = getElems src >>= setElems dst {-# INLINE copyPermute #-} -- | Set a permutation to the identity. setIdentity :: (MPermute p m) => p -> m () setIdentity p = do n <- getSize p setElems p [0 .. n-1] {-# INLINE setIdentity #-} -- | @getElem p i@ gets the value of the @i@th element of the permutation -- @p@. The index @i@ must be in the range @0..(n-1)@, where @n@ is the -- size of the permutation. 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 {-# INLINE getElem #-} -- | @getIndexOf p x@ returns @i@ sutch that @getElem p i@ equals @x@. This -- is a linear-time operation. getIndexOf :: (MPermute p m) => p -> Int -> m Int getIndexOf p x = let go !i (y:ys) | y == x = i | otherwise = go (i+1) ys go _ _ = error "getIndexOf: invalid element" in liftM (go 0) $ getElems p {-# INLINE getIndexOf #-} -- | @setElem p i x@ sets the value of the @i@th element of the permutation -- @p@. The index @i@ must be in the range @0..(n-1)@, where @n@ is the -- size of the permutation. 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 {-# INLINE setElem #-} -- | @swapElems p i j@ exchanges the @i@th and @j@th elements of the -- permutation @p@. 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 {-# INLINE swapElems #-} -- | Returns whether or not the permutation is valid. For it to be valid, -- the numbers @0,...,(n-1)@ must all appear exactly once in the stored -- values @p[0],...,p[n-1]@. 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) {-# INLINE isValid #-} -- | Compute the inverse of a permutation. getInverse :: (MPermute p m) => p -> m p getInverse p = do n <- getSize p q <- newPermute_ n copyInverse q p return $! q {-# INLINE getInverse #-} -- | Set one permutation to be the inverse of another. -- @copyInverse inv p@ computes the inverse of @p@ and stores it in @inv@. -- The two permutations must have the same size. 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 .. n-1] $ \i -> do i' <- unsafeGetElem src i unsafeSetElem dst i' i {-# INLINE copyInverse #-} -- | Advance a permutation to the next permutation in lexicogrphic order and -- return @True@. If no further permutaitons are available, return @False@ and -- leave the permutation unmodified. Starting with the idendity permutation -- and repeatedly calling @setNext@ will iterate through all permutations of a -- given size. setNext :: (MPermute p m) => p -> m Bool setNext = setNextBy compare {-# INLINE setNext #-} -- | Step backwards to the previous permutation in lexicographic order and -- return @True@. If there is no previous permutation, return @False@ and -- leave the permutation unmodified. setPrev :: (MPermute p m) => p -> m Bool setPrev = setNextBy (flip compare) {-# INLINE setPrev #-} setNextBy :: (MPermute p m) => (Int -> Int -> Ordering) -> p -> m Bool setNextBy cmp p = do n <- getSize p if n > 1 then do findLastAscent (n-2) >>= maybe (return False) (\i -> do i' <- unsafeGetElem p i i1' <- unsafeGetElem p (i+1) (k,k') <- findSmallestLargerThan n i' (i+2) (i+1) i1' -- swap i and k unsafeSetElem p i k' unsafeSetElem p k i' reverseElems (i+1) (n-1) 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 (i-1) 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) (j-1) {-# INLINE setNextBy #-} -- | Get a lazy list of swaps equivalent to the permutation. A result of -- @[ (i0,j0), (i1,j1), ..., (ik,jk) ]@ means swap @i0 \<-> j0@, -- then @i1 \<-> j1@, and so on until @ik \<-> jk@. The laziness makes this -- function slightly dangerous if you are modifying the permutation. getSwaps :: (MPermute p m) => p -> m [(Int,Int)] getSwaps = getSwapsHelp overlapping_pairs where overlapping_pairs [] = [] overlapping_pairs [_] = [] overlapping_pairs (x:xs@(y:_)) = (x,y) : overlapping_pairs xs {-# INLINE getSwaps #-} -- | Get a lazy list of swaps equivalent to the inverse of a permutation. getInvSwaps :: (MPermute p m) => p -> m [(Int,Int)] getInvSwaps = getSwapsHelp pairs_withstart where pairs_withstart [] = error "Empty cycle" pairs_withstart (x:xs) = [(x,y) | y <- xs] {-# INLINE getInvSwaps #-} getSwapsHelp :: (MPermute p m) => ([Int] -> [(Int, Int)]) -> p -> m [(Int,Int)] getSwapsHelp swapgen p = do liftM (concatMap swapgen) $ getCycles p {-# INLINE getSwapsHelp #-} -- | @getCycleFrom p i@ gets the list of elements reachable from @i@ -- by repeated application of @p@. getCycleFrom :: (MPermute p m) => p -> Int -> m [Int] getCycleFrom p i = liftM (i:) $ go i where go j = unsafeInterleaveM $ do next <- unsafeGetElem p j if next == i then return [] else liftM (next:) $ go next {-# INLINE getCycleFrom #-} -- | @getCycles p@ returns the list of disjoin cycles in @p@. getCycles :: (MPermute p m) => p -> m [[Int]] getCycles p = do n <- getSize p go n 0 where go n i | i == n = return [] | otherwise = unsafeInterleaveM $ do least <- isLeast i i if least then do c <- getCycleFrom p i liftM (c:) $ go n (i+1) else go n (i+1) isLeast i j = do k <- unsafeGetElem p j case compare i k of LT -> isLeast i k EQ -> return True GT -> return False {-# INLINE getCycles #-} -- | Whether or not the permutation is made from an even number of swaps getIsEven :: (MPermute p m) => p -> m Bool getIsEven p = do liftM (even . length) $ getSwaps p -- | @getPeriod p@ - The first power of @p@ that is the identity permutation getPeriod :: (MPermute p m) => p -> m Integer getPeriod p = do cycles <- getCycles p let lengths = map List.genericLength cycles return $ List.foldl' lcm 1 lengths -- | Convert a mutable permutation to an immutable one. freeze :: (MPermute p m) => p -> m Permute freeze p = unsafeFreeze =<< newCopyPermute p {-# INLINE freeze #-} -- | Convert an immutable permutation to a mutable one. thaw :: (MPermute p m) => Permute -> m p thaw p = newCopyPermute =<< unsafeThaw p {-# INLINE thaw #-} -- | @getSort n xs@ sorts the first @n@ elements of @xs@ and returns a -- permutation which transforms @xs@ into sorted order. The results are -- undefined if @n@ is greater than the length of @xs@. This is a special -- case of 'getSortBy'. getSort :: (Ord a, MPermute p m) => Int -> [a] -> m ([a], p) getSort = getSortBy compare {-# INLINE getSort #-} 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 {-# INLINE getSortBy #-} -- | @getOrder n xs@ returns a permutation which rearranges the first @n@ -- elements of @xs@ into ascending order. The results are undefined if @n@ is -- greater than the length of @xs@. This is a special case of 'getOrderBy'. getOrder :: (Ord a, MPermute p m) => Int -> [a] -> m p getOrder = getOrderBy compare {-# INLINE getOrder #-} getOrderBy :: (MPermute p m) => (a -> a -> Ordering) -> Int -> [a] -> m p getOrderBy cmp n xs = liftM snd $ getSortBy cmp n xs {-# INLINE getOrderBy #-} -- | @getRank n xs@ eturns a permutation, the inverse of which rearranges the -- first @n@ elements of @xs@ into ascending order. The returned permutation, -- @p@, has the property that @p[i]@ is the rank of the @i@th element of @xs@. -- The results are undefined if @n@ is greater than the length of @xs@. -- This is a special case of 'getRankBy'. getRank :: (Ord a, MPermute p m) => Int -> [a] -> m p getRank = getRankBy compare {-# INLINE getRank #-} getRankBy :: (MPermute p m) => (a -> a -> Ordering) -> Int -> [a] -> m p getRankBy cmp n xs = do p <- getOrderBy cmp n xs getInverse p {-# INLINE getRankBy #-} --------------------------------- Instances --------------------------------- instance MPermute (STPermute s) (ST s) where getSize = getSizeSTPermute {-# INLINE getSize #-} newPermute = newSTPermute {-# INLINE newPermute #-} newPermute_ = newSTPermute_ {-# INLINE newPermute_ #-} unsafeGetElem = unsafeGetElemSTPermute {-# INLINE unsafeGetElem #-} unsafeSetElem = unsafeSetElemSTPermute {-# INLINE unsafeSetElem #-} unsafeSwapElems = unsafeSwapElemsSTPermute {-# INLINE unsafeSwapElems #-} getElems = getElemsSTPermute {-# INLINE getElems #-} setElems = setElemsSTPermute {-# INLINE setElems #-} unsafeFreeze = unsafeFreezeSTPermute {-# INLINE unsafeFreeze #-} unsafeThaw = unsafeThawSTPermute {-# INLINE unsafeThaw #-} unsafeInterleaveM = unsafeInterleaveST {-# INLINE unsafeInterleaveM #-} instance MPermute IOPermute IO where getSize = getSizeIOPermute {-# INLINE getSize #-} newPermute = newIOPermute {-# INLINE newPermute #-} newPermute_ = newIOPermute_ {-# INLINE newPermute_ #-} unsafeGetElem = unsafeGetElemIOPermute {-# INLINE unsafeGetElem #-} unsafeSetElem = unsafeSetElemIOPermute {-# INLINE unsafeSetElem #-} unsafeSwapElems = unsafeSwapElemsIOPermute {-# INLINE unsafeSwapElems #-} getElems = getElemsIOPermute {-# INLINE getElems #-} setElems = setElemsIOPermute {-# INLINE setElems #-} unsafeFreeze = unsafeFreezeIOPermute {-# INLINE unsafeFreeze #-} unsafeThaw = unsafeThawIOPermute {-# INLINE unsafeThaw #-} unsafeInterleaveM = unsafeInterleaveIO {-# INLINE unsafeInterleaveM #-} permutation-0.5.0.5/lib/Data/Permute/IOBase.hs0000644000000000000000000000425412457565375017142 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Permute.IOBase -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Data.Permute.IOBase where import Control.Monad import Control.Monad.ST import Data.Permute.Base -- | A mutable permutation that can be manipulated in the 'IO' monad. newtype IOPermute = IOPermute (STPermute RealWorld) deriving Eq newIOPermute :: Int -> IO (IOPermute) newIOPermute n = liftM IOPermute $ stToIO (newSTPermute n) {-# INLINE newIOPermute #-} newIOPermute_ :: Int -> IO (IOPermute) newIOPermute_ n = liftM IOPermute $ stToIO (newSTPermute_ n) {-# INLINE newIOPermute_ #-} getSizeIOPermute :: IOPermute -> IO Int getSizeIOPermute (IOPermute p) = stToIO $ getSizeSTPermute p {-# INLINE getSizeIOPermute #-} sizeIOPermute :: IOPermute -> Int sizeIOPermute (IOPermute p) = sizeSTPermute p {-# INLINE sizeIOPermute #-} unsafeGetElemIOPermute :: IOPermute -> Int -> IO Int unsafeGetElemIOPermute (IOPermute p) i = stToIO $ unsafeGetElemSTPermute p i {-# INLINE unsafeGetElemIOPermute #-} unsafeSetElemIOPermute :: IOPermute -> Int -> Int -> IO () unsafeSetElemIOPermute (IOPermute p) i x = stToIO $ unsafeSetElemSTPermute p i x {-# INLINE unsafeSetElemIOPermute #-} unsafeSwapElemsIOPermute :: IOPermute -> Int -> Int -> IO () unsafeSwapElemsIOPermute (IOPermute p) i j = stToIO $ unsafeSwapElemsSTPermute p i j {-# INLINE unsafeSwapElemsIOPermute #-} getElemsIOPermute :: IOPermute -> IO [Int] getElemsIOPermute (IOPermute p) = stToIO $ getElemsSTPermute p {-# INLINE getElemsIOPermute #-} setElemsIOPermute :: IOPermute -> [Int] -> IO () setElemsIOPermute (IOPermute p) is = stToIO $ setElemsSTPermute p is {-# INLINE setElemsIOPermute #-} unsafeFreezeIOPermute :: IOPermute -> IO Permute unsafeFreezeIOPermute (IOPermute p) = stToIO $ unsafeFreezeSTPermute p {-# INLINE unsafeFreezeIOPermute #-} unsafeThawIOPermute :: Permute -> IO (IOPermute) unsafeThawIOPermute p = liftM IOPermute $ stToIO (unsafeThawSTPermute p) {-# INLINE unsafeThawIOPermute #-} permutation-0.5.0.5/lib/Data/Permute/Base.hs0000644000000000000000000000716512457565375016716 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -XMagicHash -XUnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Permute.Base -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Data.Permute.Base where import Control.Monad import Control.Monad.ST import Foreign import Data.IntArray ( IntArray, STIntArray ) import qualified Data.IntArray as Arr import qualified Data.IntArray as ArrST --------------------------------- Permute --------------------------------- -- | The immutable permutation data type. -- Internally, a permutation of size @n@ is stored as an -- @0@-based array of @n@ 'Int's. The permutation represents a reordering of -- the integers @0, ..., (n-1)@. The permutation sents the value p[i] to -- @i@. newtype Permute = Permute IntArray unsafeAt :: Permute -> Int -> Int unsafeAt (Permute p) i = Arr.unsafeAt p i {-# INLINE unsafeAt #-} -- | Get the size of the permutation. size :: Permute -> Int size (Permute p) = Arr.numElements p {-# INLINE size #-} -- | Get a list of the permutation elements. elems :: Permute -> [Int] elems (Permute p) = Arr.elems p {-# INLINE elems #-} instance Show Permute where show p = "listPermute " ++ show (size p) ++ " " ++ show (elems p) instance Eq Permute where (==) p q = (size p == size q) && (elems p == elems q) --------------------------------- STPermute -------------------------------- -- | A mutable permutation that can be manipulated in the 'ST' monad. The -- type argument @s@ is the state variable argument for the 'ST' type. newtype STPermute s = STPermute (STIntArray s) getSizeSTPermute :: STPermute s -> ST s Int getSizeSTPermute (STPermute marr) = ArrST.getNumElements marr {-# INLINE getSizeSTPermute #-} sizeSTPermute :: STPermute s -> Int sizeSTPermute (STPermute marr) = ArrST.numElementsSTIntArray marr {-# INLINE sizeSTPermute #-} newSTPermute :: Int -> ST s (STPermute s) newSTPermute n = do p@(STPermute marr) <- newSTPermute_ n ArrST.writeElems marr [0 .. n-1] return p {-# INLINE newSTPermute #-} newSTPermute_ :: Int -> ST s (STPermute s) newSTPermute_ n = do when (n < 0) $ fail "invalid size" liftM STPermute $ ArrST.newArray_ n {-# INLINE newSTPermute_ #-} unsafeGetElemSTPermute :: STPermute s -> Int -> ST s Int unsafeGetElemSTPermute (STPermute marr) i = ArrST.unsafeRead marr i {-# INLINE unsafeGetElemSTPermute #-} unsafeSetElemSTPermute :: STPermute s -> Int -> Int -> ST s () unsafeSetElemSTPermute (STPermute marr) i x = ArrST.unsafeWrite marr i x {-# INLINE unsafeSetElemSTPermute #-} unsafeSwapElemsSTPermute :: STPermute s -> Int -> Int -> ST s () unsafeSwapElemsSTPermute (STPermute marr) i j = ArrST.unsafeSwap marr i j {-# INLINE unsafeSwapElemsSTPermute #-} getElemsSTPermute :: STPermute s -> ST s [Int] getElemsSTPermute (STPermute marr) = ArrST.readElems marr {-# INLINE getElemsSTPermute #-} setElemsSTPermute :: STPermute s -> [Int] -> ST s () setElemsSTPermute (STPermute marr) is = ArrST.writeElems marr is {-# INLINE setElemsSTPermute #-} unsafeFreezeSTPermute :: STPermute s -> ST s Permute unsafeFreezeSTPermute (STPermute marr) = (liftM Permute . ArrST.unsafeFreeze) marr {-# INLINE unsafeFreezeSTPermute #-} unsafeThawSTPermute :: Permute -> ST s (STPermute s) unsafeThawSTPermute (Permute arr) = (liftM STPermute . ArrST.unsafeThaw) arr {-# INLINE unsafeThawSTPermute #-} instance Eq (STPermute s) where (==) (STPermute marr1) (STPermute marr2) = ArrST.sameSTIntArray marr1 marr2 permutation-0.5.0.5/lib/Data/Permute/ST.hs0000644000000000000000000000210412457565375016356 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Permute.ST -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Mutable permutations in the 'ST' monad. module Data.Permute.ST ( -- * Permutations STPermute, runSTPermute, -- * Overloaded mutable permutation interface module Data.Permute.MPermute ) where import Control.Monad.ST import Data.Permute.Base( Permute, STPermute, unsafeFreezeSTPermute ) import Data.Permute.MPermute -- | A safe way to create and work with a mutable permutation before returning -- an immutable one for later perusal. This function avoids copying the -- permutation before returning it - it uses unsafeFreeze internally, but this -- wrapper is a safe interface to that function. runSTPermute :: (forall s. ST s (STPermute s)) -> Permute runSTPermute p = runST (p >>= unsafeFreezeSTPermute) {-# INLINE runSTPermute #-} permutation-0.5.0.5/lib/Data/Permute/IO.hs0000644000000000000000000000107012457565375016340 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Permute.IO -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Mutable permutations in the 'IO' monad. module Data.Permute.IO ( -- * Permutations IOPermute, -- * Overloaded mutable permutation interface module Data.Permute.MPermute ) where import Data.Permute.IOBase( IOPermute ) import Data.Permute.MPermute permutation-0.5.0.5/lib/Data/Choose/0000755000000000000000000000000012457565375015276 5ustar0000000000000000permutation-0.5.0.5/lib/Data/Choose/MChoose.hs0000644000000000000000000002410312457565375017167 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Choose.MChoose -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- An overloaded interface to mutable combinations. For combination types which -- can be used with this interface, see "Data.Choose.IO" and "Data.Choose.ST". -- module Data.Choose.MChoose ( -- * Class of mutable combination types MChoose, -- * Constructing mutable combinations newChoose, newChoose_, newListChoose, newCopyChoose, copyChoose, setFirst, -- * Accessing combination elements getElem, setElem, -- * Combination properties getPossible, getSize, getElems, setElems, isValid, -- * Combination functions getComplement, getComplElems, setNext, setPrev, -- * Converstions between mutable and immutable combinations freeze, unsafeFreeze, thaw, unsafeThaw, -- * Unsafe operations unsafeNewListChoose, unsafeGetElem, unsafeSetElem, ) where import Control.Monad import Control.Monad.ST import Data.Choose.Base import Data.Choose.IOBase --------------------------------- MChoose -------------------------------- -- | Class for representing a mutable combination. The type is parameterized -- over the type of the monad, @m@, in which the mutable combination will be -- manipulated. class (Monad m) => MChoose c m | c -> m, m -> c where -- | Get the number of possibilities, @n@ in the combination. getPossible :: c -> m Int -- | Get the number of outcomes, @k@ in the combination. getSize :: c -> m Int -- | @newChoose n k@ creates a new combination of @k@ outcomes from @n@ -- possibilites initialized to the subset @{ 0, ..., k-1 }@. newChoose :: Int -> Int -> m c -- | @newChoose n k@ allocates a new combination of @k@ outcomes from -- @n@ possibilities but does not initialize it. newChoose_ :: Int -> Int -> m c unsafeGetElem :: c -> Int -> m Int unsafeSetElem :: c -> Int -> Int -> m () -- | Get a lazy list of the combination elements. The laziness makes this -- function slightly dangerous if you are modifying the combination. getElems :: c -> m [Int] -- | Set all the values of a combination from a list of elements. setElems :: c -> [Int] -> m () unsafeFreeze :: c -> m Choose unsafeThaw :: Choose -> m c -- | Construct a combination from a list of elements. -- @newListChoose n k is@ creates a combination of @k@ outcomes from @n@ -- possibilities initialized to have the @i@th element equal to @is !! i@. -- For the combination to be valid, the elements must all be unique, they -- must be in sorted order, and they all must be in the range @0 .. n-1@. newListChoose :: (MChoose c m) => Int -> Int -> [Int] -> m c newListChoose n k is = do c <- unsafeNewListChoose n k is valid <- isValid c when (not valid) $ fail "invalid combination" return c {-# INLINE newListChoose #-} unsafeNewListChoose :: (MChoose c m) => Int -> Int -> [Int] -> m c unsafeNewListChoose n k is = do c <- newChoose_ n k setElems c is return c {-# INLINE unsafeNewListChoose #-} -- | Construct a new combination by copying another. newCopyChoose :: (MChoose c m) => c -> m c newCopyChoose c = do n <- getPossible c k <- getSize c c' <- newChoose_ n k copyChoose c' c return c' {-# INLINE newCopyChoose #-} -- | @copyChoose dst src@ copies the elements of the combination @src@ -- into the combination @dst@. The two combinations must have the same -- size. copyChoose :: (MChoose c m) => c -> c -> m () copyChoose dst src = getElems src >>= setElems dst {-# INLINE copyChoose #-} -- | Set a combination to be the first subset of its size. setFirst :: (MChoose c m) => c -> m () setFirst c = do k <- getSize c setElems c [0 .. k-1] {-# INLINE setFirst #-} -- | @getElem c i@ gets the value of the @i@th element of the combination -- @c@. The index @i@ must be in the range @0..k-1@, where @n@ is the -- size of the combination. getElem :: (MChoose c m) => c -> Int -> m Int getElem c i = do k <- getSize c when (i < 0 || i >= k) $ fail "getElem: invalid index" unsafeGetElem c i {-# INLINE getElem #-} -- | @setElem c i x@ sets the value of the @i@th element of the combination -- @c@. The index @i@ must be in the range @0..k-1@, where @k@ is the -- size of the combination. setElem :: (MChoose c m) => c -> Int -> Int -> m () setElem c i x = do k <- getSize c when (i < 0 || i >= k) $ fail "getElem: invalid index" unsafeSetElem c i x {-# INLINE setElem #-} -- | Returns whether or not the combination is valid. For it to be valid, -- the elements must all be unique, they must be in sorted order, and they -- all must be in the range @0 .. n-1@, where @n@ is the number of -- possibilies in the combination. isValid :: (MChoose c m) => c -> m Bool isValid c = do n <- getPossible c is <- getElems c return $! go n (-1) is where go _ _ [] = True go n j (i:is) = i > j && i < n && go n i is {-# INLINE isValid #-} -- | Compute the complement of a combination getComplement :: (MChoose c m) => c -> m c getComplement c = do n <- getPossible c k <- getSize c d <- newChoose_ n (n-k) setElems d =<< getComplElems c return $! d {-# INLINE getComplement #-} -- | Return a lazy list of the elements in the complement of a combination. -- If the combination is a subset of @k@ outcomes from @n@ possibilities, then -- the returned list will be sorted and of length @n-k@. -- Due to the laziness, you should be careful when using this function if you -- are also modifying the combination. getComplElems :: (MChoose c m) => c -> m [Int] getComplElems c = do n <- getPossible c is <- getElems c return $ go n is 0 where go n [] j = [j .. n-1] go n (i:is) j | j == i = go n is (j+1) | otherwise = [j .. i-1] ++ go n is (i+1) {-# INLINE getComplElems #-} -- | Advance a combination to the next in lexicogrphic order and return @True@. -- If no further combinations are available, return @False@ and leave the -- combination unmodified. Starting with @[ 0 .. k-1 ]@ and repeatedly -- calling @setNext@ will iterate through all subsets of size @k@. setNext :: (MChoose c m) => c -> m Bool setNext c = do n <- getPossible c k <- getSize c if k > 0 then do findIncrement (k-1) (n-1) >>= maybe (return False) (\(i,i') -> do unsafeSetElem c i (i'+1) setAscending k (i+1) (i'+2) return True ) else return False where findIncrement i m = do i' <- unsafeGetElem c i if i' /= m then return (Just (i,i')) else recurse where recurse = if i /= 0 then findIncrement (i-1) (m-1) else return Nothing setAscending k i x | i == k = return () | otherwise = do unsafeSetElem c i x setAscending k (i+1) (x+1) {-# INLINE setNext #-} -- | Step backwards to the previous combination in lexicographic order and -- return @True@. If there is no previous combination, return @False@ and -- leave the combination unmodified. setPrev :: (MChoose c m) => c -> m Bool setPrev c = do n <- getPossible c k <- getSize c if k > 0 then do k1' <- unsafeGetElem c (k-1) findGap (k-1) k1' >>= maybe (return False) (\(i,i') -> do unsafeSetElem c i (i'-1) setAscending k (i+1) (n-k+i+1) return True ) else return False where findGap i i' | i == 0 = if i' == 0 then return $ Nothing else return $ Just (0,i') | otherwise = let j = i-1 in do j' <- unsafeGetElem c j if i' /= j'+1 then return $ Just (i,i') else findGap j j' setAscending k i x | i == k = return () | otherwise = do unsafeSetElem c i x setAscending k (i+1) (x+1) {-# INLINE setPrev #-} -- | Convert a mutable combination to an immutable one. freeze :: (MChoose c m) => c -> m Choose freeze c = unsafeFreeze =<< newCopyChoose c {-# INLINE freeze #-} -- | Convert an immutable combination to a mutable one. thaw :: (MChoose c m) => Choose -> m c thaw c = newCopyChoose =<< unsafeThaw c {-# INLINE thaw #-} --------------------------------- Instances --------------------------------- instance MChoose (STChoose s) (ST s) where getPossible = getPossibleSTChoose {-# INLINE getPossible #-} getSize = getSizeSTChoose {-# INLINE getSize #-} newChoose = newSTChoose {-# INLINE newChoose #-} newChoose_ = newSTChoose_ {-# INLINE newChoose_ #-} unsafeGetElem = unsafeGetElemSTChoose {-# INLINE unsafeGetElem #-} unsafeSetElem = unsafeSetElemSTChoose {-# INLINE unsafeSetElem #-} getElems = getElemsSTChoose {-# INLINE getElems #-} setElems = setElemsSTChoose {-# INLINE setElems #-} unsafeFreeze = unsafeFreezeSTChoose {-# INLINE unsafeFreeze #-} unsafeThaw = unsafeThawSTChoose {-# INLINE unsafeThaw #-} instance MChoose IOChoose IO where getPossible = getPossibleIOChoose {-# INLINE getPossible #-} getSize = getSizeIOChoose {-# INLINE getSize #-} newChoose = newIOChoose {-# INLINE newChoose #-} newChoose_ = newIOChoose_ {-# INLINE newChoose_ #-} unsafeGetElem = unsafeGetElemIOChoose {-# INLINE unsafeGetElem #-} unsafeSetElem = unsafeSetElemIOChoose {-# INLINE unsafeSetElem #-} getElems = getElemsIOChoose {-# INLINE getElems #-} setElems = setElemsIOChoose {-# INLINE setElems #-} unsafeFreeze = unsafeFreezeIOChoose {-# INLINE unsafeFreeze #-} unsafeThaw = unsafeThawIOChoose {-# INLINE unsafeThaw #-} permutation-0.5.0.5/lib/Data/Choose/IOBase.hs0000644000000000000000000000431312457565375016735 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Choose.IOBase -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Data.Choose.IOBase where import Control.Monad import Control.Monad.ST import Data.Choose.Base -- | A mutable combination that can be manipulated in the 'IO' monad. newtype IOChoose = IOChoose (STChoose RealWorld) deriving Eq newIOChoose :: Int -> Int -> IO (IOChoose) newIOChoose n k = liftM IOChoose $ stToIO (newSTChoose n k) {-# INLINE newIOChoose #-} newIOChoose_ :: Int -> Int -> IO (IOChoose) newIOChoose_ n k = liftM IOChoose $ stToIO (newSTChoose_ n k) {-# INLINE newIOChoose_ #-} getPossibleIOChoose :: IOChoose -> IO Int getPossibleIOChoose (IOChoose c) = stToIO $ getPossibleSTChoose c {-# INLINE getPossibleIOChoose #-} possibleIOChoose :: IOChoose -> Int possibleIOChoose (IOChoose c) = possibleSTChoose c {-# INLINE possibleIOChoose #-} getSizeIOChoose :: IOChoose -> IO Int getSizeIOChoose (IOChoose c) = stToIO $ getSizeSTChoose c {-# INLINE getSizeIOChoose #-} sizeIOChoose :: IOChoose -> Int sizeIOChoose (IOChoose c) = sizeSTChoose c {-# INLINE sizeIOChoose #-} unsafeGetElemIOChoose :: IOChoose -> Int -> IO Int unsafeGetElemIOChoose (IOChoose c) i = stToIO $ unsafeGetElemSTChoose c i {-# INLINE unsafeGetElemIOChoose #-} unsafeSetElemIOChoose :: IOChoose -> Int -> Int -> IO () unsafeSetElemIOChoose (IOChoose c) i x = stToIO $ unsafeSetElemSTChoose c i x {-# INLINE unsafeSetElemIOChoose #-} getElemsIOChoose :: IOChoose -> IO [Int] getElemsIOChoose (IOChoose c) = stToIO $ getElemsSTChoose c {-# INLINE getElemsIOChoose #-} setElemsIOChoose :: IOChoose -> [Int] -> IO () setElemsIOChoose (IOChoose c) is = stToIO $ setElemsSTChoose c is {-# INLINE setElemsIOChoose #-} unsafeFreezeIOChoose :: IOChoose -> IO Choose unsafeFreezeIOChoose (IOChoose c) = stToIO $ unsafeFreezeSTChoose c {-# INLINE unsafeFreezeIOChoose #-} unsafeThawIOChoose :: Choose -> IO (IOChoose) unsafeThawIOChoose c = liftM IOChoose $ stToIO (unsafeThawSTChoose c) {-# INLINE unsafeThawIOChoose #-} permutation-0.5.0.5/lib/Data/Choose/Base.hs0000644000000000000000000001024412457565375016505 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Choose.Base -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- module Data.Choose.Base where import Control.Monad import Control.Monad.ST import Foreign import Data.IntArray ( IntArray, STIntArray ) import qualified Data.IntArray as Arr import qualified Data.IntArray as ArrST --------------------------------- Choose --------------------------------- -- | The immutable combination data type. A way of representing @k@ -- unordered outcomes from @n@ possiblities. The possibilites are -- represented as the indices @0, ..., n-1@, and the outcomes are -- given as a subset of size @k@. The subset is stored with the indices -- in ascending order. data Choose = Choose {-# UNPACK #-} !Int -- n {-# UNPACK #-} !IntArray -- the subset of size k unsafeAt :: Choose -> Int -> Int unsafeAt (Choose _ arr) i = Arr.unsafeAt arr i {-# INLINE unsafeAt #-} -- | Get the number of outcomes, @k@. size :: Choose -> Int size (Choose _ arr) = Arr.numElements arr {-# INLINE size #-} -- | Get the number of possibilities, @n@. possible :: Choose -> Int possible (Choose n _) = n {-# INLINE possible #-} -- | Get a list of the @k@ outcomes. elems :: Choose -> [Int] elems (Choose _ arr) = Arr.elems arr {-# INLINE elems #-} instance Show Choose where show c = "listChoose " ++ show n ++ " " ++ show k ++ " " ++ show es where n = possible c k = size c es = elems c instance Eq Choose where (==) c1 c2 = ( (possible c1 == possible c2) && (size c1 == size c2) && (elems c1 == elems c2) ) --------------------------------- STChoose -------------------------------- -- | A mutable combination that can be manipulated in the 'ST' monad. The -- type argument @s@ is the state variable argument for the 'ST' type. data STChoose s = STChoose {-# UNPACK #-} !Int -- n {-# UNPACK #-} !(STIntArray s) -- the subset getSizeSTChoose :: STChoose s -> ST s Int getSizeSTChoose (STChoose _ marr) = ArrST.getNumElements marr {-# INLINE getSizeSTChoose #-} sizeSTChoose :: STChoose s -> Int sizeSTChoose (STChoose _ marr) = ArrST.numElementsSTIntArray marr {-# INLINE sizeSTChoose #-} getPossibleSTChoose :: STChoose s -> ST s Int getPossibleSTChoose (STChoose n _) = return n {-# INLINE getPossibleSTChoose #-} possibleSTChoose :: STChoose s -> Int possibleSTChoose (STChoose n _) = n {-# INLINE possibleSTChoose #-} newSTChoose :: Int -> Int -> ST s (STChoose s) newSTChoose n k = do c@(STChoose _ marr) <- newSTChoose_ n k ArrST.writeElems marr [0 .. k-1] return c {-# INLINE newSTChoose #-} newSTChoose_ :: Int -> Int -> ST s (STChoose s) newSTChoose_ n k = do when (n < 0) $ fail "invalid number of possibilities" when (k < 0 || k > n) $ fail "invalid outcome size" liftM (STChoose n) $ ArrST.newArray_ k {-# INLINE newSTChoose_ #-} unsafeGetElemSTChoose :: STChoose s -> Int -> ST s Int unsafeGetElemSTChoose (STChoose _ marr) i = ArrST.unsafeRead marr i {-# INLINE unsafeGetElemSTChoose #-} unsafeSetElemSTChoose :: STChoose s -> Int -> Int -> ST s () unsafeSetElemSTChoose (STChoose _ marr) i x = ArrST.unsafeWrite marr i x {-# INLINE unsafeSetElemSTChoose #-} getElemsSTChoose :: STChoose s -> ST s [Int] getElemsSTChoose (STChoose _ marr) = ArrST.readElems marr {-# INLINE getElemsSTChoose #-} setElemsSTChoose :: STChoose s -> [Int] -> ST s () setElemsSTChoose (STChoose _ marr) is = ArrST.writeElems marr is {-# INLINE setElemsSTChoose #-} unsafeFreezeSTChoose :: STChoose s -> ST s Choose unsafeFreezeSTChoose (STChoose n marr) = (liftM (Choose n) . ArrST.unsafeFreeze) marr {-# INLINE unsafeFreezeSTChoose #-} unsafeThawSTChoose :: Choose -> ST s (STChoose s) unsafeThawSTChoose (Choose n arr) = (liftM (STChoose n) . ArrST.unsafeThaw) arr {-# INLINE unsafeThawSTChoose #-} instance Eq (STChoose s) where (==) (STChoose _ marr1) (STChoose _ marr2) = ArrST.sameSTIntArray marr1 marr2 permutation-0.5.0.5/lib/Data/Choose/ST.hs0000644000000000000000000000206212457565375016160 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Choose.ST -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Mutable combinations in the 'ST' monad. module Data.Choose.ST ( -- * Combinations STChoose, runSTChoose, -- * Overloaded mutable combination interface module Data.Choose.MChoose ) where import Control.Monad.ST import Data.Choose.Base( Choose, STChoose, unsafeFreezeSTChoose ) import Data.Choose.MChoose -- | A safe way to create and work with a mutable combination before returning -- an immutable one for later perusal. This function avoids copying the -- combination before returning it - it uses unsafeFreeze internally, but this -- wrapper is a safe interface to that function. runSTChoose :: (forall s. ST s (STChoose s)) -> Choose runSTChoose c = runST (c >>= unsafeFreezeSTChoose) {-# INLINE runSTChoose #-} permutation-0.5.0.5/lib/Data/Choose/IO.hs0000644000000000000000000000105712457565375016144 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Choose.IO -- Copyright : Copyright (c) , Patrick Perry -- License : BSD3 -- Maintainer : Patrick Perry -- Stability : experimental -- -- Mutable combinations in the 'IO' monad. module Data.Choose.IO ( -- * Combinations IOChoose, -- * Overloaded mutable combination interface module Data.Choose.MChoose ) where import Data.Choose.IOBase( IOChoose ) import Data.Choose.MChoose permutation-0.5.0.5/examples/0000755000000000000000000000000012457565375014255 5ustar0000000000000000permutation-0.5.0.5/examples/Enumerate.hs0000644000000000000000000000470512457565375016544 0ustar0000000000000000module Main where import Control.Monad import Control.Monad.ST import Data.List( permutations ) import Data.STRef import System.Environment import Data.Permute import Data.Permute.MPermute -- | Execute an action on every permutation of a given order. This function -- is unsafe, because it only allocates space for a single permutation. The -- action @f@ should not retain any references to the passed-in @Permute@ -- object, otherwise bad things will happen. For instance, running -- > -- > forAllPermutes 2 id -- > -- in ghci yields @[listPermute 2 [1,0],listPermute 2 [1,0]]@. -- forAllPermutes :: Int -> (Permute -> a) -> [a] forAllPermutes n f = runST $ do -- Allocate a mutable permutation initialized to the identity p <- newPermute n -- Run the action on all successors of p runOnSuccessors p where runOnSuccessors p = do -- Cast the mutable permutation to an immutable one -- and the action on the immutable a <- liftM f (unsafeFreeze p) -- Set the permutation to be equal to its successor hasNext <- setNext p -- If a successor exists, recurse, otherwise stop as <- unsafeInterleaveST $ if hasNext then runOnSuccessors p else return [] return (a:as) forAllPermutesM_ :: (MPermute p m) => Int -> (Permute -> m a) -> m () forAllPermutesM_ n f = sequence_ $ forAllPermutes n f {-# INLINE forAllPermutesM_ #-} -- | Count the number of permutations of a given order countAllPermutes :: Int -> Int countAllPermutes n = length $ forAllPermutes n id -- | Another version of the same function. This one is slightly slower. countAllPermutes2 :: Int -> Int countAllPermutes2 n = runST $ do count <- newSTRef 0 forAllPermutesM_ n $ (const $ modifySTRef' count (+1)) readSTRef count where modifySTRef' var f = do old <- readSTRef var writeSTRef var $! f old -- | Yet another version, this time using 'permutations' from Data.List. -- This version is faster but uses more memory. countAllPermutes3 :: Int -> Int countAllPermutes3 n = length $ permutations [0 .. n-1] -- | Print all permutations of a given order. printAllPermutes :: Int -> IO () printAllPermutes n = forAllPermutesM_ n (putStrLn . show . elems) main = do n <- fmap (read . head) getArgs let count = countAllPermutes n putStrLn $ "There are " ++ show count ++ " permutations of order " ++ show n ++ "."