module Permutation where import Data.Char import Display import Data.Monoid import Data.List import Data.Maybe import Data.Tree (flatten) import Data.Graph (dff, Graph) import Data.Array type Orbit = [Int] type Orbits = [Orbit] mkPerm :: [Int] -> Permutation mkPerm xs | sort xs == [0..length xs-1] = P xs | otherwise = error \$ "malformed permutation: " ++ show xs liftPermut (P xs) = P (xs ++ [length xs]) permFromString "" = P [1,0] permFromString xs = mkPerm . map digitToInt \$ xs newtype Permutation = P {unP :: [Int]} deriving (Eq) instance Show Permutation where show = show . orbitsFromPerm permLength = length . unP invert :: Permutation -> Permutation invert (P xs) = P [fromJust \$ elemIndex x xs | x <- [0..length xs-1]] project :: Permutation -> [Bool] -> Permutation project (P perm) proj = P (map toIndex \$ sort projected) where projected = [x | (x,bit) <- zip perm proj, bit] toIndex x = fromJust \$ elemIndex x projected instance Permutable Int where apply (P p) i = p !! i swap2 :: Int -> Int -> Int -> Permutation swap2 n i j | i >= n || j >= n = error \$ "swap2: wrong arguments: " ++ show (n,i,j) | otherwise = mkPerm \$ map f [0..n-1] where f x | x == i = j | x == j = i | otherwise = x after :: Permutation -> Permutation -> Permutation (P p) `after` (P q) = P \$ [p!!(q!!i) | i <- [0..length q-1]] class Permutable a where apply :: Permutation -> a -> a instance Pretty Permutation where pretty (P [1,0]) = mempty pretty (P xs) = mconcat \$ map pretty \$ xs isIdentity (P x) = x == [0..length x-1] extendPerm (P x) = P \$ x ++ [length x] reducePerm (P x) n | n == length x = P x | n > length x = error "reduction attempted when extension should have been done" | r /= [n .. length x - 1] = error \$ "permutation " ++ show x ++ " cannot be reduced to dimension " ++ show n | otherwise = P l where (l,r) = splitAt n x simplifyPerm :: Int -> Permutation -> Permutation simplifyPerm n xs = permFromOrbits (length . unP \$ xs) . filter usefulOrbit . orbitsFromPerm \$ xs where usefulOrbit :: Orbit -> Bool usefulOrbit = or . map (>= n) permAsGraph :: Permutation -> Graph permAsGraph (P xs) = listArray (0,length xs-1) \$ map (:[]) xs -- | Returns the orbits of a permutation, as a partition orbitsFromPerm :: Permutation -> Orbits orbitsFromPerm = map flatten . dff . permAsGraph -- | Returns a permutation whose orbits are given. permFromOrbits :: Int -> Orbits -> Permutation permFromOrbits dimension orbits = P \$ elems \$ accumArray (\_ x-> x) 0 bnds (base ++ cycles) where cycleOf' first (v1:v2:vs) = (v1, v2) : cycleOf' first (v2:vs) cycleOf' first (v:[]) = [(v, first)] cycleOf' _ _ = [] cycleOf orbit@(v:_) = cycleOf' v orbit cycleOf _ = [] bnds = (0,dimension-1) base = [(i,i) | i <- range bnds] cycles = concat \$ map cycleOf \$ orbits