uAgda-1.2.0.3: Permutation.hs

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