module Data.Permgram
(
Label
, Permgram
, perm
, label
, size
, permgram
, inverse
) where
import Data.Ord
import Data.List
import Data.Perm (Perm)
import qualified Data.Perm as P
import Data.Array.Unboxed
type Label a = Array Int a
data Permgram a = PGram {
perm :: Perm
, label :: Label a
}
constituents :: Permgram a -> (Perm, [a])
constituents (PGram v f) = (v, elems f)
instance Show a => Show (Permgram a) where
show w =
let (v, ys) = constituents w
in unwords ["permgram", "(" ++ show v ++ ")", show ys]
instance Eq a => Eq (Permgram a) where
u == v = constituents u == constituents v
instance Ord a => Ord (Permgram a) where
compare u v =
case comparing size u v of
EQ -> comparing constituents u v
x -> x
permgram :: Perm -> [a] -> Permgram a
permgram v = PGram v . listArray (0, P.size v 1) . cycle
inverse :: Permgram a -> Permgram a
inverse (PGram u f) = PGram (P.fromList v) (listArray (0,n1) (map (f!) v))
where
v = map snd . sort $ zip (P.toList u) [0..]
n = P.size u
size :: Permgram a -> Int
size = P.size . perm
instance Functor Permgram where
fmap f w = w { label = amap f (label w) }
instance Monad Permgram where
return x = permgram (P.fromList [0]) [x]
w >>= f = joinPermgram $ fmap f w
joinPermgram :: Permgram (Permgram a) -> Permgram a
joinPermgram w@(PGram u f) = PGram (P.fromList xs) (listArray (0,m1) ys)
where
len = amap size f
m = sum $ elems len
n = size w
uInverse = map snd . sort $ zip (P.toList u) [0..]
a :: UArray Int Int
a = listArray (0,n1) . scanl (+) 0 $ map (len!) uInverse
(xs, ys) = unzip $ do
i <- [0..n1]
let PGram v g = f!i
let d = a ! (u `P.unsafeAt` i)
[ (d + v `P.unsafeAt` j, g!j) | j <- [0..len!i1] ]