module Math.Combinatorics.CombinatorialHopfAlgebra where
import Data.List as L
import Data.Maybe (fromJust)
import qualified Data.Set as S
import Math.Core.Field
import Math.Core.Utils
import Math.Algebras.VectorSpace hiding (E)
import Math.Algebras.TensorProduct
import Math.Algebras.Structures
import Math.Combinatorics.Poset
import Math.CommutativeAlgebra.Polynomial
newtype Shuffle a = Sh [a] deriving (Eq,Ord,Show)
sh :: [a] -> Vect Q (Shuffle a)
sh = return . Sh
shuffles (x:xs) (y:ys) = map (x:) (shuffles xs (y:ys)) ++ map (y:) (shuffles (x:xs) ys)
shuffles xs [] = [xs]
shuffles [] ys = [ys]
instance (Eq k, Num k, Ord a) => Algebra k (Shuffle a) where
unit x = x *> return (Sh [])
mult = linear mult'
where mult' (Sh xs, Sh ys) = sumv [return (Sh zs) | zs <- shuffles xs ys]
deconcatenations xs = zip (inits xs) (tails xs)
instance (Eq k, Num k, Ord a) => Coalgebra k (Shuffle a) where
counit = unwrap . linear counit' where counit' (Sh xs) = if null xs then 1 else 0
comult = linear comult'
where comult' (Sh xs) = sumv [return (Sh us, Sh vs) | (us, vs) <- deconcatenations xs]
instance (Eq k, Num k, Ord a) => Bialgebra k (Shuffle a) where {}
instance (Eq k, Num k, Ord a) => HopfAlgebra k (Shuffle a) where
antipode = linear (\(Sh xs) -> (1)^length xs *> return (Sh (reverse xs)))
newtype SSymF = SSymF [Int] deriving (Eq)
instance Ord SSymF where
compare (SSymF xs) (SSymF ys) = compare (length xs, xs) (length ys, ys)
instance Show SSymF where
show (SSymF xs) = "F " ++ show xs
ssymF :: [Int] -> Vect Q SSymF
ssymF xs | L.sort xs == [1..n] = return (SSymF xs)
| otherwise = error "Not a permutation of [1..n]"
where n = length xs
shiftedConcat (SSymF xs) (SSymF ys) = let k = length xs in SSymF (xs ++ map (+k) ys)
prop_Associative f (x,y,z) = f x (f y z) == f (f x y) z
instance (Eq k, Num k) => Algebra k SSymF where
unit x = x *> return (SSymF [])
mult = linear mult'
where mult' (SSymF xs, SSymF ys) =
let k = length xs
in sumv [return (SSymF zs) | zs <- shuffles xs (map (+k) ys)]
flatten xs = let mapping = zip (L.sort xs) [1..]
in [y | x <- xs, let Just y = lookup x mapping]
instance (Eq k, Num k) => Coalgebra k SSymF where
counit = unwrap . linear counit' where counit' (SSymF xs) = if null xs then 1 else 0
comult = linear comult'
where comult' (SSymF xs) = sumv [return (SSymF (st us), SSymF (st vs)) | (us, vs) <- deconcatenations xs]
st = flatten
instance (Eq k, Num k) => Bialgebra k SSymF where {}
instance (Eq k, Num k) => HopfAlgebra k SSymF where
antipode = linear antipode'
where antipode' (SSymF []) = return (SSymF [])
antipode' x@(SSymF xs) = (negatev . mult . (id `tf` antipode) . removeTerm (SSymF [],x) . comult . return) x
newtype SSymM = SSymM [Int] deriving (Eq)
instance Ord SSymM where
compare (SSymM xs) (SSymM ys) = compare (length xs, xs) (length ys, ys)
instance Show SSymM where
show (SSymM xs) = "M " ++ show xs
ssymM :: [Int] -> Vect Q SSymM
ssymM xs | L.sort xs == [1..n] = return (SSymM xs)
| otherwise = error "Not a permutation of [1..n]"
where n = length xs
inversions xs = let ixs = zip [1..] xs
in [(i,j) | ((i,xi),(j,xj)) <- pairs ixs, xi > xj]
weakOrder xs ys = inversions xs `isSubsetAsc` inversions ys
mu (set,po) x y = mu' x y where
mu' x y | x == y = 1
| po x y = negate $ sum [mu' x z | z <- set, po x z, po z y, z /= y]
| otherwise = 0
toSSymF :: (Eq k, Num k) => Vect k SSymM -> Vect k SSymF
toSSymF = linear toSSymF'
where toSSymF' (SSymM u) = sumv [mu (set,po) u v *> return (SSymF v) | v <- set, po u v]
where set = L.permutations u
po = weakOrder
toSSymM :: (Eq k, Num k) => Vect k SSymF -> Vect k SSymM
toSSymM = linear toSSymM'
where toSSymM' (SSymF u) = sumv [return (SSymM v) | v <- set, po u v]
where set = L.permutations u
po = weakOrder
instance (Eq k, Num k) => Algebra k SSymM where
unit x = x *> return (SSymM [])
mult = toSSymM . mult . (toSSymF `tf` toSSymF)
instance (Eq k, Num k) => Coalgebra k SSymM where
counit = unwrap . linear counit' where counit' (SSymM xs) = if null xs then 1 else 0
comult = linear comult'
where comult' (SSymM xs) = sumv [return (SSymM (flatten ys), SSymM (flatten zs))
| (ys,zs) <- deconcatenations xs,
minimum (infinity:ys) > maximum (0:zs)]
infinity = maxBound :: Int
instance (Eq k, Num k) => Bialgebra k SSymM where {}
instance (Eq k, Num k) => HopfAlgebra k SSymM where
antipode = toSSymM . antipode . toSSymF
data PBT a = T (PBT a) a (PBT a) | E deriving (Eq, Show, Functor)
instance Ord a => Ord (PBT a) where
compare u v = compare (shapeSignature u, prefix u) (shapeSignature v, prefix v)
newtype YSymF a = YSymF (PBT a) deriving (Eq, Ord, Functor)
instance Show a => Show (YSymF a) where
show (YSymF t) = "F(" ++ show t ++ ")"
ysymF :: PBT a -> Vect Q (YSymF a)
ysymF t = return (YSymF t)
nodecount (T l x r) = 1 + nodecount l + nodecount r
nodecount E = 0
leafcount (T l x r) = leafcount l + leafcount r
leafcount E = 1
prefix E = []
prefix (T l x r) = x : prefix l ++ prefix r
shapeSignature t = shapeSignature' (nodeCountTree t)
where shapeSignature' E = [0]
shapeSignature' (T l x r) = x : shapeSignature' r ++ shapeSignature' l
nodeCountTree E = E
nodeCountTree (T l _ r) = T l' n r'
where l' = nodeCountTree l
r' = nodeCountTree r
n = 1 + (case l' of E -> 0; T _ lc _ -> lc) + (case r' of E -> 0; T _ rc _ -> rc)
leafCountTree E = E
leafCountTree (T l _ r) = T l' n r'
where l' = leafCountTree l
r' = leafCountTree r
n = (case l' of E -> 1; T _ lc _ -> lc) + (case r' of E -> 1; T _ rc _ -> rc)
lrCountTree E = E
lrCountTree (T l _ r) = T l' (lc,rc) r'
where l' = lrCountTree l
r' = lrCountTree r
lc = case l' of E -> 0; T _ (llc,lrc) _ -> 1 + llc + lrc
rc = case r' of E -> 0; T _ (rlc,rrc) _ -> 1 + rlc + rrc
shape :: PBT a -> PBT ()
shape t = fmap (\_ -> ()) t
numbered t = numbered' 1 t
where numbered' _ E = E
numbered' i (T l x r) = let k = nodecount l in T (numbered' i l) (i+k) (numbered' (i+k+1) r)
splits E = [(E,E)]
splits (T l x r) = [(u, T v x r) | (u,v) <- splits l] ++ [(T l x u, v) | (u,v) <- splits r]
instance (Eq k, Num k, Ord a) => Coalgebra k (YSymF a) where
counit = unwrap . linear counit' where counit' (YSymF E) = 1; counit' (YSymF (T _ _ _)) = 0
comult = linear comult'
where comult' (YSymF t) = sumv [return (YSymF u, YSymF v) | (u,v) <- splits t]
multisplits 1 t = [ [t] ]
multisplits 2 t = [ [u,v] | (u,v) <- splits t ]
multisplits n t = [ u:ws | (u,v) <- splits t, ws <- multisplits (n1) v ]
graft [t] E = t
graft ts (T l x r) = let (ls,rs) = splitAt (leafcount l) ts
in T (graft ls l) x (graft rs r)
instance (Eq k, Num k, Ord a) => Algebra k (YSymF a) where
unit x = x *> return (YSymF E)
mult = linear mult'
where mult' (YSymF t, YSymF u) = sumv [return (YSymF (graft ts u)) | ts <- multisplits (leafcount u) t]
instance (Eq k, Num k, Ord a) => Bialgebra k (YSymF a) where {}
instance (Eq k, Num k, Ord a) => HopfAlgebra k (YSymF a) where
antipode = linear antipode'
where antipode' (YSymF E) = return (YSymF E)
antipode' x = (negatev . mult . (id `tf` antipode) . removeTerm (YSymF E,x) . comult . return) x
newtype YSymM = YSymM (PBT ()) deriving (Eq, Ord)
instance Show YSymM where
show (YSymM t) = "M(" ++ show t ++ ")"
ysymM :: PBT () -> Vect Q YSymM
ysymM t = return (YSymM t)
trees 0 = [E]
trees n = [T l () r | i <- [0..n1], l <- trees (n1i), r <- trees i]
covers E = []
covers (T t@(T u x v) y w) = [T t' y w | t' <- covers t]
++ [T t y w' | w' <- covers w]
++ [T u y (T v x w)]
covers (T E x u) = [T E x u' | u' <- covers u]
tamariUpSet t = upSet' [] [t]
where upSet' interior boundary =
if null boundary
then interior
else let interior' = setUnionAsc interior boundary
boundary' = toSet $ concatMap covers boundary
in upSet' interior' boundary'
tamariOrder u v = weakOrder (minPerm u) (minPerm v)
toYSymF :: (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ())
toYSymF = linear toYSymF'
where toYSymF' (YSymM t) = sumv [mu (set,po) t s *> return (YSymF s) | s <- set]
where po = tamariOrder
set = tamariUpSet t
toYSymM :: (Eq k, Num k) => Vect k (YSymF ()) -> Vect k YSymM
toYSymM = linear toYSymM'
where toYSymM' (YSymF t) = sumv [return (YSymM s) | s <- tamariUpSet t]
instance (Eq k, Num k) => Algebra k YSymM where
unit x = x *> return (YSymM E)
mult = toYSymM . mult . (toYSymF `tf` toYSymF)
instance (Eq k, Num k) => Coalgebra k YSymM where
counit = unwrap . linear counit' where counit' (YSymM E) = 1; counit' (YSymM (T _ _ _)) = 0
comult = linear comult'
where comult' (YSymM t) = sumv [return (YSymM r, YSymM s) | (rs,ss) <- deconcatenations (underDecomposition t),
let r = foldl under E rs, let s = foldl under E ss]
instance (Eq k, Num k) => Bialgebra k YSymM where {}
instance (Eq k, Num k) => HopfAlgebra k YSymM where
antipode = toYSymM . antipode . toYSymF
compositions :: Int -> [[Int]]
compositions 0 = [[]]
compositions n = [i:is | i <- [1..n], is <- compositions (ni)]
quasiShuffles :: [Int] -> [Int] -> [[Int]]
quasiShuffles (x:xs) (y:ys) = map (x:) (quasiShuffles xs (y:ys)) ++
map (y:) (quasiShuffles (x:xs) ys) ++
map ((x+y):) (quasiShuffles xs ys)
quasiShuffles xs [] = [xs]
quasiShuffles [] ys = [ys]
newtype QSymM = QSymM [Int] deriving (Eq)
instance Ord QSymM where
compare (QSymM xs) (QSymM ys) = compare (length xs, xs) (length ys, ys)
instance Show QSymM where
show (QSymM xs) = "M " ++ show xs
qsymM :: [Int] -> Vect Q QSymM
qsymM = return . QSymM
instance (Eq k, Num k) => Algebra k QSymM where
unit x = x *> return (QSymM [])
mult = linear mult'
where mult' (QSymM alpha, QSymM beta) = sum [return (QSymM gamma) | gamma <- quasiShuffles alpha beta]
instance (Eq k, Num k) => Coalgebra k QSymM where
counit = unwrap . linear counit' where counit' (QSymM alpha) = if null alpha then 1 else 0
comult = linear comult' where
comult' (QSymM gamma) = sum [return (QSymM alpha, QSymM beta) | (alpha,beta) <- deconcatenations gamma]
instance (Eq k, Num k) => Bialgebra k QSymM where {}
instance (Eq k, Num k) => HopfAlgebra k QSymM where
antipode = linear antipode' where
antipode' (QSymM alpha) = (1)^length alpha * sum [return (QSymM (reverse beta)) | beta <- coarsenings alpha]
coarsenings (x1:x2:xs) = coarsenings ((x1+x2):xs) ++ map (x1:) (coarsenings (x2:xs))
coarsenings xs = [xs]
refinements (x:xs) = [y++ys | y <- compositions x, ys <- refinements xs]
refinements [] = [[]]
newtype QSymF = QSymF [Int] deriving (Eq)
instance Ord QSymF where
compare (QSymF xs) (QSymF ys) = compare (length xs, xs) (length ys, ys)
instance Show QSymF where
show (QSymF xs) = "F " ++ show xs
qsymF :: [Int] -> Vect Q QSymF
qsymF = return . QSymF
toQSymF :: (Eq k, Num k) => Vect k QSymM -> Vect k QSymF
toQSymF = linear toQSymF'
where toQSymF' (QSymM alpha) = sumv [(1) ^ (length beta length alpha) *> return (QSymF beta) | beta <- refinements alpha]
toQSymM :: (Eq k, Num k) => Vect k QSymF -> Vect k QSymM
toQSymM = linear toQSymM'
where toQSymM' (QSymF alpha) = sumv [return (QSymM beta) | beta <- refinements alpha]
instance (Eq k, Num k) => Algebra k QSymF where
unit x = x *> return (QSymF [])
mult = toQSymF . mult . (toQSymM `tf` toQSymM)
instance (Eq k, Num k) => Coalgebra k QSymF where
counit = unwrap . linear counit' where counit' (QSymF xs) = if null xs then 1 else 0
comult = (toQSymF `tf` toQSymF) . comult . toQSymM
instance (Eq k, Num k) => Bialgebra k QSymF where {}
instance (Eq k, Num k) => HopfAlgebra k QSymF where
antipode = toQSymF . antipode . toQSymM
xvars n = [glexvar ("x" ++ show i) | i <- [1..n] ]
quasiSymM xs is = sum [product (zipWith (^) xs' is) | xs' <- combinationsOf r xs]
where r = length is
descendingTree [] = E
descendingTree [x] = T E x E
descendingTree xs = T l x r
where x = maximum xs
(ls,_:rs) = L.break (== x) xs
l = descendingTree ls
r = descendingTree rs
descendingTreeMap :: (Eq k, Num k) => Vect k SSymF -> Vect k (YSymF ())
descendingTreeMap = nf . fmap (YSymF . shape . descendingTree')
where descendingTree' (SSymF xs) = descendingTree xs
minPerm t = minPerm' (lrCountTree t)
where minPerm' E = []
minPerm' (T l (lc,rc) r) = minPerm' l ++ [lc+rc+1] ++ map (+lc) (minPerm' r)
maxPerm t = maxPerm' (lrCountTree t)
where maxPerm' E = []
maxPerm' (T l (lc,rc) r) = map (+rc) (maxPerm' l) ++ [lc+rc+1] ++ maxPerm' r
leftLeafComposition E = []
leftLeafComposition t = cuts $ tail $ leftLeafs t
where leftLeafs (T l x E) = leftLeafs l ++ [False]
leftLeafs (T l x r) = leftLeafs l ++ leftLeafs r
leftLeafs E = [True]
cuts bs = case break id bs of
(ls,r:rs) -> (length ls + 1) : cuts rs
(ls,[]) -> [length ls]
leftLeafComposition' (YSymF t) = QSymF (leftLeafComposition t)
leftLeafCompositionMap :: (Eq k, Num k) => Vect k (YSymF a) -> Vect k QSymF
leftLeafCompositionMap = nf . fmap leftLeafComposition'
descents [] = []
descents xs = map (+1) $ L.elemIndices True $ zipWith (>) xs (tail xs)
descentComposition [] = []
descentComposition xs = dc $ zipWith (>) xs (tail xs) ++ [False]
where dc bs = case break id bs of
(ls,r:rs) -> (length ls + 1) : dc rs
(ls,[]) -> [length ls]
descentMap :: (Eq k, Num k) => Vect k SSymF -> Vect k QSymF
descentMap = nf . fmap (\(SSymF xs) -> QSymF (descentComposition xs))
underComposition (QSymF ps) = foldr under (SSymF []) [SSymF [1..p] | p <- ps]
where under (SSymF xs) (SSymF ys) = let q = length ys
zs = map (+q) xs ++ ys
in SSymF zs
under E t = t
under (T l x r) t = T l x (under r t)
isUnderIrreducible (T l x E) = True
isUnderIrreducible _ = False
underDecomposition (T l x r) = T l x E : underDecomposition r
underDecomposition E = []
ysymmToSh = fmap ysymmToSh'
where ysymmToSh' (YSymM t) = Sh (underDecomposition t)