-- Copyright (c) 2012-2015, David Amos. All rights reserved.

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, NoMonomorphismRestriction, ScopedTypeVariables, DeriveFunctor #-}

-- |A module defining the following Combinatorial Hopf Algebras, together with coalgebra or Hopf algebra morphisms between them:
--
-- * Sh, the Shuffle Hopf algebra
--
-- * SSym, the Malvenuto-Reutnenauer Hopf algebra of permutations
--
-- * YSym, the (dual of the) Loday-Ronco Hopf algebra of binary trees
--
-- * QSym, the Hopf algebra of quasi-symmetric functions (having a basis indexed by compositions)
--
-- * Sym, the Hopf algebra of symmetric functions (having a basis indexed by integer partitions)
--
-- * NSym, the Hopf algebra of non-commutative symmetric functions
module Math.Combinatorics.CombinatorialHopfAlgebra where

-- Sources:

-- Structure of the Malvenuto-Reutenauer Hopf algebra of permutations
-- Marcelo Aguiar and Frank Sottile
-- http://www.math.tamu.edu/~sottile/research/pdf/SSym.pdf

-- Structure of the Loday-Ronco Hopf algebra of trees
-- Marcelo Aguiar and Frank Sottile
-- http://www.math.tamu.edu/~sottile/research/pdf/Loday.pdf

-- Hopf Structures on the Multiplihedra
-- Stefan Forcey, Aaron Lauve and Frank Sottile
-- http://www.math.tamu.edu/~sottile/research/pdf/MSym.pdf

-- Lie Algebras and Hopf Algebras
-- Michiel Hazewinkel, Nadiya Gubareni, V.V.Kirichenko

import Prelude hiding ( (*>) )

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.Algebra.Group.PermutationGroup
import Math.CommutativeAlgebra.Polynomial



class Graded b where
  grade :: b -> Int

instance Graded b => Graded (Dual b) where grade :: Dual b -> Int
grade (Dual b :: b
b) = b -> Int
forall b. Graded b => b -> Int
grade b
b


class (Eq k, Num k, Ord b, Graded b, HopfAlgebra k b) => CombinatorialHopfAlgebra k b where
    zeta :: Vect k b -> Vect k ()


-- Hazewinkel et al, p155.
-- Given a graded, connected Hopf algebra, we can calculate the antipode recursively.
-- (A connected Hopf algebra means that the counit is projection onto the grade 0 part.)
-- Then we can calculate the antipode using mult . (id `tf` antipode) . comult == unit . counit
gradedConnectedAntipode
  :: (Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
     Vect k b -> Vect k b
gradedConnectedAntipode :: Vect k b -> Vect k b
gradedConnectedAntipode = (b -> Vect k b) -> Vect k b -> Vect k b
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear b -> Vect k b
forall b k.
(Graded b, Num k, Ord b, Bialgebra k b, Eq k) =>
b -> Vect k b
antipode' where
    antipode' :: b -> Vect k b
antipode' b :: b
b = if b -> Int
forall b. Graded b => b -> Int
grade b
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                  then b -> Vect k b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
                  else (Vect k b -> Vect k b
forall k b. (Eq k, Num k) => Vect k b -> Vect k b
negatev (Vect k b -> Vect k b) -> (b -> Vect k b) -> b -> Vect k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k (Tensor b b) -> Vect k b
forall k b. Algebra k b => Vect k (Tensor b b) -> Vect k b
mult (Vect k (Tensor b b) -> Vect k b)
-> (b -> Vect k (Tensor b b)) -> b -> Vect k b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vect k b -> Vect k b
forall a. a -> a
id (Vect k b -> Vect k b)
-> (Vect k b -> Vect k b)
-> Vect k (Tensor b b)
-> Vect k (Tensor b b)
forall k a' b' a b.
(Eq k, Num k, Ord a', Ord b') =>
(Vect k a -> Vect k a')
-> (Vect k b -> Vect k b')
-> Vect k (Tensor a b)
-> Vect k (Tensor a' b')
`tf` Vect k b -> Vect k b
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode) (Vect k (Tensor b b) -> Vect k (Tensor b b))
-> (b -> Vect k (Tensor b b)) -> b -> Vect k (Tensor b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k (Tensor b b) -> Vect k (Tensor b b)
forall b k b. Graded b => Vect k (b, b) -> Vect k (b, b)
removeLeftGradeZero (Vect k (Tensor b b) -> Vect k (Tensor b b))
-> (b -> Vect k (Tensor b b)) -> b -> Vect k (Tensor b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k b -> Vect k (Tensor b b)
forall k b. Coalgebra k b => Vect k b -> Vect k (Tensor b b)
comult (Vect k b -> Vect k (Tensor b b))
-> (b -> Vect k b) -> b -> Vect k (Tensor b b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Vect k b
forall (m :: * -> *) a. Monad m => a -> m a
return) b
b
    -- removeLeftGradeZero :: Graded b => Vect k (b,b) -> Vect k (b,b)
    removeLeftGradeZero :: Vect k (b, b) -> Vect k (b, b)
removeLeftGradeZero (V ts :: [((b, b), k)]
ts) = [((b, b), k)] -> Vect k (b, b)
forall k b. [(b, k)] -> Vect k b
V ([((b, b), k)] -> Vect k (b, b)) -> [((b, b), k)] -> Vect k (b, b)
forall a b. (a -> b) -> a -> b
$ (((b, b), k) -> Bool) -> [((b, b), k)] -> [((b, b), k)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((l :: b
l,r :: b
r),_) -> b -> Int
forall b. Graded b => b -> Int
grade b
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) [((b, b), k)]
ts



-- SHUFFLE ALGEBRA
-- This is just the tensor algebra, but with shuffle product (and deconcatenation coproduct)

-- |A basis for the shuffle algebra. As a vector space, the shuffle algebra is identical to the tensor algebra.
-- However, we consider a different algebra structure, based on the shuffle product. Together with the
-- deconcatenation coproduct, this leads to a Hopf algebra structure.
newtype Shuffle a = Sh [a] deriving (Shuffle a -> Shuffle a -> Bool
(Shuffle a -> Shuffle a -> Bool)
-> (Shuffle a -> Shuffle a -> Bool) -> Eq (Shuffle a)
forall a. Eq a => Shuffle a -> Shuffle a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Shuffle a -> Shuffle a -> Bool
$c/= :: forall a. Eq a => Shuffle a -> Shuffle a -> Bool
== :: Shuffle a -> Shuffle a -> Bool
$c== :: forall a. Eq a => Shuffle a -> Shuffle a -> Bool
Eq,Eq (Shuffle a)
Eq (Shuffle a) =>
(Shuffle a -> Shuffle a -> Ordering)
-> (Shuffle a -> Shuffle a -> Bool)
-> (Shuffle a -> Shuffle a -> Bool)
-> (Shuffle a -> Shuffle a -> Bool)
-> (Shuffle a -> Shuffle a -> Bool)
-> (Shuffle a -> Shuffle a -> Shuffle a)
-> (Shuffle a -> Shuffle a -> Shuffle a)
-> Ord (Shuffle a)
Shuffle a -> Shuffle a -> Bool
Shuffle a -> Shuffle a -> Ordering
Shuffle a -> Shuffle a -> Shuffle a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Shuffle a)
forall a. Ord a => Shuffle a -> Shuffle a -> Bool
forall a. Ord a => Shuffle a -> Shuffle a -> Ordering
forall a. Ord a => Shuffle a -> Shuffle a -> Shuffle a
min :: Shuffle a -> Shuffle a -> Shuffle a
$cmin :: forall a. Ord a => Shuffle a -> Shuffle a -> Shuffle a
max :: Shuffle a -> Shuffle a -> Shuffle a
$cmax :: forall a. Ord a => Shuffle a -> Shuffle a -> Shuffle a
>= :: Shuffle a -> Shuffle a -> Bool
$c>= :: forall a. Ord a => Shuffle a -> Shuffle a -> Bool
> :: Shuffle a -> Shuffle a -> Bool
$c> :: forall a. Ord a => Shuffle a -> Shuffle a -> Bool
<= :: Shuffle a -> Shuffle a -> Bool
$c<= :: forall a. Ord a => Shuffle a -> Shuffle a -> Bool
< :: Shuffle a -> Shuffle a -> Bool
$c< :: forall a. Ord a => Shuffle a -> Shuffle a -> Bool
compare :: Shuffle a -> Shuffle a -> Ordering
$ccompare :: forall a. Ord a => Shuffle a -> Shuffle a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Shuffle a)
Ord,Int -> Shuffle a -> ShowS
[Shuffle a] -> ShowS
Shuffle a -> String
(Int -> Shuffle a -> ShowS)
-> (Shuffle a -> String)
-> ([Shuffle a] -> ShowS)
-> Show (Shuffle a)
forall a. Show a => Int -> Shuffle a -> ShowS
forall a. Show a => [Shuffle a] -> ShowS
forall a. Show a => Shuffle a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Shuffle a] -> ShowS
$cshowList :: forall a. Show a => [Shuffle a] -> ShowS
show :: Shuffle a -> String
$cshow :: forall a. Show a => Shuffle a -> String
showsPrec :: Int -> Shuffle a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Shuffle a -> ShowS
Show)

instance Graded (Shuffle a) where grade :: Shuffle a -> Int
grade (Sh xs :: [a]
xs) = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

-- |Construct a basis element of the shuffle algebra
sh :: [a] -> Vect Q (Shuffle a)
sh :: [a] -> Vect Q (Shuffle a)
sh = Shuffle a -> Vect Q (Shuffle a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Shuffle a -> Vect Q (Shuffle a))
-> ([a] -> Shuffle a) -> [a] -> Vect Q (Shuffle a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh

shuffles :: [a] -> [a] -> [[a]]
shuffles (x :: a
x:xs :: [a]
xs) (y :: a
y:ys :: [a]
ys) = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a] -> [[a]]
shuffles [a]
xs (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a] -> [[a]]
shuffles (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [a]
ys)
shuffles xs :: [a]
xs [] = [[a]
xs]
shuffles [] ys :: [a]
ys = [[a]
ys]

instance (Eq k, Num k, Ord a) => Algebra k (Shuffle a) where
    unit :: k -> Vect k (Shuffle a)
unit x :: k
x = k
x k -> Vect k (Shuffle a) -> Vect k (Shuffle a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Shuffle a -> Vect k (Shuffle a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh [])
    mult :: Vect k (Tensor (Shuffle a) (Shuffle a)) -> Vect k (Shuffle a)
mult = (Tensor (Shuffle a) (Shuffle a) -> Vect k (Shuffle a))
-> Vect k (Tensor (Shuffle a) (Shuffle a)) -> Vect k (Shuffle a)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor (Shuffle a) (Shuffle a) -> Vect k (Shuffle a)
forall k a.
(Num k, Ord a, Eq k) =>
(Shuffle a, Shuffle a) -> Vect k (Shuffle a)
mult' where
        mult' :: (Shuffle a, Shuffle a) -> Vect k (Shuffle a)
mult' (Sh xs :: [a]
xs, Sh ys :: [a]
ys) = [Vect k (Shuffle a)] -> Vect k (Shuffle a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Shuffle a -> Vect k (Shuffle a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh [a]
zs) | [a]
zs <- [a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
shuffles [a]
xs [a]
ys]

deconcatenations :: [a] -> [([a], [a])]
deconcatenations xs :: [a]
xs = [[a]] -> [[a]] -> [([a], [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs)

instance (Eq k, Num k, Ord a) => Coalgebra k (Shuffle a) where
    counit :: Vect k (Shuffle a) -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k (Shuffle a) -> Vect k ()) -> Vect k (Shuffle a) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Shuffle a -> Vect k ()) -> Vect k (Shuffle a) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Shuffle a -> Vect k ()
forall p a. Num p => Shuffle a -> p
counit' where counit' :: Shuffle a -> p
counit' (Sh xs :: [a]
xs) = if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then 1 else 0
    comult :: Vect k (Shuffle a) -> Vect k (Tensor (Shuffle a) (Shuffle a))
comult = (Shuffle a -> Vect k (Tensor (Shuffle a) (Shuffle a)))
-> Vect k (Shuffle a) -> Vect k (Tensor (Shuffle a) (Shuffle a))
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Shuffle a -> Vect k (Tensor (Shuffle a) (Shuffle a))
forall k a.
(Num k, Ord a, Eq k) =>
Shuffle a -> Vect k (Shuffle a, Shuffle a)
comult' where
        comult' :: Shuffle a -> Vect k (Shuffle a, Shuffle a)
comult' (Sh xs :: [a]
xs) = [Vect k (Shuffle a, Shuffle a)] -> Vect k (Shuffle a, Shuffle a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(Shuffle a, Shuffle a) -> Vect k (Shuffle a, Shuffle a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh [a]
us, [a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh [a]
vs) | (us :: [a]
us, vs :: [a]
vs) <- [a] -> [([a], [a])]
forall a. [a] -> [([a], [a])]
deconcatenations [a]
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 :: Vect k (Shuffle a) -> Vect k (Shuffle a)
antipode = (Shuffle a -> Vect k (Shuffle a))
-> Vect k (Shuffle a) -> Vect k (Shuffle a)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear (\(Sh xs :: [a]
xs) -> (-1)k -> Int -> k
forall a b. (Num a, Integral b) => a -> b -> a
^[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs k -> Vect k (Shuffle a) -> Vect k (Shuffle a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Shuffle a -> Vect k (Shuffle a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Shuffle a
forall a. [a] -> Shuffle a
Sh ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)))


-- SSYM: PERMUTATIONS
-- (This is permutations considered as combinatorial objects rather than as algebraic objects)

-- Permutations with shifted shuffle product and flattened deconcatenation coproduct
-- This is the Malvenuto-Reutenauer Hopf algebra of permutations, SSym.
-- It is neither commutative nor co-commutative

-- ssymF xs is the fundamental basis F_xs (Aguiar and Sottile)

-- |The fundamental basis for the Malvenuto-Reutenauer Hopf algebra of permutations, SSym.
newtype SSymF = SSymF [Int] deriving (SSymF -> SSymF -> Bool
(SSymF -> SSymF -> Bool) -> (SSymF -> SSymF -> Bool) -> Eq SSymF
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SSymF -> SSymF -> Bool
$c/= :: SSymF -> SSymF -> Bool
== :: SSymF -> SSymF -> Bool
$c== :: SSymF -> SSymF -> Bool
Eq)

instance Ord SSymF where
    compare :: SSymF -> SSymF -> Ordering
compare (SSymF xs :: [Int]
xs) (SSymF ys :: [Int]
ys) = (Int, [Int]) -> (Int, [Int]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs, [Int]
xs) ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys, [Int]
ys)

instance Show SSymF where
    show :: SSymF -> String
show (SSymF xs :: [Int]
xs) = "F " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
xs

instance Graded SSymF where grade :: SSymF -> Int
grade (SSymF xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs

-- |Construct a fundamental basis element in SSym.
-- The list of ints must be a permutation of [1..n], eg [1,2], [3,4,2,1].
ssymF :: [Int] -> Vect Q SSymF
ssymF :: [Int] -> Vect Q SSymF
ssymF xs :: [Int]
xs | [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort [Int]
xs [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [1..Int
n] = SSymF -> Vect Q SSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF [Int]
xs)
         | Bool
otherwise = String -> Vect Q SSymF
forall a. HasCallStack => String -> a
error "Not a permutation of [1..n]"
         where n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs

-- so this is a candidate mult. It is associative and SSymF [] is obviously a left and right identity
-- (need quickcheck properties to prove that)
shiftedConcat :: SSymF -> SSymF -> SSymF
shiftedConcat (SSymF xs :: [Int]
xs) (SSymF ys :: [Int]
ys) = let k :: Int
k = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs in [Int] -> SSymF
SSymF ([Int]
xs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k) [Int]
ys)

prop_Associative :: (a -> a -> a) -> (a, a, a) -> Bool
prop_Associative f :: a -> a -> a
f (x :: a
x,y :: a
y,z :: a
z) = a -> a -> a
f a
x (a -> a -> a
f a
y a
z) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a -> a
f (a -> a -> a
f a
x a
y) a
z

-- > quickCheck (prop_Associative shiftedConcat)
-- +++ OK, passed 100 tests.


instance (Eq k, Num k) => Algebra k SSymF where
    unit :: k -> Vect k SSymF
unit x :: k
x = k
x k -> Vect k SSymF -> Vect k SSymF
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SSymF -> Vect k SSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF [])
    mult :: Vect k (Tensor SSymF SSymF) -> Vect k SSymF
mult = (Tensor SSymF SSymF -> Vect k SSymF)
-> Vect k (Tensor SSymF SSymF) -> Vect k SSymF
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor SSymF SSymF -> Vect k SSymF
forall k. (Eq k, Num k) => Tensor SSymF SSymF -> Vect k SSymF
mult' where
        mult' :: Tensor SSymF SSymF -> Vect k SSymF
mult' (SSymF xs :: [Int]
xs, SSymF ys :: [Int]
ys) =
            let k :: Int
k = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs
            in [Vect k SSymF] -> Vect k SSymF
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [SSymF -> Vect k SSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF [Int]
zs) | [Int]
zs <- [Int] -> [Int] -> [[Int]]
forall a. [a] -> [a] -> [[a]]
shuffles [Int]
xs ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k) [Int]
ys)]


-- standard permutation, also called flattening, eg [6,2,5] -> [3,1,2]
flatten :: [a] -> [a]
flatten xs :: [a]
xs = let mapping :: [(a, b)]
mapping = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([a] -> [a]
forall a. Ord a => [a] -> [a]
L.sort [a]
xs) [1..]
        in [a
forall a. (Num a, Enum a) => a
y | a
x <- [a]
xs, let Just y :: a
y = a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
x [(a, a)]
forall b. (Num b, Enum b) => [(a, b)]
mapping] 

instance (Eq k, Num k) => Coalgebra k SSymF where
    counit :: Vect k SSymF -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k SSymF -> Vect k ()) -> Vect k SSymF -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SSymF -> Vect k ()) -> Vect k SSymF -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymF -> Vect k ()
forall p. Num p => SSymF -> p
counit' where counit' :: SSymF -> p
counit' (SSymF xs :: [Int]
xs) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs then 1 else 0
    comult :: Vect k SSymF -> Vect k (Tensor SSymF SSymF)
comult = (SSymF -> Vect k (Tensor SSymF SSymF))
-> Vect k SSymF -> Vect k (Tensor SSymF SSymF)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymF -> Vect k (Tensor SSymF SSymF)
forall k. (Eq k, Num k) => SSymF -> Vect k (Tensor SSymF SSymF)
comult'
        where comult' :: SSymF -> Vect k (Tensor SSymF SSymF)
comult' (SSymF xs :: [Int]
xs) = [Vect k (Tensor SSymF SSymF)] -> Vect k (Tensor SSymF SSymF)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor SSymF SSymF -> Vect k (Tensor SSymF SSymF)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF ([Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
st [Int]
us), [Int] -> SSymF
SSymF ([Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
st [Int]
vs)) | (us :: [Int]
us, vs :: [Int]
vs) <- [Int] -> [([Int], [Int])]
forall a. [a] -> [([a], [a])]
deconcatenations [Int]
xs]
              st :: [a] -> [a]
st = [a] -> [a]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten

instance (Eq k, Num k) => Bialgebra k SSymF where {}

instance (Eq k, Num k) => HopfAlgebra k SSymF where
    antipode :: Vect k SSymF -> Vect k SSymF
antipode = Vect k SSymF -> Vect k SSymF
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    {-
    antipode = linear antipode' where
        antipode' (SSymF []) = return (SSymF [])
        antipode' x@(SSymF xs) = (negatev . mult . (id `tf` antipode) . removeTerm (SSymF [],x) . comult . return) x
        -- This expression for antipode is derived from mult . (id `tf` antipode) . comult == unit . counit
        -- It's possible because this is a graded, connected Hopf algebra. (connected means the counit is projection onto the grade 0 part)
    -}
-- It would be nicer to have an explicit expression for antipode.
{-
instance (Eq k, Num k) => HopfAlgebra k SSymF where
    antipode = linear antipode'
        where antipode' (SSymF v) = sumv [lambda v w *> return (SSymF w) | w <- L.permutations v]
              lambda v w = length [s | s <- powerset [1..n-1],  odd (length s), descentSet (w^-1 * v_s) `isSubset` s]
                         - length [s | s <- powerset [1..n-1],  even (length s), descentSet (w^-1 * v_s) `isSubset` s]
-}

instance HasInverses SSymF where
    inverse :: SSymF -> SSymF
inverse (SSymF xs :: [Int]
xs) = [Int] -> SSymF
SSymF ([Int] -> SSymF) -> [Int] -> SSymF
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
L.sort ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(s :: Int
s,t :: Int
t)->(Int
t,Int
s)) ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [Int]
xs

-- Hazewinkel p267
-- |A pairing showing that SSym is self-adjoint
instance (Eq k, Num k) => HasPairing k SSymF SSymF where
    pairing :: Vect k (Tensor SSymF SSymF) -> Vect k ()
pairing = (Tensor SSymF SSymF -> Vect k ())
-> Vect k (Tensor SSymF SSymF) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor SSymF SSymF -> Vect k ()
forall a p. (Eq a, Num p, HasInverses a) => (a, a) -> p
pairing' where
        pairing' :: (a, a) -> p
pairing' (x :: a
x,y :: a
y) = a -> a -> p
forall a p. (Eq a, Num p) => a -> a -> p
delta a
x (a -> a
forall a. HasInverses a => a -> a
inverse a
y)
-- Not entirely clear to me why this works
-- The pairing is *not* positive definite (Hazewinkel p267)
-- eg (\x -> pairing' x x >= 0) (ssymF [1,3,2] + ssymF [2,3,1] - ssymF [3,1,2]) == False


-- |An alternative \"monomial\" basis for the Malvenuto-Reutenauer Hopf algebra of permutations, SSym.
-- This basis is related to the fundamental basis by Mobius inversion in the poset of permutations with the weak order.
newtype SSymM = SSymM [Int] deriving (SSymM -> SSymM -> Bool
(SSymM -> SSymM -> Bool) -> (SSymM -> SSymM -> Bool) -> Eq SSymM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SSymM -> SSymM -> Bool
$c/= :: SSymM -> SSymM -> Bool
== :: SSymM -> SSymM -> Bool
$c== :: SSymM -> SSymM -> Bool
Eq)

instance Ord SSymM where
    compare :: SSymM -> SSymM -> Ordering
compare (SSymM xs :: [Int]
xs) (SSymM ys :: [Int]
ys) = (Int, [Int]) -> (Int, [Int]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs, [Int]
xs) ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys, [Int]
ys)

instance Show SSymM where
    show :: SSymM -> String
show (SSymM xs :: [Int]
xs) = "M " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
xs

instance Graded SSymM where grade :: SSymM -> Int
grade (SSymM xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs

-- |Construct a monomial basis element in SSym.
-- The list of ints must be a permutation of [1..n], eg [1,2], [3,4,2,1].
ssymM :: [Int] -> Vect Q SSymM
ssymM :: [Int] -> Vect Q SSymM
ssymM xs :: [Int]
xs | [Int] -> [Int]
forall a. Ord a => [a] -> [a]
L.sort [Int]
xs [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [1..Int
n] = SSymM -> Vect Q SSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymM
SSymM [Int]
xs)
         | Bool
otherwise = String -> Vect Q SSymM
forall a. HasCallStack => String -> a
error "Not a permutation of [1..n]"
         where n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs

inversions :: [a] -> [(b, b)]
inversions xs :: [a]
xs = let ixs :: [(a, a)]
ixs = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [1..] [a]
xs
                in [(b
i,b
j) | ((i :: b
i,xi :: a
xi),(j :: b
j,xj :: a
xj)) <- [(b, a)] -> [((b, a), (b, a))]
forall t. [t] -> [(t, t)]
pairs [(b, a)]
forall a. (Num a, Enum a) => [(a, a)]
ixs, a
xi a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
xj]

-- should really check that xs and ys have the same length, and perhaps insist also on same type
weakOrder :: [a] -> [a] -> Bool
weakOrder xs :: [a]
xs ys :: [a]
ys = [a] -> [(Integer, Integer)]
forall b a. (Num b, Enum b, Ord a) => [a] -> [(b, b)]
inversions [a]
xs [(Integer, Integer)] -> [(Integer, Integer)] -> Bool
forall a. Ord a => [a] -> [a] -> Bool
`isSubsetAsc` [a] -> [(Integer, Integer)]
forall b a. (Num b, Enum b, Ord a) => [a] -> [(b, b)]
inversions [a]
ys

mu :: ([t], t -> t -> Bool) -> t -> t -> p
mu (set :: [t]
set,po :: t -> t -> Bool
po) x :: t
x y :: t
y = t -> t -> p
forall p. Num p => t -> t -> p
mu' t
x t
y where
    mu' :: t -> t -> p
mu' x :: t
x y :: t
y | t
x t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
y    = 1
            | t -> t -> Bool
po t
x t
y    = p -> p
forall a. Num a => a -> a
negate (p -> p) -> p -> p
forall a b. (a -> b) -> a -> b
$ [p] -> p
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [t -> t -> p
mu' t
x t
z | t
z <- [t]
set, t -> t -> Bool
po t
x t
z, t -> t -> Bool
po t
z t
y, t
z t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/= t
y]
            | Bool
otherwise = 0

-- |Convert an element of SSym represented in the monomial basis to the fundamental basis
ssymMtoF :: (Eq k, Num k) => Vect k SSymM -> Vect k SSymF
ssymMtoF :: Vect k SSymM -> Vect k SSymF
ssymMtoF = (SSymM -> Vect k SSymF) -> Vect k SSymM -> Vect k SSymF
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymM -> Vect k SSymF
forall k. (Eq k, Num k) => SSymM -> Vect k SSymF
ssymMtoF' where
    ssymMtoF' :: SSymM -> Vect k SSymF
ssymMtoF' (SSymM u :: [Int]
u) = [Vect k SSymF] -> Vect k SSymF
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [([[Int]], [Int] -> [Int] -> Bool) -> [Int] -> [Int] -> k
forall p t. (Num p, Eq t) => ([t], t -> t -> Bool) -> t -> t -> p
mu ([[Int]]
set,[Int] -> [Int] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
po) [Int]
u [Int]
v k -> Vect k SSymF -> Vect k SSymF
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SSymF -> Vect k SSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF [Int]
v) | [Int]
v <- [[Int]]
set, [Int] -> [Int] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
po [Int]
u [Int]
v]
        where set :: [[Int]]
set = [Int] -> [[Int]]
forall a. [a] -> [[a]]
L.permutations [Int]
u
              po :: [a] -> [a] -> Bool
po = [a] -> [a] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
weakOrder

-- |Convert an element of SSym represented in the fundamental basis to the monomial basis
ssymFtoM :: (Eq k, Num k) => Vect k SSymF -> Vect k SSymM
ssymFtoM :: Vect k SSymF -> Vect k SSymM
ssymFtoM = (SSymF -> Vect k SSymM) -> Vect k SSymF -> Vect k SSymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymF -> Vect k SSymM
forall k. (Eq k, Num k) => SSymF -> Vect k SSymM
ssymFtoM' where
    ssymFtoM' :: SSymF -> Vect k SSymM
ssymFtoM' (SSymF u :: [Int]
u) = [Vect k SSymM] -> Vect k SSymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [SSymM -> Vect k SSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymM
SSymM [Int]
v) | [Int]
v <- [[Int]]
set, [Int] -> [Int] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
po [Int]
u [Int]
v]
        where set :: [[Int]]
set = [Int] -> [[Int]]
forall a. [a] -> [[a]]
L.permutations [Int]
u
              po :: [a] -> [a] -> Bool
po = [a] -> [a] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
weakOrder

-- (p,q)-shuffles: permutations of [1..p+q] having at most one descent, at position p
-- denoted S^{(p,q)} in Aguiar&Sottile
-- (Grassmannian permutations?)
-- pqShuffles p q = [u++v | u <- combinationsOf p [1..n], let v = [1..n] `diffAsc` u] where n = p+q

-- The inverse of a (p,q)-shuffle.
-- The special form of (p,q)-shuffles makes an O(n) algorithm possible
-- pqInverse :: Int -> Int -> [Int] -> [Int]
{-
-- incorrect
pqInverse p q xs = pqInverse' [1..p] [p+1..p+q] xs
    where pqInverse' (l:ls) (r:rs) (x:xs) =
              if x <= p then l : pqInverse' ls (r:rs) xs else r : pqInverse' (l:ls) rs xs
          pqInverse' ls rs _ = ls ++ rs -- one of them is null
-}
-- pqInverseShuffles p q = shuffles [1..p] [p+1..p+q]


instance (Eq k, Num k) => Algebra k SSymM where
    unit :: k -> Vect k SSymM
unit x :: k
x = k
x k -> Vect k SSymM -> Vect k SSymM
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SSymM -> Vect k SSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymM
SSymM [])
    mult :: Vect k (Tensor SSymM SSymM) -> Vect k SSymM
mult = Vect k SSymF -> Vect k SSymM
forall k. (Eq k, Num k) => Vect k SSymF -> Vect k SSymM
ssymFtoM (Vect k SSymF -> Vect k SSymM)
-> (Vect k (Tensor SSymM SSymM) -> Vect k SSymF)
-> Vect k (Tensor SSymM SSymM)
-> Vect k SSymM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k (Tensor SSymF SSymF) -> Vect k SSymF
forall k b. Algebra k b => Vect k (Tensor b b) -> Vect k b
mult (Vect k (Tensor SSymF SSymF) -> Vect k SSymF)
-> (Vect k (Tensor SSymM SSymM) -> Vect k (Tensor SSymF SSymF))
-> Vect k (Tensor SSymM SSymM)
-> Vect k SSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vect k SSymM -> Vect k SSymF
forall k. (Eq k, Num k) => Vect k SSymM -> Vect k SSymF
ssymMtoF (Vect k SSymM -> Vect k SSymF)
-> (Vect k SSymM -> Vect k SSymF)
-> Vect k (Tensor SSymM SSymM)
-> Vect k (Tensor SSymF SSymF)
forall k a' b' a b.
(Eq k, Num k, Ord a', Ord b') =>
(Vect k a -> Vect k a')
-> (Vect k b -> Vect k b')
-> Vect k (Tensor a b)
-> Vect k (Tensor a' b')
`tf` Vect k SSymM -> Vect k SSymF
forall k. (Eq k, Num k) => Vect k SSymM -> Vect k SSymF
ssymMtoF)

{-
mult2 = linear mult'
    where mult' (SSymM u, SSymM v) = sumv [alpha u v w *> return (SSymM w) | w <- L.permutations [1..p+q] ]
                                     where p = length u; q = length v

alpha u v w = length [z | z <- pqInverseShuffles p q, let uv = shiftedConcat u v,
                          uv * z `weakOrder` w, u and v are maximal, ie no transposition of adjacents in either also works]
    where p = length u
          q = length v
-- so we need to define (*) for permutations in row form
-}

instance (Eq k, Num k) => Coalgebra k SSymM where
    counit :: Vect k SSymM -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k SSymM -> Vect k ()) -> Vect k SSymM -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SSymM -> Vect k ()) -> Vect k SSymM -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymM -> Vect k ()
forall p. Num p => SSymM -> p
counit' where counit' :: SSymM -> p
counit' (SSymM xs :: [Int]
xs) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs then 1 else 0
    -- comult = (ssymFtoM `tf` ssymFtoM) . comult . ssymMtoF
    comult :: Vect k SSymM -> Vect k (Tensor SSymM SSymM)
comult = (SSymM -> Vect k (Tensor SSymM SSymM))
-> Vect k SSymM -> Vect k (Tensor SSymM SSymM)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SSymM -> Vect k (Tensor SSymM SSymM)
forall k. (Eq k, Num k) => SSymM -> Vect k (Tensor SSymM SSymM)
comult'
        where comult' :: SSymM -> Vect k (Tensor SSymM SSymM)
comult' (SSymM xs :: [Int]
xs) = [Vect k (Tensor SSymM SSymM)] -> Vect k (Tensor SSymM SSymM)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor SSymM SSymM -> Vect k (Tensor SSymM SSymM)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymM
SSymM ([Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten [Int]
ys), [Int] -> SSymM
SSymM ([Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten [Int]
zs))
                                        | (ys :: [Int]
ys,zs :: [Int]
zs) <- [Int] -> [([Int], [Int])]
forall a. [a] -> [([a], [a])]
deconcatenations [Int]
xs,
                                          [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (Int
infinityInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ys) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
zs)] -- ie deconcatenations at a global descent
              infinity :: Int
infinity = Int
forall a. Bounded a => a
maxBound :: Int

instance (Eq k, Num k) => Bialgebra k SSymM where {}

instance (Eq k, Num k) => HopfAlgebra k SSymM where
    antipode :: Vect k SSymM -> Vect k SSymM
antipode = Vect k SSymM -> Vect k SSymM
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    -- antipode = ssymFtoM . antipode . ssymMtoF


-- Hazewinkel p265
instance (Eq k, Num k) => Algebra k (Dual SSymF) where
    unit :: k -> Vect k (Dual SSymF)
unit x :: k
x = k
x k -> Vect k (Dual SSymF) -> Vect k (Dual SSymF)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> Dual SSymF -> Vect k (Dual SSymF)
forall (m :: * -> *) a. Monad m => a -> m a
return (SSymF -> Dual SSymF
forall b. b -> Dual b
Dual ([Int] -> SSymF
SSymF []))
    mult :: Vect k (Tensor (Dual SSymF) (Dual SSymF)) -> Vect k (Dual SSymF)
mult = (Tensor (Dual SSymF) (Dual SSymF) -> Vect k (Dual SSymF))
-> Vect k (Tensor (Dual SSymF) (Dual SSymF)) -> Vect k (Dual SSymF)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor (Dual SSymF) (Dual SSymF) -> Vect k (Dual SSymF)
forall k.
(Eq k, Num k) =>
Tensor (Dual SSymF) (Dual SSymF) -> Vect k (Dual SSymF)
mult' where
        mult' :: Tensor (Dual SSymF) (Dual SSymF) -> Vect k (Dual SSymF)
mult' (Dual (SSymF xs :: [Int]
xs), Dual (SSymF ys :: [Int]
ys)) =
            [Vect k (Dual SSymF)] -> Vect k (Dual SSymF)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(Dual SSymF -> Vect k (Dual SSymF)
forall (m :: * -> *) a. Monad m => a -> m a
return (Dual SSymF -> Vect k (Dual SSymF))
-> ([Int] -> Dual SSymF) -> [Int] -> Vect k (Dual SSymF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSymF -> Dual SSymF
forall b. b -> Dual b
Dual (SSymF -> Dual SSymF) -> ([Int] -> SSymF) -> [Int] -> Dual SSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> SSymF
SSymF) ([Int]
xs'' [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
ys'')
                 | [Int]
xs' <- Int -> [Int] -> [[Int]]
forall a. Int -> [a] -> [[a]]
combinationsOf Int
r [1..Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
s], let ys' :: [Int]
ys' = [Int] -> [Int] -> [Int]
forall a. Ord a => [a] -> [a] -> [a]
diffAsc [1..Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
s] [Int]
xs',
                   [Int]
xs'' <- [Int] -> [[Int]]
forall a. [a] -> [[a]]
L.permutations [Int]
xs', [Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten [Int]
xs'' [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
xs,
                   [Int]
ys'' <- [Int] -> [[Int]]
forall a. [a] -> [[a]]
L.permutations [Int]
ys', [Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten [Int]
ys'' [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
ys ]
            where r :: Int
r = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs; s :: Int
s = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys
-- In other words, mult x y is the sum of those z whose comult (in SSymF) has an (x,y) term
-- So the matrix for mult is the transpose of the matrix for comult in SSymF

instance (Eq k, Num k) => Coalgebra k (Dual SSymF) where
    counit :: Vect k (Dual SSymF) -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k (Dual SSymF) -> Vect k ()) -> Vect k (Dual SSymF) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dual SSymF -> Vect k ()) -> Vect k (Dual SSymF) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Dual SSymF -> Vect k ()
forall p. Num p => Dual SSymF -> p
counit' where counit' :: Dual SSymF -> p
counit' (Dual (SSymF xs :: [Int]
xs)) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs then 1 else 0
    comult :: Vect k (Dual SSymF) -> Vect k (Tensor (Dual SSymF) (Dual SSymF))
comult = (Dual SSymF -> Vect k (Tensor (Dual SSymF) (Dual SSymF)))
-> Vect k (Dual SSymF) -> Vect k (Tensor (Dual SSymF) (Dual SSymF))
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Dual SSymF -> Vect k (Tensor (Dual SSymF) (Dual SSymF))
forall k.
(Eq k, Num k) =>
Dual SSymF -> Vect k (Tensor (Dual SSymF) (Dual SSymF))
comult' where
        comult' :: Dual SSymF -> Vect k (Tensor (Dual SSymF) (Dual SSymF))
comult' (Dual (SSymF xs :: [Int]
xs)) =
            [Vect k (Tensor (Dual SSymF) (Dual SSymF))]
-> Vect k (Tensor (Dual SSymF) (Dual SSymF))
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor (Dual SSymF) (Dual SSymF)
-> Vect k (Tensor (Dual SSymF) (Dual SSymF))
forall (m :: * -> *) a. Monad m => a -> m a
return (SSymF -> Dual SSymF
forall b. b -> Dual b
Dual ([Int] -> SSymF
SSymF [Int]
ys), SSymF -> Dual SSymF
forall b. b -> Dual b
Dual ([Int] -> SSymF
SSymF ([Int] -> [Int]
forall a a. (Num a, Enum a, Ord a) => [a] -> [a]
flatten [Int]
zs))) | Int
i <- [0..Int
n], let (ys :: [Int]
ys,zs :: [Int]
zs) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
i) [Int]
xs ]
            where n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs
-- In other words, comult x is the sum of those (y,z) whose mult (in SSymF) has a z term
-- So the matrix for comult is the transpose of the matrix for mult in SSymF

instance (Eq k, Num k) => Bialgebra k (Dual SSymF) where {}

instance (Eq k, Num k) => HopfAlgebra k (Dual SSymF) where
    antipode :: Vect k (Dual SSymF) -> Vect k (Dual SSymF)
antipode = Vect k (Dual SSymF) -> Vect k (Dual SSymF)
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    {-
    antipode = linear antipode' where
        antipode' (Dual (SSymF [])) = return (Dual (SSymF []))
        antipode' x@(Dual (SSymF xs)) =
            (negatev . mult . (id `tf` antipode) . removeTerm (Dual (SSymF []),x) . comult . return) x
    -}

-- This pairing is positive definite (Hazewinkel p267)
instance (Eq k, Num k) => HasPairing k SSymF (Dual SSymF) where
    pairing :: Vect k (Tensor SSymF (Dual SSymF)) -> Vect k ()
pairing = (Tensor SSymF (Dual SSymF) -> Vect k ())
-> Vect k (Tensor SSymF (Dual SSymF)) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor SSymF (Dual SSymF) -> Vect k ()
forall a p. (Eq a, Num p) => (a, Dual a) -> p
pairing' where
        pairing' :: (a, Dual a) -> p
pairing' (x :: a
x, Dual y :: a
y) = a -> a -> p
forall a p. (Eq a, Num p) => a -> a -> p
delta a
x a
y

-- |The isomorphism from SSym to its dual that takes a permutation in the fundamental basis to its inverse in the dual basis
ssymFtoDual :: (Eq k, Num k) => Vect k SSymF -> Vect k (Dual SSymF)
ssymFtoDual :: Vect k SSymF -> Vect k (Dual SSymF)
ssymFtoDual = Vect k (Dual SSymF) -> Vect k (Dual SSymF)
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k (Dual SSymF) -> Vect k (Dual SSymF))
-> (Vect k SSymF -> Vect k (Dual SSymF))
-> Vect k SSymF
-> Vect k (Dual SSymF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SSymF -> Dual SSymF) -> Vect k SSymF -> Vect k (Dual SSymF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SSymF -> Dual SSymF
forall b. b -> Dual b
Dual (SSymF -> Dual SSymF) -> (SSymF -> SSymF) -> SSymF -> Dual SSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSymF -> SSymF
forall a. HasInverses a => a -> a
inverse)
-- This is theta on Hazewinkel p266 (though later he also uses theta for the inverse of this map)


-- YSYM: PLANAR BINARY TREES
-- These are really rooted planar binary trees.
-- It's because they're planar that we can distinguish left and right child branches.
-- (Non-planar would be if we considered trees where left and right children are swapped relative to one another as the same tree)
-- It is neither commutative nor co-commutative

-- |A type for (rooted) planar binary trees. The basis elements of the Loday-Ronco Hopf algebra are indexed by these.
--
-- Although the trees are labelled, we're really only interested in the shapes of the trees, and hence in the type PBT ().
-- The Algebra, Coalgebra and HopfAlgebra instances all ignore the labels.
-- However, it is convenient to allow labels, as they can be useful for seeing what is going on, and they also make it possible
-- to define various ways to create trees from lists of labels.
data PBT a = T (PBT a) a (PBT a) | E deriving (PBT a -> PBT a -> Bool
(PBT a -> PBT a -> Bool) -> (PBT a -> PBT a -> Bool) -> Eq (PBT a)
forall a. Eq a => PBT a -> PBT a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PBT a -> PBT a -> Bool
$c/= :: forall a. Eq a => PBT a -> PBT a -> Bool
== :: PBT a -> PBT a -> Bool
$c== :: forall a. Eq a => PBT a -> PBT a -> Bool
Eq, Int -> PBT a -> ShowS
[PBT a] -> ShowS
PBT a -> String
(Int -> PBT a -> ShowS)
-> (PBT a -> String) -> ([PBT a] -> ShowS) -> Show (PBT a)
forall a. Show a => Int -> PBT a -> ShowS
forall a. Show a => [PBT a] -> ShowS
forall a. Show a => PBT a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PBT a] -> ShowS
$cshowList :: forall a. Show a => [PBT a] -> ShowS
show :: PBT a -> String
$cshow :: forall a. Show a => PBT a -> String
showsPrec :: Int -> PBT a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PBT a -> ShowS
Show, a -> PBT b -> PBT a
(a -> b) -> PBT a -> PBT b
(forall a b. (a -> b) -> PBT a -> PBT b)
-> (forall a b. a -> PBT b -> PBT a) -> Functor PBT
forall a b. a -> PBT b -> PBT a
forall a b. (a -> b) -> PBT a -> PBT b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PBT b -> PBT a
$c<$ :: forall a b. a -> PBT b -> PBT a
fmap :: (a -> b) -> PBT a -> PBT b
$cfmap :: forall a b. (a -> b) -> PBT a -> PBT b
Functor)

instance Ord a => Ord (PBT a) where
    compare :: PBT a -> PBT a -> Ordering
compare u :: PBT a
u v :: PBT a
v = ([Integer], [a]) -> ([Integer], [a]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (PBT a -> [Integer]
forall a a. Num a => PBT a -> [a]
shapeSignature PBT a
u, PBT a -> [a]
forall a. PBT a -> [a]
prefix PBT a
u) (PBT a -> [Integer]
forall a a. Num a => PBT a -> [a]
shapeSignature PBT a
v, PBT a -> [a]
forall a. PBT a -> [a]
prefix PBT a
v)

-- |The fundamental basis for (the dual of) the Loday-Ronco Hopf algebra of binary trees, YSym.
newtype YSymF a = YSymF (PBT a) deriving (YSymF a -> YSymF a -> Bool
(YSymF a -> YSymF a -> Bool)
-> (YSymF a -> YSymF a -> Bool) -> Eq (YSymF a)
forall a. Eq a => YSymF a -> YSymF a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YSymF a -> YSymF a -> Bool
$c/= :: forall a. Eq a => YSymF a -> YSymF a -> Bool
== :: YSymF a -> YSymF a -> Bool
$c== :: forall a. Eq a => YSymF a -> YSymF a -> Bool
Eq, Eq (YSymF a)
Eq (YSymF a) =>
(YSymF a -> YSymF a -> Ordering)
-> (YSymF a -> YSymF a -> Bool)
-> (YSymF a -> YSymF a -> Bool)
-> (YSymF a -> YSymF a -> Bool)
-> (YSymF a -> YSymF a -> Bool)
-> (YSymF a -> YSymF a -> YSymF a)
-> (YSymF a -> YSymF a -> YSymF a)
-> Ord (YSymF a)
YSymF a -> YSymF a -> Bool
YSymF a -> YSymF a -> Ordering
YSymF a -> YSymF a -> YSymF a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (YSymF a)
forall a. Ord a => YSymF a -> YSymF a -> Bool
forall a. Ord a => YSymF a -> YSymF a -> Ordering
forall a. Ord a => YSymF a -> YSymF a -> YSymF a
min :: YSymF a -> YSymF a -> YSymF a
$cmin :: forall a. Ord a => YSymF a -> YSymF a -> YSymF a
max :: YSymF a -> YSymF a -> YSymF a
$cmax :: forall a. Ord a => YSymF a -> YSymF a -> YSymF a
>= :: YSymF a -> YSymF a -> Bool
$c>= :: forall a. Ord a => YSymF a -> YSymF a -> Bool
> :: YSymF a -> YSymF a -> Bool
$c> :: forall a. Ord a => YSymF a -> YSymF a -> Bool
<= :: YSymF a -> YSymF a -> Bool
$c<= :: forall a. Ord a => YSymF a -> YSymF a -> Bool
< :: YSymF a -> YSymF a -> Bool
$c< :: forall a. Ord a => YSymF a -> YSymF a -> Bool
compare :: YSymF a -> YSymF a -> Ordering
$ccompare :: forall a. Ord a => YSymF a -> YSymF a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (YSymF a)
Ord, a -> YSymF b -> YSymF a
(a -> b) -> YSymF a -> YSymF b
(forall a b. (a -> b) -> YSymF a -> YSymF b)
-> (forall a b. a -> YSymF b -> YSymF a) -> Functor YSymF
forall a b. a -> YSymF b -> YSymF a
forall a b. (a -> b) -> YSymF a -> YSymF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> YSymF b -> YSymF a
$c<$ :: forall a b. a -> YSymF b -> YSymF a
fmap :: (a -> b) -> YSymF a -> YSymF b
$cfmap :: forall a b. (a -> b) -> YSymF a -> YSymF b
Functor)

instance Show a => Show (YSymF a) where
    show :: YSymF a -> String
show (YSymF t :: PBT a
t) = "F(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PBT a -> String
forall a. Show a => a -> String
show PBT a
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

instance Graded (YSymF a) where grade :: YSymF a -> Int
grade (YSymF t :: PBT a
t) = PBT a -> Int
forall p a. Num p => PBT a -> p
nodecount PBT a
t

-- |Construct the element of YSym in the fundamental basis indexed by the given tree
ysymF :: PBT a -> Vect Q (YSymF a)
ysymF :: PBT a -> Vect Q (YSymF a)
ysymF t :: PBT a
t = YSymF a -> Vect Q (YSymF a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT a -> YSymF a
forall a. PBT a -> YSymF a
YSymF PBT a
t)

{-
depth (T l x r) = 1 + max (depth l) (depth r)
depth E = 0
-}
nodecount :: PBT a -> p
nodecount (T l :: PBT a
l x :: a
x r :: PBT a
r) = 1 p -> p -> p
forall a. Num a => a -> a -> a
+ PBT a -> p
nodecount PBT a
l p -> p -> p
forall a. Num a => a -> a -> a
+ PBT a -> p
nodecount PBT a
r
nodecount E = 0

-- in fact leafcount t = 1 + nodecount t (easiest to see with a picture)
leafcount :: PBT a -> p
leafcount (T l :: PBT a
l x :: a
x r :: PBT a
r) = PBT a -> p
leafcount PBT a
l p -> p -> p
forall a. Num a => a -> a -> a
+ PBT a -> p
leafcount PBT a
r
leafcount E = 1

prefix :: PBT a -> [a]
prefix E = []
prefix (T l :: PBT a
l x :: a
x r :: PBT a
r) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: PBT a -> [a]
prefix PBT a
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ PBT a -> [a]
prefix PBT a
r

-- The shape signature uniquely identifies the shape of a tree.
-- Trees with distinct shapes have distinct signatures.
-- In addition, if sorting on shapeSignature, smaller trees sort before larger trees,
-- and leftward leaning trees sort before rightward leaning trees
shapeSignature :: PBT a -> [a]
shapeSignature t :: PBT a
t = PBT a -> [a]
forall a. Num a => PBT a -> [a]
shapeSignature' (PBT a -> PBT a
forall a a. Num a => PBT a -> PBT a
nodeCountTree PBT a
t)
    where shapeSignature' :: PBT a -> [a]
shapeSignature' E = [0] -- not [], otherwise we can't distinguish T (T E () E) () E from T E () (T E () E)
          shapeSignature' (T l :: PBT a
l x :: a
x r :: PBT a
r) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: PBT a -> [a]
shapeSignature' PBT a
r [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ PBT a -> [a]
shapeSignature' PBT a
l

nodeCountTree :: PBT a -> PBT a
nodeCountTree E = PBT a
forall a. PBT a
E
nodeCountTree (T l :: PBT a
l _ r :: PBT a
r) = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l' a
n PBT a
r'
    where l' :: PBT a
l' = PBT a -> PBT a
nodeCountTree PBT a
l
          r' :: PBT a
r' = PBT a -> PBT a
nodeCountTree PBT a
r
          n :: a
n = 1 a -> a -> a
forall a. Num a => a -> a -> a
+ (case PBT a
l' of E -> 0; T _ lc _ -> a
lc) a -> a -> a
forall a. Num a => a -> a -> a
+ (case PBT a
r' of E -> 0; T _ rc _ -> a
rc)

leafCountTree :: PBT a -> PBT a
leafCountTree E = PBT a
forall a. PBT a
E
leafCountTree (T l :: PBT a
l _ r :: PBT a
r) = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l' a
n PBT a
r'
    where l' :: PBT a
l' = PBT a -> PBT a
leafCountTree PBT a
l
          r' :: PBT a
r' = PBT a -> PBT a
leafCountTree PBT a
r
          n :: a
n = (case PBT a
l' of E -> 1; T _ lc _ -> a
lc) a -> a -> a
forall a. Num a => a -> a -> a
+ (case PBT a
r' of E -> 1; T _ rc _ -> a
rc)

-- A tree that counts nodes in left and right subtrees
lrCountTree :: PBT a -> PBT (b, b)
lrCountTree E = PBT (b, b)
forall a. PBT a
E
lrCountTree (T l :: PBT a
l _ r :: PBT a
r) = PBT (b, b) -> (b, b) -> PBT (b, b) -> PBT (b, b)
forall a. PBT a -> a -> PBT a -> PBT a
T PBT (b, b)
l' (b
lc,b
rc) PBT (b, b)
r'
    where l' :: PBT (b, b)
l' = PBT a -> PBT (b, b)
lrCountTree PBT a
l
          r' :: PBT (b, b)
r' = PBT a -> PBT (b, b)
lrCountTree PBT a
r
          lc :: b
lc = case PBT (b, b)
l' of E -> 0; T _ (llc,lrc) _ -> 1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
llc b -> b -> b
forall a. Num a => a -> a -> a
+ b
lrc
          rc :: b
rc = case PBT (b, b)
r' of E -> 0; T _ (rlc,rrc) _ -> 1 b -> b -> b
forall a. Num a => a -> a -> a
+ b
rlc b -> b -> b
forall a. Num a => a -> a -> a
+ b
rrc

shape :: PBT a -> PBT ()
shape :: PBT a -> PBT ()
shape t :: PBT a
t = (a -> ()) -> PBT a -> PBT ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\_ -> ()) PBT a
t

-- label the nodes of a tree in infix order while preserving its shape
numbered :: PBT a -> PBT a
numbered t :: PBT a
t = a -> PBT a -> PBT a
forall a a. Num a => a -> PBT a -> PBT a
numbered' 1 PBT a
t
    where numbered' :: a -> PBT a -> PBT a
numbered' _ E = PBT a
forall a. PBT a
E
          numbered' i :: a
i (T l :: PBT a
l x :: a
x r :: PBT a
r) = let k :: p
k = PBT a -> p
forall p a. Num p => PBT a -> p
nodecount PBT a
l in PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T (a -> PBT a -> PBT a
numbered' a
i PBT a
l) (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
forall p. Num p => p
k) (a -> PBT a -> PBT a
numbered' (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
forall p. Num p => p
ka -> a -> a
forall a. Num a => a -> a -> a
+1) PBT a
r)
-- could also pair the numbers with the input labels


splits :: PBT a -> [(PBT a, PBT a)]
splits E = [(PBT a
forall a. PBT a
E,PBT a
forall a. PBT a
E)]
splits (T l :: PBT a
l x :: a
x r :: PBT a
r) = [(PBT a
u, PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
v a
x PBT a
r) | (u :: PBT a
u,v :: PBT a
v) <- PBT a -> [(PBT a, PBT a)]
splits PBT a
l] [(PBT a, PBT a)] -> [(PBT a, PBT a)] -> [(PBT a, PBT a)]
forall a. [a] -> [a] -> [a]
++ [(PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l a
x PBT a
u, PBT a
v) | (u :: PBT a
u,v :: PBT a
v) <- PBT a -> [(PBT a, PBT a)]
splits PBT a
r]

instance (Eq k, Num k, Ord a) => Coalgebra k (YSymF a) where
    counit :: Vect k (YSymF a) -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k (YSymF a) -> Vect k ()) -> Vect k (YSymF a) -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YSymF a -> Vect k ()) -> Vect k (YSymF a) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymF a -> Vect k ()
forall p a. Num p => YSymF a -> p
counit' where counit' :: YSymF a -> p
counit' (YSymF E) = 1; counit' (YSymF (T _ _ _)) = 0
    comult :: Vect k (YSymF a) -> Vect k (Tensor (YSymF a) (YSymF a))
comult = (YSymF a -> Vect k (Tensor (YSymF a) (YSymF a)))
-> Vect k (YSymF a) -> Vect k (Tensor (YSymF a) (YSymF a))
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymF a -> Vect k (Tensor (YSymF a) (YSymF a))
forall k a.
(Num k, Ord a, Eq k) =>
YSymF a -> Vect k (YSymF a, YSymF a)
comult'
        where comult' :: YSymF a -> Vect k (YSymF a, YSymF a)
comult' (YSymF t :: PBT a
t) = [Vect k (YSymF a, YSymF a)] -> Vect k (YSymF a, YSymF a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(YSymF a, YSymF a) -> Vect k (YSymF a, YSymF a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT a -> YSymF a
forall a. PBT a -> YSymF a
YSymF PBT a
u, PBT a -> YSymF a
forall a. PBT a -> YSymF a
YSymF PBT a
v) | (u :: PBT a
u,v :: PBT a
v) <- PBT a -> [(PBT a, PBT a)]
forall a. PBT a -> [(PBT a, PBT a)]
splits PBT a
t]
              -- using sumv rather than sum to avoid requiring Show a
    -- so again this is a kind of deconcatenation coproduct

multisplits :: t -> PBT a -> [[PBT a]]
multisplits 1 t :: PBT a
t = [ [PBT a
t] ]
multisplits 2 t :: PBT a
t = [ [PBT a
u,PBT a
v] | (u :: PBT a
u,v :: PBT a
v) <- PBT a -> [(PBT a, PBT a)]
forall a. PBT a -> [(PBT a, PBT a)]
splits PBT a
t ]
multisplits n :: t
n t :: PBT a
t = [ PBT a
uPBT a -> [PBT a] -> [PBT a]
forall a. a -> [a] -> [a]
:[PBT a]
ws | (u :: PBT a
u,v :: PBT a
v) <- PBT a -> [(PBT a, PBT a)]
forall a. PBT a -> [(PBT a, PBT a)]
splits PBT a
t, [PBT a]
ws <- t -> PBT a -> [[PBT a]]
multisplits (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) PBT a
v ]

graft :: [PBT a] -> PBT a -> PBT a
graft [t :: PBT a
t] E = PBT a
t
graft ts :: [PBT a]
ts (T l :: PBT a
l x :: a
x r :: PBT a
r) = let (ls :: [PBT a]
ls,rs :: [PBT a]
rs) = Int -> [PBT a] -> ([PBT a], [PBT a])
forall a. Int -> [a] -> ([a], [a])
splitAt (PBT a -> Int
forall p a. Num p => PBT a -> p
leafcount PBT a
l) [PBT a]
ts
                     in PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T ([PBT a] -> PBT a -> PBT a
graft [PBT a]
ls PBT a
l) a
x ([PBT a] -> PBT a -> PBT a
graft [PBT a]
rs PBT a
r)

instance (Eq k, Num k, Ord a) => Algebra k (YSymF a) where
    unit :: k -> Vect k (YSymF a)
unit x :: k
x = k
x k -> Vect k (YSymF a) -> Vect k (YSymF a)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> YSymF a -> Vect k (YSymF a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT a -> YSymF a
forall a. PBT a -> YSymF a
YSymF PBT a
forall a. PBT a
E)
    mult :: Vect k (Tensor (YSymF a) (YSymF a)) -> Vect k (YSymF a)
mult = (Tensor (YSymF a) (YSymF a) -> Vect k (YSymF a))
-> Vect k (Tensor (YSymF a) (YSymF a)) -> Vect k (YSymF a)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor (YSymF a) (YSymF a) -> Vect k (YSymF a)
forall a k.
(Ord a, Num k, Eq k) =>
(YSymF a, YSymF a) -> Vect k (YSymF a)
mult' where
        mult' :: (YSymF a, YSymF a) -> Vect k (YSymF a)
mult' (YSymF t :: PBT a
t, YSymF u :: PBT a
u) = [Vect k (YSymF a)] -> Vect k (YSymF a)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [YSymF a -> Vect k (YSymF a)
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT a -> YSymF a
forall a. PBT a -> YSymF a
YSymF ([PBT a] -> PBT a -> PBT a
forall a. [PBT a] -> PBT a -> PBT a
graft [PBT a]
ts PBT a
u)) | [PBT a]
ts <- Integer -> PBT a -> [[PBT a]]
forall t a. (Eq t, Num t) => t -> PBT a -> [[PBT a]]
multisplits (PBT a -> Integer
forall p a. Num p => PBT a -> p
leafcount PBT a
u) PBT a
t]
        -- using sumv rather than sum to avoid requiring Show a

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 :: Vect k (YSymF a) -> Vect k (YSymF a)
antipode = Vect k (YSymF a) -> Vect k (YSymF a)
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    {-
    antipode = linear antipode' where
        antipode' (YSymF E) = return (YSymF E)
        antipode' x = (negatev . mult . (id `tf` antipode) . removeTerm (YSymF E,x) . comult . return) x
    -}


-- |An alternative \"monomial\" basis for (the dual of) the Loday-Ronco Hopf algebra of binary trees, YSym.
newtype YSymM = YSymM (PBT ()) deriving (YSymM -> YSymM -> Bool
(YSymM -> YSymM -> Bool) -> (YSymM -> YSymM -> Bool) -> Eq YSymM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: YSymM -> YSymM -> Bool
$c/= :: YSymM -> YSymM -> Bool
== :: YSymM -> YSymM -> Bool
$c== :: YSymM -> YSymM -> Bool
Eq, Eq YSymM
Eq YSymM =>
(YSymM -> YSymM -> Ordering)
-> (YSymM -> YSymM -> Bool)
-> (YSymM -> YSymM -> Bool)
-> (YSymM -> YSymM -> Bool)
-> (YSymM -> YSymM -> Bool)
-> (YSymM -> YSymM -> YSymM)
-> (YSymM -> YSymM -> YSymM)
-> Ord YSymM
YSymM -> YSymM -> Bool
YSymM -> YSymM -> Ordering
YSymM -> YSymM -> YSymM
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: YSymM -> YSymM -> YSymM
$cmin :: YSymM -> YSymM -> YSymM
max :: YSymM -> YSymM -> YSymM
$cmax :: YSymM -> YSymM -> YSymM
>= :: YSymM -> YSymM -> Bool
$c>= :: YSymM -> YSymM -> Bool
> :: YSymM -> YSymM -> Bool
$c> :: YSymM -> YSymM -> Bool
<= :: YSymM -> YSymM -> Bool
$c<= :: YSymM -> YSymM -> Bool
< :: YSymM -> YSymM -> Bool
$c< :: YSymM -> YSymM -> Bool
compare :: YSymM -> YSymM -> Ordering
$ccompare :: YSymM -> YSymM -> Ordering
$cp1Ord :: Eq YSymM
Ord)

instance Show YSymM where
    show :: YSymM -> String
show (YSymM t :: PBT ()
t) = "M(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PBT () -> String
forall a. Show a => a -> String
show PBT ()
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

instance Graded YSymM where grade :: YSymM -> Int
grade (YSymM t :: PBT ()
t) = PBT () -> Int
forall p a. Num p => PBT a -> p
nodecount PBT ()
t

-- |Construct the element of YSym in the monomial basis indexed by the given tree
ysymM :: PBT () -> Vect Q YSymM
ysymM :: PBT () -> Vect Q YSymM
ysymM t :: PBT ()
t = YSymM -> Vect Q YSymM
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT () -> YSymM
YSymM PBT ()
t)

-- |List all trees with the given number of nodes
trees :: Int -> [PBT ()]
trees :: Int -> [PBT ()]
trees 0 = [PBT ()
forall a. PBT a
E]
trees n :: Int
n = [PBT () -> () -> PBT () -> PBT ()
forall a. PBT a -> a -> PBT a -> PBT a
T PBT ()
l () PBT ()
r | Int
i <- [0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1], PBT ()
l <- Int -> [PBT ()]
trees (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i), PBT ()
r <- Int -> [PBT ()]
trees Int
i]

-- |The covering relation for the Tamari partial order on binary trees
tamariCovers :: PBT a -> [PBT a]
tamariCovers :: PBT a -> [PBT a]
tamariCovers E = []
tamariCovers (T t :: PBT a
t@(T u :: PBT a
u x :: a
x v :: PBT a
v) y :: a
y w :: PBT a
w) = [PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
t' a
y PBT a
w | PBT a
t' <- PBT a -> [PBT a]
forall a. PBT a -> [PBT a]
tamariCovers PBT a
t]
                                [PBT a] -> [PBT a] -> [PBT a]
forall a. [a] -> [a] -> [a]
++ [PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
t a
y PBT a
w' | PBT a
w' <- PBT a -> [PBT a]
forall a. PBT a -> [PBT a]
tamariCovers PBT a
w]
                                [PBT a] -> [PBT a] -> [PBT a]
forall a. [a] -> [a] -> [a]
++ [PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
u a
y (PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
v a
x PBT a
w)]
                                -- Note that this preserves the descending property, and hence the bijection with permutations
                                -- If we were to swap x and y, we would preserve the binary search tree property instead (if our trees had it)
tamariCovers (T E x :: a
x u :: PBT a
u) = [PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
forall a. PBT a
E a
x PBT a
u' | PBT a
u' <- PBT a -> [PBT a]
forall a. PBT a -> [PBT a]
tamariCovers PBT a
u]  

-- |The up-set of a binary tree in the Tamari partial order
tamariUpSet :: Ord a => PBT a -> [PBT a]
tamariUpSet :: PBT a -> [PBT a]
tamariUpSet t :: PBT a
t = [PBT a] -> [PBT a] -> [PBT a]
forall a. Ord a => [PBT a] -> [PBT a] -> [PBT a]
upSet' [] [PBT a
t]
    where upSet' :: [PBT a] -> [PBT a] -> [PBT a]
upSet' interior :: [PBT a]
interior boundary :: [PBT a]
boundary =
              if [PBT a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PBT a]
boundary
              then [PBT a]
interior
              else let interior' :: [PBT a]
interior' = [PBT a] -> [PBT a] -> [PBT a]
forall a. Ord a => [a] -> [a] -> [a]
setUnionAsc [PBT a]
interior [PBT a]
boundary
                       boundary' :: [PBT a]
boundary' = [PBT a] -> [PBT a]
forall a. Ord a => [a] -> [a]
toSet ([PBT a] -> [PBT a]) -> [PBT a] -> [PBT a]
forall a b. (a -> b) -> a -> b
$ (PBT a -> [PBT a]) -> [PBT a] -> [PBT a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap PBT a -> [PBT a]
forall a. PBT a -> [PBT a]
tamariCovers [PBT a]
boundary
                   in [PBT a] -> [PBT a] -> [PBT a]
upSet' [PBT a]
interior' [PBT a]
boundary'

-- tamariOrder1 u v = v `elem` upSet u

-- |The Tamari partial order on binary trees.
-- This is only defined between trees of the same size (number of nodes).
-- The result between trees of different sizes is undefined (we don't check).
tamariOrder :: PBT a -> PBT a -> Bool
tamariOrder :: PBT a -> PBT a -> Bool
tamariOrder u :: PBT a
u v :: PBT a
v = [Integer] -> [Integer] -> Bool
forall a a. (Ord a, Ord a) => [a] -> [a] -> Bool
weakOrder (PBT a -> [Integer]
forall a a. Num a => PBT a -> [a]
minPerm PBT a
u) (PBT a -> [Integer]
forall a a. Num a => PBT a -> [a]
minPerm PBT a
v)
-- It should be possible to unpack this to be a statement purely about trees, but probably not worth it

-- |Convert an element of YSym represented in the monomial basis to the fundamental basis
ysymMtoF :: (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ())
ysymMtoF :: Vect k YSymM -> Vect k (YSymF ())
ysymMtoF = (YSymM -> Vect k (YSymF ())) -> Vect k YSymM -> Vect k (YSymF ())
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymM -> Vect k (YSymF ())
forall k. (Eq k, Num k) => YSymM -> Vect k (YSymF ())
ysymMtoF' where
    ysymMtoF' :: YSymM -> Vect k (YSymF ())
ysymMtoF' (YSymM t :: PBT ()
t) = [Vect k (YSymF ())] -> Vect k (YSymF ())
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [([PBT ()], PBT () -> PBT () -> Bool) -> PBT () -> PBT () -> k
forall p t. (Num p, Eq t) => ([t], t -> t -> Bool) -> t -> t -> p
mu ([PBT ()]
set,PBT () -> PBT () -> Bool
forall a. PBT a -> PBT a -> Bool
po) PBT ()
t PBT ()
s k -> Vect k (YSymF ()) -> Vect k (YSymF ())
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> YSymF () -> Vect k (YSymF ())
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT () -> YSymF ()
forall a. PBT a -> YSymF a
YSymF PBT ()
s) | PBT ()
s <- [PBT ()]
set]
        where po :: PBT a -> PBT a -> Bool
po = PBT a -> PBT a -> Bool
forall a. PBT a -> PBT a -> Bool
tamariOrder
              set :: [PBT ()]
set = PBT () -> [PBT ()]
forall a. Ord a => PBT a -> [PBT a]
tamariUpSet PBT ()
t -- [s | s <- trees (nodecount t), t `tamariOrder` s]

-- |Convert an element of YSym represented in the fundamental basis to the monomial basis
ysymFtoM :: (Eq k, Num k) => Vect k (YSymF ()) -> Vect k YSymM
ysymFtoM :: Vect k (YSymF ()) -> Vect k YSymM
ysymFtoM = (YSymF () -> Vect k YSymM) -> Vect k (YSymF ()) -> Vect k YSymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymF () -> Vect k YSymM
forall k. (Eq k, Num k) => YSymF () -> Vect k YSymM
ysymFtoM' where
    ysymFtoM' :: YSymF () -> Vect k YSymM
ysymFtoM' (YSymF t :: PBT ()
t) = [Vect k YSymM] -> Vect k YSymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [YSymM -> Vect k YSymM
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT () -> YSymM
YSymM PBT ()
s) | PBT ()
s <- PBT () -> [PBT ()]
forall a. Ord a => PBT a -> [PBT a]
tamariUpSet PBT ()
t]
                       -- sumv [return (YSymM s) | s <- trees (nodecount t), t `tamariOrder` s]


instance (Eq k, Num k) => Algebra k YSymM where
    unit :: k -> Vect k YSymM
unit x :: k
x = k
x k -> Vect k YSymM -> Vect k YSymM
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> YSymM -> Vect k YSymM
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT () -> YSymM
YSymM PBT ()
forall a. PBT a
E)
    mult :: Vect k (Tensor YSymM YSymM) -> Vect k YSymM
mult = Vect k (YSymF ()) -> Vect k YSymM
forall k. (Eq k, Num k) => Vect k (YSymF ()) -> Vect k YSymM
ysymFtoM (Vect k (YSymF ()) -> Vect k YSymM)
-> (Vect k (Tensor YSymM YSymM) -> Vect k (YSymF ()))
-> Vect k (Tensor YSymM YSymM)
-> Vect k YSymM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k (Tensor (YSymF ()) (YSymF ())) -> Vect k (YSymF ())
forall k b. Algebra k b => Vect k (Tensor b b) -> Vect k b
mult (Vect k (Tensor (YSymF ()) (YSymF ())) -> Vect k (YSymF ()))
-> (Vect k (Tensor YSymM YSymM)
    -> Vect k (Tensor (YSymF ()) (YSymF ())))
-> Vect k (Tensor YSymM YSymM)
-> Vect k (YSymF ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vect k YSymM -> Vect k (YSymF ())
forall k. (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ())
ysymMtoF (Vect k YSymM -> Vect k (YSymF ()))
-> (Vect k YSymM -> Vect k (YSymF ()))
-> Vect k (Tensor YSymM YSymM)
-> Vect k (Tensor (YSymF ()) (YSymF ()))
forall k a' b' a b.
(Eq k, Num k, Ord a', Ord b') =>
(Vect k a -> Vect k a')
-> (Vect k b -> Vect k b')
-> Vect k (Tensor a b)
-> Vect k (Tensor a' b')
`tf` Vect k YSymM -> Vect k (YSymF ())
forall k. (Eq k, Num k) => Vect k YSymM -> Vect k (YSymF ())
ysymMtoF)

instance (Eq k, Num k) => Coalgebra k YSymM where
    counit :: Vect k YSymM -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k YSymM -> Vect k ()) -> Vect k YSymM -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YSymM -> Vect k ()) -> Vect k YSymM -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymM -> Vect k ()
forall p. Num p => YSymM -> p
counit' where counit' :: YSymM -> p
counit' (YSymM E) = 1; counit' (YSymM (T _ _ _)) = 0
    -- comult = (ysymFtoM `tf` ysymFtoM) . comult . ysymMtoF
    comult :: Vect k YSymM -> Vect k (Tensor YSymM YSymM)
comult = (YSymM -> Vect k (Tensor YSymM YSymM))
-> Vect k YSymM -> Vect k (Tensor YSymM YSymM)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear YSymM -> Vect k (Tensor YSymM YSymM)
forall k. (Eq k, Num k) => YSymM -> Vect k (Tensor YSymM YSymM)
comult' where
        comult' :: YSymM -> Vect k (Tensor YSymM YSymM)
comult' (YSymM t :: PBT ()
t) = [Vect k (Tensor YSymM YSymM)] -> Vect k (Tensor YSymM YSymM)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor YSymM YSymM -> Vect k (Tensor YSymM YSymM)
forall (m :: * -> *) a. Monad m => a -> m a
return (PBT () -> YSymM
YSymM PBT ()
r, PBT () -> YSymM
YSymM PBT ()
s) | (rs :: [PBT ()]
rs,ss :: [PBT ()]
ss) <- [PBT ()] -> [([PBT ()], [PBT ()])]
forall a. [a] -> [([a], [a])]
deconcatenations (PBT () -> [PBT ()]
forall a. PBT a -> [PBT a]
underDecomposition PBT ()
t),
                                                              let r :: PBT ()
r = (PBT () -> PBT () -> PBT ()) -> PBT () -> [PBT ()] -> PBT ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PBT () -> PBT () -> PBT ()
forall a. PBT a -> PBT a -> PBT a
under PBT ()
forall a. PBT a
E [PBT ()]
rs, let s :: PBT ()
s = (PBT () -> PBT () -> PBT ()) -> PBT () -> [PBT ()] -> PBT ()
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl PBT () -> PBT () -> PBT ()
forall a. PBT a -> PBT a -> PBT a
under PBT ()
forall a. PBT a
E [PBT ()]
ss]


instance (Eq k, Num k) => Bialgebra k YSymM where {}

instance (Eq k, Num k) => HopfAlgebra k YSymM where
    antipode :: Vect k YSymM -> Vect k YSymM
antipode = Vect k YSymM -> Vect k YSymM
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    -- antipode = ysymFtoM . antipode . ysymMtoF 


-- QSYM: QUASI-SYMMETRIC FUNCTIONS
-- The following is the Hopf algebra QSym of quasi-symmetric functions
-- using the monomial and fundamental bases (indexed by compositions)

-- compositions in ascending order
-- might be better to use bfs to get length order
-- |List the compositions of an integer n. For example, the compositions of 4 are [[1,1,1,1],[1,1,2],[1,2,1],[1,3],[2,1,1],[2,2],[3,1],[4]]
compositions :: Int -> [[Int]]
compositions :: Int -> [[Int]]
compositions 0 = [[]]
compositions n :: Int
n = [Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is | Int
i <- [1..Int
n], [Int]
is <- Int -> [[Int]]
compositions (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)]

-- can retrieve subsets of [1..n-1] from compositions n as follows
-- > map (tail . scanl (+) 0) (map init $ compositions 4)
-- [[],[3],[2],[2,3],[1],[1,3],[1,2],[1,2,3]]

-- quasi shuffles of two compositions
quasiShuffles :: [Int] -> [Int] -> [[Int]]
quasiShuffles :: [Int] -> [Int] -> [[Int]]
quasiShuffles (x :: Int
x:xs :: [Int]
xs) (y :: Int
y:ys :: [Int]
ys) = ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int
xInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int] -> [[Int]]
quasiShuffles [Int]
xs (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ys)) [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++
                              ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
y)Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int] -> [[Int]]
quasiShuffles [Int]
xs [Int]
ys) [[Int]] -> [[Int]] -> [[Int]]
forall a. [a] -> [a] -> [a]
++
                              ([Int] -> [Int]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int] -> [[Int]]
quasiShuffles (Int
xInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs) [Int]
ys)
quasiShuffles xs :: [Int]
xs [] = [[Int]
xs]
quasiShuffles [] ys :: [Int]
ys = [[Int]
ys]


-- |A type for the monomial basis for the quasi-symmetric functions, indexed by compositions.
newtype QSymM = QSymM [Int] deriving (QSymM -> QSymM -> Bool
(QSymM -> QSymM -> Bool) -> (QSymM -> QSymM -> Bool) -> Eq QSymM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QSymM -> QSymM -> Bool
$c/= :: QSymM -> QSymM -> Bool
== :: QSymM -> QSymM -> Bool
$c== :: QSymM -> QSymM -> Bool
Eq)

instance Ord QSymM where
    compare :: QSymM -> QSymM -> Ordering
compare (QSymM xs :: [Int]
xs) (QSymM ys :: [Int]
ys) = (Int, [Int]) -> (Int, [Int]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs, [Int]
xs) ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ys, [Int]
ys)

instance Show QSymM where
    show :: QSymM -> String
show (QSymM xs :: [Int]
xs) = "M " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
xs

instance Graded QSymM where grade :: QSymM -> Int
grade (QSymM xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs

-- |Construct the element of QSym in the monomial basis indexed by the given composition
qsymM :: [Int] -> Vect Q QSymM
qsymM :: [Int] -> Vect Q QSymM
qsymM xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = QSymM -> Vect Q QSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [Int]
xs)
         | Bool
otherwise = String -> Vect Q QSymM
forall a. HasCallStack => String -> a
error "qsymM: not a composition"

instance (Eq k, Num k) => Algebra k QSymM where
    unit :: k -> Vect k QSymM
unit x :: k
x = k
x k -> Vect k QSymM -> Vect k QSymM
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> QSymM -> Vect k QSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [])
    mult :: Vect k (Tensor QSymM QSymM) -> Vect k QSymM
mult = (Tensor QSymM QSymM -> Vect k QSymM)
-> Vect k (Tensor QSymM QSymM) -> Vect k QSymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor QSymM QSymM -> Vect k QSymM
forall k. (Eq k, Num k) => Tensor QSymM QSymM -> Vect k QSymM
mult' where
        mult' :: Tensor QSymM QSymM -> Vect k QSymM
mult' (QSymM alpha :: [Int]
alpha, QSymM beta :: [Int]
beta) = [Vect k QSymM] -> Vect k QSymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [QSymM -> Vect k QSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [Int]
gamma) | [Int]
gamma <- [Int] -> [Int] -> [[Int]]
quasiShuffles [Int]
alpha [Int]
beta]

instance (Eq k, Num k) => Coalgebra k QSymM where
    counit :: Vect k QSymM -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k QSymM -> Vect k ()) -> Vect k QSymM -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QSymM -> Vect k ()) -> Vect k QSymM -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear QSymM -> Vect k ()
forall p. Num p => QSymM -> p
counit' where counit' :: QSymM -> p
counit' (QSymM alpha :: [Int]
alpha) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
alpha then 1 else 0
    comult :: Vect k QSymM -> Vect k (Tensor QSymM QSymM)
comult = (QSymM -> Vect k (Tensor QSymM QSymM))
-> Vect k QSymM -> Vect k (Tensor QSymM QSymM)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear QSymM -> Vect k (Tensor QSymM QSymM)
forall k. (Eq k, Num k) => QSymM -> Vect k (Tensor QSymM QSymM)
comult' where
        comult' :: QSymM -> Vect k (Tensor QSymM QSymM)
comult' (QSymM gamma :: [Int]
gamma) = [Vect k (Tensor QSymM QSymM)] -> Vect k (Tensor QSymM QSymM)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor QSymM QSymM -> Vect k (Tensor QSymM QSymM)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [Int]
alpha, [Int] -> QSymM
QSymM [Int]
beta) | (alpha :: [Int]
alpha,beta :: [Int]
beta) <- [Int] -> [([Int], [Int])]
forall a. [a] -> [([a], [a])]
deconcatenations [Int]
gamma]

instance (Eq k, Num k) => Bialgebra k QSymM where {}

instance (Eq k, Num k) => HopfAlgebra k QSymM where
    antipode :: Vect k QSymM -> Vect k QSymM
antipode = Vect k QSymM -> Vect k QSymM
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    {-
    antipode = linear antipode' where
        antipode' (QSymM alpha) = (-1)^length alpha * sumv [return (QSymM beta) | beta <- coarsenings (reverse alpha)]
        -- antipode' (QSymM alpha) = (-1)^length alpha * sumv [return (QSymM (reverse beta)) | beta <- coarsenings alpha]
    -}

coarsenings :: [a] -> [[a]]
coarsenings (x1 :: a
x1:x2 :: a
x2:xs :: [a]
xs) = ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
x1a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [[a]]
coarsenings (a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [a] -> [[a]]
coarsenings ((a
x1a -> a -> a
forall a. Num a => a -> a -> a
+a
x2)a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
coarsenings xs :: [a]
xs = [[a]
xs] -- for xs a singleton or null

refinements :: [Int] -> [[Int]]
refinements (x :: Int
x:xs :: [Int]
xs) = [[Int]
y[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int]
ys | [Int]
y <- Int -> [[Int]]
compositions Int
x, [Int]
ys <- [Int] -> [[Int]]
refinements [Int]
xs]
refinements [] = [[]]


-- |A type for the fundamental basis for the quasi-symmetric functions, indexed by compositions.
newtype QSymF = QSymF [Int] deriving (QSymF -> QSymF -> Bool
(QSymF -> QSymF -> Bool) -> (QSymF -> QSymF -> Bool) -> Eq QSymF
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QSymF -> QSymF -> Bool
$c/= :: QSymF -> QSymF -> Bool
== :: QSymF -> QSymF -> Bool
$c== :: QSymF -> QSymF -> Bool
Eq)

instance Ord QSymF where
    compare :: QSymF -> QSymF -> Ordering
compare (QSymF xs :: [Int]
xs) (QSymF ys :: [Int]
ys) = (Int, [Int]) -> (Int, [Int]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs, [Int]
xs) ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ys, [Int]
ys)

instance Show QSymF where
    show :: QSymF -> String
show (QSymF xs :: [Int]
xs) = "F " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Int] -> String
forall a. Show a => a -> String
show [Int]
xs

instance Graded QSymF where grade :: QSymF -> Int
grade (QSymF xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs

-- |Construct the element of QSym in the fundamental basis indexed by the given composition
qsymF :: [Int] -> Vect Q QSymF
qsymF :: [Int] -> Vect Q QSymF
qsymF xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = QSymF -> Vect Q QSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymF
QSymF [Int]
xs)
         | Bool
otherwise = String -> Vect Q QSymF
forall a. HasCallStack => String -> a
error "qsymF: not a composition"

-- |Convert an element of QSym represented in the monomial basis to the fundamental basis
qsymMtoF :: (Eq k, Num k) => Vect k QSymM -> Vect k QSymF
qsymMtoF :: Vect k QSymM -> Vect k QSymF
qsymMtoF = (QSymM -> Vect k QSymF) -> Vect k QSymM -> Vect k QSymF
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear QSymM -> Vect k QSymF
forall k. (Eq k, Num k) => QSymM -> Vect k QSymF
qsymMtoF' where
    qsymMtoF' :: QSymM -> Vect k QSymF
qsymMtoF' (QSymM alpha :: [Int]
alpha) = [Vect k QSymF] -> Vect k QSymF
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(-1) k -> Int -> k
forall a b. (Num a, Integral b) => a -> b -> a
^ ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
beta Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
alpha) k -> Vect k QSymF -> Vect k QSymF
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> QSymF -> Vect k QSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymF
QSymF [Int]
beta) | [Int]
beta <- [Int] -> [[Int]]
refinements [Int]
alpha]

-- |Convert an element of QSym represented in the fundamental basis to the monomial basis
qsymFtoM :: (Eq k, Num k) => Vect k QSymF -> Vect k QSymM
qsymFtoM :: Vect k QSymF -> Vect k QSymM
qsymFtoM = (QSymF -> Vect k QSymM) -> Vect k QSymF -> Vect k QSymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear QSymF -> Vect k QSymM
forall k. (Eq k, Num k) => QSymF -> Vect k QSymM
qsymFtoM' where
    qsymFtoM' :: QSymF -> Vect k QSymM
qsymFtoM' (QSymF alpha :: [Int]
alpha) = [Vect k QSymM] -> Vect k QSymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [QSymM -> Vect k QSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [Int]
beta) | [Int]
beta <- [Int] -> [[Int]]
refinements [Int]
alpha] -- ie beta <- up-set of alpha

instance (Eq k, Num k) => Algebra k QSymF where
    unit :: k -> Vect k QSymF
unit x :: k
x = k
x k -> Vect k QSymF -> Vect k QSymF
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> QSymF -> Vect k QSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymF
QSymF [])
    mult :: Vect k (Tensor QSymF QSymF) -> Vect k QSymF
mult = Vect k QSymM -> Vect k QSymF
forall k. (Eq k, Num k) => Vect k QSymM -> Vect k QSymF
qsymMtoF (Vect k QSymM -> Vect k QSymF)
-> (Vect k (Tensor QSymF QSymF) -> Vect k QSymM)
-> Vect k (Tensor QSymF QSymF)
-> Vect k QSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k (Tensor QSymM QSymM) -> Vect k QSymM
forall k b. Algebra k b => Vect k (Tensor b b) -> Vect k b
mult (Vect k (Tensor QSymM QSymM) -> Vect k QSymM)
-> (Vect k (Tensor QSymF QSymF) -> Vect k (Tensor QSymM QSymM))
-> Vect k (Tensor QSymF QSymF)
-> Vect k QSymM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vect k QSymF -> Vect k QSymM
forall k. (Eq k, Num k) => Vect k QSymF -> Vect k QSymM
qsymFtoM (Vect k QSymF -> Vect k QSymM)
-> (Vect k QSymF -> Vect k QSymM)
-> Vect k (Tensor QSymF QSymF)
-> Vect k (Tensor QSymM QSymM)
forall k a' b' a b.
(Eq k, Num k, Ord a', Ord b') =>
(Vect k a -> Vect k a')
-> (Vect k b -> Vect k b')
-> Vect k (Tensor a b)
-> Vect k (Tensor a' b')
`tf` Vect k QSymF -> Vect k QSymM
forall k. (Eq k, Num k) => Vect k QSymF -> Vect k QSymM
qsymFtoM)

instance (Eq k, Num k) => Coalgebra k QSymF where
    counit :: Vect k QSymF -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k)
-> (Vect k QSymF -> Vect k ()) -> Vect k QSymF -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QSymF -> Vect k ()) -> Vect k QSymF -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear QSymF -> Vect k ()
forall p. Num p => QSymF -> p
counit' where counit' :: QSymF -> p
counit' (QSymF xs :: [Int]
xs) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs then 1 else 0
    comult :: Vect k QSymF -> Vect k (Tensor QSymF QSymF)
comult = (Vect k QSymM -> Vect k QSymF
forall k. (Eq k, Num k) => Vect k QSymM -> Vect k QSymF
qsymMtoF (Vect k QSymM -> Vect k QSymF)
-> (Vect k QSymM -> Vect k QSymF)
-> Vect k (Tensor QSymM QSymM)
-> Vect k (Tensor QSymF QSymF)
forall k a' b' a b.
(Eq k, Num k, Ord a', Ord b') =>
(Vect k a -> Vect k a')
-> (Vect k b -> Vect k b')
-> Vect k (Tensor a b)
-> Vect k (Tensor a' b')
`tf` Vect k QSymM -> Vect k QSymF
forall k. (Eq k, Num k) => Vect k QSymM -> Vect k QSymF
qsymMtoF) (Vect k (Tensor QSymM QSymM) -> Vect k (Tensor QSymF QSymF))
-> (Vect k QSymF -> Vect k (Tensor QSymM QSymM))
-> Vect k QSymF
-> Vect k (Tensor QSymF QSymF)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k QSymM -> Vect k (Tensor QSymM QSymM)
forall k b. Coalgebra k b => Vect k b -> Vect k (Tensor b b)
comult (Vect k QSymM -> Vect k (Tensor QSymM QSymM))
-> (Vect k QSymF -> Vect k QSymM)
-> Vect k QSymF
-> Vect k (Tensor QSymM QSymM)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vect k QSymF -> Vect k QSymM
forall k. (Eq k, Num k) => Vect k QSymF -> Vect k QSymM
qsymFtoM

instance (Eq k, Num k) => Bialgebra k QSymF where {}

instance (Eq k, Num k) => HopfAlgebra k QSymF where
    antipode :: Vect k QSymF -> Vect k QSymF
antipode = Vect k QSymF -> Vect k QSymF
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    -- antipode = qsymMtoF . antipode . qsymFtoM


-- QUASI-SYMMETRIC POLYNOMIALS

-- the above induces Hopf algebra structure on quasi-symmetric functions via
-- m_alpha -> sum [product (zipWith (^) (map x_ is) alpha | is <- combinationsOf k [] ] where k = length alpha

-- xvars n = [glexvar ("x" ++ show i) | i <- [1..n] ]

-- |@qsymPoly n is@ is the quasi-symmetric polynomial in n variables for the indices is. (This corresponds to the
-- monomial basis for QSym.) For example, qsymPoly 3 [2,1] == x1^2*x2+x1^2*x3+x2^2*x3.
qsymPoly :: Int -> [Int] -> GlexPoly Q String
qsymPoly :: Int -> [Int] -> GlexPoly Q String
qsymPoly n :: Int
n is :: [Int]
is = [GlexPoly Q String] -> GlexPoly Q String
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[GlexPoly Q String] -> GlexPoly Q String
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((GlexPoly Q String -> Int -> GlexPoly Q String)
-> [GlexPoly Q String] -> [Int] -> [GlexPoly Q String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith GlexPoly Q String -> Int -> GlexPoly Q String
forall a b. (Num a, Integral b) => a -> b -> a
(^) [GlexPoly Q String]
xs' [Int]
is) | [GlexPoly Q String]
xs' <- Int -> [GlexPoly Q String] -> [[GlexPoly Q String]]
forall a. Int -> [a] -> [[a]]
combinationsOf Int
r [GlexPoly Q String]
xs]
    where xs :: [GlexPoly Q String]
xs = [String -> GlexPoly Q String
forall v. v -> GlexPoly Q v
glexvar ("x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [1..Int
n] ]
          r :: Int
r = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
is


-- SYM, THE HOPF ALGEBRA OF SYMMETRIC FUNCTIONS

-- |A type for the monomial basis for Sym, the Hopf algebra of symmetric functions, indexed by integer partitions
newtype SymM = SymM [Int] deriving (SymM -> SymM -> Bool
(SymM -> SymM -> Bool) -> (SymM -> SymM -> Bool) -> Eq SymM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SymM -> SymM -> Bool
$c/= :: SymM -> SymM -> Bool
== :: SymM -> SymM -> Bool
$c== :: SymM -> SymM -> Bool
Eq,Int -> SymM -> ShowS
[SymM] -> ShowS
SymM -> String
(Int -> SymM -> ShowS)
-> (SymM -> String) -> ([SymM] -> ShowS) -> Show SymM
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SymM] -> ShowS
$cshowList :: [SymM] -> ShowS
show :: SymM -> String
$cshow :: SymM -> String
showsPrec :: Int -> SymM -> ShowS
$cshowsPrec :: Int -> SymM -> ShowS
Show)

instance Ord SymM where
    compare :: SymM -> SymM -> Ordering
compare (SymM xs :: [Int]
xs) (SymM ys :: [Int]
ys) = (Int, [Int]) -> (Int, [Int]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs, [Int]
ys) ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ys, [Int]
xs) -- note the order reversal in snd

instance Graded SymM where grade :: SymM -> Int
grade (SymM xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs

-- |Construct the element of Sym in the monomial basis indexed by the given integer partition
symM :: [Int] -> Vect Q SymM
symM :: [Int] -> Vect Q SymM
symM xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = SymM -> Vect Q SymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM ([Int] -> SymM) -> [Int] -> SymM
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sortDesc [Int]
xs)
        | Bool
otherwise = String -> Vect Q SymM
forall a. HasCallStack => String -> a
error "symM: not a partition"

instance (Eq k, Num k) => Algebra k SymM where
    unit :: k -> Vect k SymM
unit x :: k
x = k
x k -> Vect k SymM -> Vect k SymM
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SymM -> Vect k SymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM [])
    mult :: Vect k (Tensor SymM SymM) -> Vect k SymM
mult = (Tensor SymM SymM -> Vect k SymM)
-> Vect k (Tensor SymM SymM) -> Vect k SymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor SymM SymM -> Vect k SymM
forall k. (Eq k, Num k) => Tensor SymM SymM -> Vect k SymM
mult' where
        mult' :: Tensor SymM SymM -> Vect k SymM
mult' (SymM lambda :: [Int]
lambda, SymM mu :: [Int]
mu) = [Vect k SymM] -> Vect k SymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [SymM -> Vect k SymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM [Int]
nu) | [Int]
nu <- [Int] -> [Int] -> [[Int]]
symMult [Int]
lambda [Int]
mu]

-- multisetPermutations = toSet . L.permutations

-- compositionsFromPartition2 = foldl (\xss ys -> concatMap (shuffles ys) xss) [[]] . L.group
-- compositionsFromPartition2 = foldl (\ls r -> concat [shuffles l r | l <- ls]) [[]] . L.group

-- The partition must be in either ascending or descending order (so that L.group does as expected)
compositionsFromPartition :: [a] -> [[a]]
compositionsFromPartition = ([a] -> [[a]] -> [[a]]) -> [[a]] -> [[a]] -> [[a]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\l :: [a]
l rs :: [[a]]
rs -> ([a] -> [[a]]) -> [[a]] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([a] -> [a] -> [[a]]
forall a. [a] -> [a] -> [[a]]
shuffles [a]
l) [[a]]
rs) [[]] ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
L.group

-- In effect, we multiply in Sym by converting to QSym, multiplying there, and converting back.
-- It would be nice to find a more direct method.
symMult :: [Int] -> [Int] -> [[Int]]
symMult xs :: [Int]
xs ys :: [Int]
ys = ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Int] -> Bool
forall t. Ord t => [t] -> Bool
isWeaklyDecreasing ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ [[[Int]]] -> [[Int]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [[Int] -> [Int] -> [[Int]]
quasiShuffles [Int]
xs' [Int]
ys' | [Int]
xs' <- [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
compositionsFromPartition [Int]
xs, [Int]
ys' <- [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
compositionsFromPartition [Int]
ys]

instance (Eq k, Num k) => Coalgebra k SymM where
    counit :: Vect k SymM -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k) -> (Vect k SymM -> Vect k ()) -> Vect k SymM -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymM -> Vect k ()) -> Vect k SymM -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymM -> Vect k ()
forall p. Num p => SymM -> p
counit' where counit' :: SymM -> p
counit' (SymM lambda :: [Int]
lambda) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
lambda then 1 else 0
    comult :: Vect k SymM -> Vect k (Tensor SymM SymM)
comult = (SymM -> Vect k (Tensor SymM SymM))
-> Vect k SymM -> Vect k (Tensor SymM SymM)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymM -> Vect k (Tensor SymM SymM)
forall k. (Eq k, Num k) => SymM -> Vect k (Tensor SymM SymM)
comult' where
        comult' :: SymM -> Vect k (Tensor SymM SymM)
comult' (SymM lambda :: [Int]
lambda) = [Vect k (Tensor SymM SymM)] -> Vect k (Tensor SymM SymM)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor SymM SymM -> Vect k (Tensor SymM SymM)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM [Int]
mu, [Int] -> SymM
SymM [Int]
nu) | [Int]
mu <- [[Int]] -> [[Int]]
forall a. Ord a => [a] -> [a]
toSet ([Int] -> [[Int]]
forall a. [a] -> [[a]]
powersetdfs [Int]
lambda), let nu :: [Int]
nu = [Int] -> [Int] -> [Int]
forall a. Ord a => [a] -> [a] -> [a]
diffDesc [Int]
lambda [Int]
mu]

instance (Eq k, Num k) => Bialgebra k SymM where {}

instance (Eq k, Num k) => HopfAlgebra k SymM where
    antipode :: Vect k SymM -> Vect k SymM
antipode = Vect k SymM -> Vect k SymM
forall k b.
(Eq k, Num k, Ord b, Bialgebra k b, Graded b) =>
Vect k b -> Vect k b
gradedConnectedAntipode
    {-
    antipode = linear antipode' where
        antipode' (SymM []) = return (SymM [])
        antipode' x = (negatev . mult . (id `tf` antipode) . removeTerm (SymM [],x) . comult . return) x
    -}

-- |The elementary basis for Sym, the Hopf algebra of symmetric functions. Defined informally as
-- > symE [n] = symM (replicate n 1)
-- > symE lambda = product [symE [p] | p <- lambda]
newtype SymE = SymE [Int] deriving (SymE -> SymE -> Bool
(SymE -> SymE -> Bool) -> (SymE -> SymE -> Bool) -> Eq SymE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SymE -> SymE -> Bool
$c/= :: SymE -> SymE -> Bool
== :: SymE -> SymE -> Bool
$c== :: SymE -> SymE -> Bool
Eq,Eq SymE
Eq SymE =>
(SymE -> SymE -> Ordering)
-> (SymE -> SymE -> Bool)
-> (SymE -> SymE -> Bool)
-> (SymE -> SymE -> Bool)
-> (SymE -> SymE -> Bool)
-> (SymE -> SymE -> SymE)
-> (SymE -> SymE -> SymE)
-> Ord SymE
SymE -> SymE -> Bool
SymE -> SymE -> Ordering
SymE -> SymE -> SymE
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SymE -> SymE -> SymE
$cmin :: SymE -> SymE -> SymE
max :: SymE -> SymE -> SymE
$cmax :: SymE -> SymE -> SymE
>= :: SymE -> SymE -> Bool
$c>= :: SymE -> SymE -> Bool
> :: SymE -> SymE -> Bool
$c> :: SymE -> SymE -> Bool
<= :: SymE -> SymE -> Bool
$c<= :: SymE -> SymE -> Bool
< :: SymE -> SymE -> Bool
$c< :: SymE -> SymE -> Bool
compare :: SymE -> SymE -> Ordering
$ccompare :: SymE -> SymE -> Ordering
$cp1Ord :: Eq SymE
Ord,Int -> SymE -> ShowS
[SymE] -> ShowS
SymE -> String
(Int -> SymE -> ShowS)
-> (SymE -> String) -> ([SymE] -> ShowS) -> Show SymE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SymE] -> ShowS
$cshowList :: [SymE] -> ShowS
show :: SymE -> String
$cshow :: SymE -> String
showsPrec :: Int -> SymE -> ShowS
$cshowsPrec :: Int -> SymE -> ShowS
Show)

instance Graded SymE where grade :: SymE -> Int
grade (SymE xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs

symE :: [Int] -> Vect Q SymE
symE :: [Int] -> Vect Q SymE
symE xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = SymE -> Vect Q SymE
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymE
SymE ([Int] -> SymE) -> [Int] -> SymE
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sortDesc [Int]
xs)
        | Bool
otherwise = String -> Vect Q SymE
forall a. HasCallStack => String -> a
error "symE: not a partition"

instance (Eq k, Num k) => Algebra k SymE where
    unit :: k -> Vect k SymE
unit x :: k
x = k
x k -> Vect k SymE -> Vect k SymE
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SymE -> Vect k SymE
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymE
SymE [])
    mult :: Vect k (Tensor SymE SymE) -> Vect k SymE
mult = (Tensor SymE SymE -> Vect k SymE)
-> Vect k (Tensor SymE SymE) -> Vect k SymE
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear (\(SymE lambda :: [Int]
lambda, SymE mu :: [Int]
mu) -> SymE -> Vect k SymE
forall (m :: * -> *) a. Monad m => a -> m a
return (SymE -> Vect k SymE) -> SymE -> Vect k SymE
forall a b. (a -> b) -> a -> b
$ [Int] -> SymE
SymE ([Int] -> SymE) -> [Int] -> SymE
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [Int]
forall a. Ord a => [a] -> [a] -> [a]
multisetSumDesc [Int]
lambda [Int]
mu)

instance (Eq k, Num k) => Coalgebra k SymE where
    counit :: Vect k SymE -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k) -> (Vect k SymE -> Vect k ()) -> Vect k SymE -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymE -> Vect k ()) -> Vect k SymE -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymE -> Vect k ()
forall p. Num p => SymE -> p
counit' where counit' :: SymE -> p
counit' (SymE lambda :: [Int]
lambda) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
lambda then 1 else 0
    comult :: Vect k SymE -> Vect k (Tensor SymE SymE)
comult = (SymE -> Vect k (Tensor SymE SymE))
-> Vect k SymE -> Vect k (Tensor SymE SymE)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymE -> Vect k (Tensor SymE SymE)
forall k. (Eq k, Num k) => SymE -> Vect k (Tensor SymE SymE)
comult' where
        comult' :: SymE -> Vect k (Tensor SymE SymE)
comult' (SymE [n :: Int
n]) = [Vect k (Tensor SymE SymE)] -> Vect k (Tensor SymE SymE)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor SymE SymE -> Vect k (Tensor SymE SymE)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> SymE
e Int
i, Int -> SymE
e (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) | Int
i <- [0..Int
n] ]
        comult' (SymE lambda :: [Int]
lambda) = [Vect k (Tensor SymE SymE)] -> Vect k (Tensor SymE SymE)
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [SymE -> Vect k (Tensor SymE SymE)
comult' ([Int] -> SymE
SymE [Int
n]) | Int
n <- [Int]
lambda]
        e :: Int -> SymE
e 0 = [Int] -> SymE
SymE []
        e i :: Int
i = [Int] -> SymE
SymE [Int
i]

instance (Eq k, Num k) => Bialgebra k SymE where {}

-- TODO: HopfAlgebra instance?

-- |Convert from the elementary to the monomial basis of Sym
symEtoM :: (Eq k, Num k) => Vect k SymE -> Vect k SymM
symEtoM :: Vect k SymE -> Vect k SymM
symEtoM = (SymE -> Vect k SymM) -> Vect k SymE -> Vect k SymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymE -> Vect k SymM
forall (m :: * -> *). (Monad m, Num (m SymM)) => SymE -> m SymM
symEtoM' where
    symEtoM' :: SymE -> m SymM
symEtoM' (SymE [n :: Int
n]) = SymM -> m SymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
n 1))
    symEtoM' (SymE lambda :: [Int]
lambda) = [m SymM] -> m SymM
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [SymE -> m SymM
symEtoM' ([Int] -> SymE
SymE [Int
p]) | Int
p <- [Int]
lambda]


-- |The complete basis for Sym, the Hopf algebra of symmetric functions. Defined informally as
-- > symH [n] = sum [symM lambda | lambda <- integerPartitions n] -- == all monomials of weight n
-- > symH lambda = product [symH [p] | p <- lambda]
newtype SymH = SymH [Int] deriving (SymH -> SymH -> Bool
(SymH -> SymH -> Bool) -> (SymH -> SymH -> Bool) -> Eq SymH
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SymH -> SymH -> Bool
$c/= :: SymH -> SymH -> Bool
== :: SymH -> SymH -> Bool
$c== :: SymH -> SymH -> Bool
Eq,Eq SymH
Eq SymH =>
(SymH -> SymH -> Ordering)
-> (SymH -> SymH -> Bool)
-> (SymH -> SymH -> Bool)
-> (SymH -> SymH -> Bool)
-> (SymH -> SymH -> Bool)
-> (SymH -> SymH -> SymH)
-> (SymH -> SymH -> SymH)
-> Ord SymH
SymH -> SymH -> Bool
SymH -> SymH -> Ordering
SymH -> SymH -> SymH
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SymH -> SymH -> SymH
$cmin :: SymH -> SymH -> SymH
max :: SymH -> SymH -> SymH
$cmax :: SymH -> SymH -> SymH
>= :: SymH -> SymH -> Bool
$c>= :: SymH -> SymH -> Bool
> :: SymH -> SymH -> Bool
$c> :: SymH -> SymH -> Bool
<= :: SymH -> SymH -> Bool
$c<= :: SymH -> SymH -> Bool
< :: SymH -> SymH -> Bool
$c< :: SymH -> SymH -> Bool
compare :: SymH -> SymH -> Ordering
$ccompare :: SymH -> SymH -> Ordering
$cp1Ord :: Eq SymH
Ord,Int -> SymH -> ShowS
[SymH] -> ShowS
SymH -> String
(Int -> SymH -> ShowS)
-> (SymH -> String) -> ([SymH] -> ShowS) -> Show SymH
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SymH] -> ShowS
$cshowList :: [SymH] -> ShowS
show :: SymH -> String
$cshow :: SymH -> String
showsPrec :: Int -> SymH -> ShowS
$cshowsPrec :: Int -> SymH -> ShowS
Show)

symH :: [Int] -> Vect Q SymH
symH :: [Int] -> Vect Q SymH
symH xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = SymH -> Vect Q SymH
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymH
SymH ([Int] -> SymH) -> [Int] -> SymH
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sortDesc [Int]
xs)
        | Bool
otherwise = String -> Vect Q SymH
forall a. HasCallStack => String -> a
error "symH: not a partition"

instance (Eq k, Num k) => Algebra k SymH where
    unit :: k -> Vect k SymH
unit x :: k
x = k
x k -> Vect k SymH -> Vect k SymH
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> SymH -> Vect k SymH
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymH
SymH [])
    mult :: Vect k (Tensor SymH SymH) -> Vect k SymH
mult = (Tensor SymH SymH -> Vect k SymH)
-> Vect k (Tensor SymH SymH) -> Vect k SymH
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear (\(SymH lambda :: [Int]
lambda, SymH mu :: [Int]
mu) -> SymH -> Vect k SymH
forall (m :: * -> *) a. Monad m => a -> m a
return (SymH -> Vect k SymH) -> SymH -> Vect k SymH
forall a b. (a -> b) -> a -> b
$ [Int] -> SymH
SymH ([Int] -> SymH) -> [Int] -> SymH
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [Int]
forall a. Ord a => [a] -> [a] -> [a]
multisetSumDesc [Int]
lambda [Int]
mu)

instance (Eq k, Num k) => Coalgebra k SymH where
    counit :: Vect k SymH -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k) -> (Vect k SymH -> Vect k ()) -> Vect k SymH -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymH -> Vect k ()) -> Vect k SymH -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymH -> Vect k ()
forall p. Num p => SymH -> p
counit' where counit' :: SymH -> p
counit' (SymH lambda :: [Int]
lambda) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
lambda then 1 else 0
    comult :: Vect k SymH -> Vect k (Tensor SymH SymH)
comult = (SymH -> Vect k (Tensor SymH SymH))
-> Vect k SymH -> Vect k (Tensor SymH SymH)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymH -> Vect k (Tensor SymH SymH)
forall k. (Eq k, Num k) => SymH -> Vect k (Tensor SymH SymH)
comult' where
        comult' :: SymH -> Vect k (Tensor SymH SymH)
comult' (SymH [n :: Int
n]) = [Vect k (Tensor SymH SymH)] -> Vect k (Tensor SymH SymH)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor SymH SymH -> Vect k (Tensor SymH SymH)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> SymH
h Int
i, Int -> SymH
h (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) | Int
i <- [0..Int
n] ]
        comult' (SymH lambda :: [Int]
lambda) = [Vect k (Tensor SymH SymH)] -> Vect k (Tensor SymH SymH)
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [SymH -> Vect k (Tensor SymH SymH)
comult' ([Int] -> SymH
SymH [Int
n]) | Int
n <- [Int]
lambda]
        h :: Int -> SymH
h 0 = [Int] -> SymH
SymH []
        h i :: Int
i = [Int] -> SymH
SymH [Int
i]

instance (Eq k, Num k) => Bialgebra k SymH where {}

-- TODO: HopfAlgebra instance?

-- |Convert from the complete to the monomial basis of Sym
symHtoM :: (Eq k, Num k) => Vect k SymH -> Vect k SymM
symHtoM :: Vect k SymH -> Vect k SymM
symHtoM = (SymH -> Vect k SymM) -> Vect k SymH -> Vect k SymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymH -> Vect k SymM
forall k. (Eq k, Num k) => SymH -> Vect k SymM
symHtoM' where
    symHtoM' :: SymH -> Vect k SymM
symHtoM' (SymH [n :: Int
n]) = [Vect k SymM] -> Vect k SymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [SymM -> Vect k SymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymM
SymM [Int]
mu) | [Int]
mu <- Int -> [[Int]]
forall a. (Ord a, Num a) => a -> [[a]]
integerPartitions Int
n]
    symHtoM' (SymH lambda :: [Int]
lambda) = [Vect k SymM] -> Vect k SymM
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [SymH -> Vect k SymM
symHtoM' ([Int] -> SymH
SymH [Int
p]) | Int
p <- [Int]
lambda]


-- NSYM, THE HOPF ALGEBRA OF NON-COMMUTATIVE SYMMETRIC FUNCTIONS

-- |A basis for NSym, the Hopf algebra of non-commutative symmetric functions, indexed by compositions
newtype NSym = NSym [Int] deriving (NSym -> NSym -> Bool
(NSym -> NSym -> Bool) -> (NSym -> NSym -> Bool) -> Eq NSym
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NSym -> NSym -> Bool
$c/= :: NSym -> NSym -> Bool
== :: NSym -> NSym -> Bool
$c== :: NSym -> NSym -> Bool
Eq,Eq NSym
Eq NSym =>
(NSym -> NSym -> Ordering)
-> (NSym -> NSym -> Bool)
-> (NSym -> NSym -> Bool)
-> (NSym -> NSym -> Bool)
-> (NSym -> NSym -> Bool)
-> (NSym -> NSym -> NSym)
-> (NSym -> NSym -> NSym)
-> Ord NSym
NSym -> NSym -> Bool
NSym -> NSym -> Ordering
NSym -> NSym -> NSym
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NSym -> NSym -> NSym
$cmin :: NSym -> NSym -> NSym
max :: NSym -> NSym -> NSym
$cmax :: NSym -> NSym -> NSym
>= :: NSym -> NSym -> Bool
$c>= :: NSym -> NSym -> Bool
> :: NSym -> NSym -> Bool
$c> :: NSym -> NSym -> Bool
<= :: NSym -> NSym -> Bool
$c<= :: NSym -> NSym -> Bool
< :: NSym -> NSym -> Bool
$c< :: NSym -> NSym -> Bool
compare :: NSym -> NSym -> Ordering
$ccompare :: NSym -> NSym -> Ordering
$cp1Ord :: Eq NSym
Ord,Int -> NSym -> ShowS
[NSym] -> ShowS
NSym -> String
(Int -> NSym -> ShowS)
-> (NSym -> String) -> ([NSym] -> ShowS) -> Show NSym
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NSym] -> ShowS
$cshowList :: [NSym] -> ShowS
show :: NSym -> String
$cshow :: NSym -> String
showsPrec :: Int -> NSym -> ShowS
$cshowsPrec :: Int -> NSym -> ShowS
Show)

instance Graded NSym where grade :: NSym -> Int
grade (NSym xs :: [Int]
xs) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs

nsym :: [Int] -> Vect Q NSym
nsym :: [Int] -> Vect Q NSym
nsym xs :: [Int]
xs | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>0) [Int]
xs = NSym -> Vect Q NSym
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> NSym
NSym [Int]
xs)
        | Bool
otherwise = String -> Vect Q NSym
forall a. HasCallStack => String -> a
error "nsym: not a composition"

instance (Eq k, Num k) => Algebra k NSym where
    unit :: k -> Vect k NSym
unit x :: k
x = k
x k -> Vect k NSym -> Vect k NSym
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> NSym -> Vect k NSym
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> NSym
NSym [])
    mult :: Vect k (Tensor NSym NSym) -> Vect k NSym
mult = (Tensor NSym NSym -> Vect k NSym)
-> Vect k (Tensor NSym NSym) -> Vect k NSym
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor NSym NSym -> Vect k NSym
forall (m :: * -> *). Monad m => Tensor NSym NSym -> m NSym
mult' where
        mult' :: Tensor NSym NSym -> m NSym
mult' (NSym xs :: [Int]
xs, NSym ys :: [Int]
ys) = NSym -> m NSym
forall (m :: * -> *) a. Monad m => a -> m a
return (NSym -> m NSym) -> NSym -> m NSym
forall a b. (a -> b) -> a -> b
$ [Int] -> NSym
NSym ([Int] -> NSym) -> [Int] -> NSym
forall a b. (a -> b) -> a -> b
$ [Int]
xs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
ys

instance (Eq k, Num k) => Coalgebra k NSym where
    counit :: Vect k NSym -> k
counit = Vect k () -> k
forall k. Num k => Vect k () -> k
unwrap (Vect k () -> k) -> (Vect k NSym -> Vect k ()) -> Vect k NSym -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NSym -> Vect k ()) -> Vect k NSym -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear NSym -> Vect k ()
forall p. Num p => NSym -> p
counit' where counit' :: NSym -> p
counit' (NSym zs :: [Int]
zs) = if [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
zs then 1 else 0
    comult :: Vect k NSym -> Vect k (Tensor NSym NSym)
comult = (NSym -> Vect k (Tensor NSym NSym))
-> Vect k NSym -> Vect k (Tensor NSym NSym)
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear NSym -> Vect k (Tensor NSym NSym)
forall k. (Eq k, Num k) => NSym -> Vect k (Tensor NSym NSym)
comult' where
        comult' :: NSym -> Vect k (Tensor NSym NSym)
comult' (NSym [n :: Int
n]) = [Vect k (Tensor NSym NSym)] -> Vect k (Tensor NSym NSym)
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [Tensor NSym NSym -> Vect k (Tensor NSym NSym)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> NSym
z Int
i, Int -> NSym
z (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)) | Int
i <- [0..Int
n] ]
        comult' (NSym zs :: [Int]
zs) = [Vect k (Tensor NSym NSym)] -> Vect k (Tensor NSym NSym)
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [NSym -> Vect k (Tensor NSym NSym)
comult' ([Int] -> NSym
NSym [Int
n]) | Int
n <- [Int]
zs]
        z :: Int -> NSym
z 0 = [Int] -> NSym
NSym []
        z i :: Int
i = [Int] -> NSym
NSym [Int
i]

instance (Eq k, Num k) => Bialgebra k NSym where {}

-- Hazewinkel et al p233
instance (Eq k, Num k) => HopfAlgebra k NSym where
    antipode :: Vect k NSym -> Vect k NSym
antipode = (NSym -> Vect k NSym) -> Vect k NSym -> Vect k NSym
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear NSym -> Vect k NSym
forall k. (Eq k, Num k) => NSym -> Vect k NSym
antipode' where
        antipode' :: NSym -> Vect k NSym
antipode' (NSym alpha :: [Int]
alpha) = [Vect k NSym] -> Vect k NSym
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [(-1)k -> Int -> k
forall a b. (Num a, Integral b) => a -> b -> a
^[Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
beta k -> Vect k NSym -> Vect k NSym
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> NSym -> Vect k NSym
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> NSym
NSym [Int]
beta) | [Int]
beta <- [Int] -> [[Int]]
refinements ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
alpha)]



-- MAPS BETWEEN (POSETS AND) HOPF ALGEBRAS

-- A descending tree is one in which a child is always less than a parent.
descendingTree :: [a] -> PBT a
descendingTree [] = PBT a
forall a. PBT a
E
descendingTree [x :: a
x] = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
forall a. PBT a
E a
x PBT a
forall a. PBT a
E
descendingTree xs :: [a]
xs = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l a
x PBT a
r
    where x :: a
x = [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs
          (ls :: [a]
ls,_:rs :: [a]
rs) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs
          l :: PBT a
l = [a] -> PBT a
descendingTree [a]
ls
          r :: PBT a
r = [a] -> PBT a
descendingTree [a]
rs
-- This is a bijection from permutations to "ordered trees".
-- It is order-preserving on trees with the same nodecount.
-- We can recover the permutation by reading the node labels in infix order.
-- This is the map called lambda in Loday.pdf


-- |Given a permutation p of [1..n], we can construct a tree (the descending tree of p) as follows:
--
-- * Split the permutation as p = ls ++ [n] ++ rs
--
-- * Place n at the root of the tree, and recursively place the descending trees of ls and rs as the left and right children of the root
--
-- * To bottom out the recursion, the descending tree of the empty permutation is of course the empty tree
--
-- This map between bases SSymF -> YSymF turns out to induce a morphism of Hopf algebras.
descendingTreeMap :: (Eq k, Num k) => Vect k SSymF -> Vect k (YSymF ())
descendingTreeMap :: Vect k SSymF -> Vect k (YSymF ())
descendingTreeMap = Vect k (YSymF ()) -> Vect k (YSymF ())
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k (YSymF ()) -> Vect k (YSymF ()))
-> (Vect k SSymF -> Vect k (YSymF ()))
-> Vect k SSymF
-> Vect k (YSymF ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SSymF -> YSymF ()) -> Vect k SSymF -> Vect k (YSymF ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PBT () -> YSymF ()
forall a. PBT a -> YSymF a
YSymF (PBT () -> YSymF ()) -> (SSymF -> PBT ()) -> SSymF -> YSymF ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PBT Int -> PBT ()
forall a. PBT a -> PBT ()
shape (PBT Int -> PBT ()) -> (SSymF -> PBT Int) -> SSymF -> PBT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  SSymF -> PBT Int
descendingTree')
    where descendingTree' :: SSymF -> PBT Int
descendingTree' (SSymF xs :: [Int]
xs) = [Int] -> PBT Int
forall a. Ord a => [a] -> PBT a
descendingTree [Int]
xs
-- This is the map called Lambda in Loday.pdf, or tau in MSym.pdf
-- It is an algebra morphism.

-- One of the ideas in the MSym paper is to look at the intermediate result (fmap descendingTree' x),
-- which is an "ordered tree", and consider the map as factored through this

-- The map is surjective but not injective. The fibers tau^-1(t) are intervals in the weak order on permutations

-- "inverse" for descendingTree
-- These are the maps called gamma in Loday.pdf
-- or are they? - these give the min and max inverse images in the lexicographic order, rather than the weak order?
minPerm :: PBT a -> [a]
minPerm t :: PBT a
t = PBT (a, a) -> [a]
forall a. Num a => PBT (a, a) -> [a]
minPerm' (PBT a -> PBT (a, a)
forall b a. Num b => PBT a -> PBT (b, b)
lrCountTree PBT a
t)
    where minPerm' :: PBT (a, a) -> [a]
minPerm' E = []
          minPerm' (T l :: PBT (a, a)
l (lc :: a
lc,rc :: a
rc) r :: PBT (a, a)
r) = PBT (a, a) -> [a]
minPerm' PBT (a, a)
l [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
lca -> a -> a
forall a. Num a => a -> a -> a
+a
rca -> a -> a
forall a. Num a => a -> a -> a
+1] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
forall a. Num a => a -> a -> a
+a
lc) (PBT (a, a) -> [a]
minPerm' PBT (a, a)
r)

maxPerm :: PBT a -> [a]
maxPerm t :: PBT a
t = PBT (a, a) -> [a]
forall a. Num a => PBT (a, a) -> [a]
maxPerm' (PBT a -> PBT (a, a)
forall b a. Num b => PBT a -> PBT (b, b)
lrCountTree PBT a
t)
    where maxPerm' :: PBT (a, a) -> [a]
maxPerm' E = []
          maxPerm' (T l :: PBT (a, a)
l (lc :: a
lc,rc :: a
rc) r :: PBT (a, a)
r) = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> a
forall a. Num a => a -> a -> a
+a
rc) (PBT (a, a) -> [a]
maxPerm' PBT (a, a)
l) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
lca -> a -> a
forall a. Num a => a -> a -> a
+a
rca -> a -> a
forall a. Num a => a -> a -> a
+1] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ PBT (a, a) -> [a]
maxPerm' PBT (a, a)
r


-- The composition of [1..n] obtained by treating each left-facing leaf as a cut
-- Specifically, we visit the nodes in infix order, cutting after a node if it does not have an E as its right child
-- This is the map called L in Loday.pdf
leftLeafComposition :: PBT a -> [Int]
leftLeafComposition E = []
leftLeafComposition t :: PBT a
t = [Bool] -> [Int]
cuts ([Bool] -> [Int]) -> [Bool] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Bool] -> [Bool]
forall a. [a] -> [a]
tail ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ PBT a -> [Bool]
forall a. PBT a -> [Bool]
leftLeafs PBT a
t
    where leftLeafs :: PBT a -> [Bool]
leftLeafs (T l :: PBT a
l x :: a
x E) = PBT a -> [Bool]
leftLeafs PBT a
l [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Bool
False]
          leftLeafs (T l :: PBT a
l x :: a
x r :: PBT a
r) = PBT a -> [Bool]
leftLeafs PBT a
l [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ PBT a -> [Bool]
leftLeafs PBT a
r
          leftLeafs E = [Bool
True]
          cuts :: [Bool] -> [Int]
cuts bs :: [Bool]
bs = case (Bool -> Bool) -> [Bool] -> ([Bool], [Bool])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Bool -> Bool
forall a. a -> a
id [Bool]
bs of
                    (ls :: [Bool]
ls,r :: Bool
r:rs :: [Bool]
rs) -> ([Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
ls Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Bool] -> [Int]
cuts [Bool]
rs
                    (ls :: [Bool]
ls,[]) -> [[Bool] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Bool]
ls]

leftLeafComposition' :: YSymF a -> QSymF
leftLeafComposition' (YSymF t :: PBT a
t) = [Int] -> QSymF
QSymF (PBT a -> [Int]
forall a. PBT a -> [Int]
leftLeafComposition PBT a
t)

-- |A Hopf algebra morphism from YSymF to QSymF
leftLeafCompositionMap :: (Eq k, Num k) => Vect k (YSymF a) -> Vect k QSymF
leftLeafCompositionMap :: Vect k (YSymF a) -> Vect k QSymF
leftLeafCompositionMap = Vect k QSymF -> Vect k QSymF
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k QSymF -> Vect k QSymF)
-> (Vect k (YSymF a) -> Vect k QSymF)
-> Vect k (YSymF a)
-> Vect k QSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (YSymF a -> QSymF) -> Vect k (YSymF a) -> Vect k QSymF
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YSymF a -> QSymF
forall a. YSymF a -> QSymF
leftLeafComposition'


-- The descent set of a permutation is [i | x_i > x_i+1], where we start the indexing from 1
descents :: [a] -> [Int]
descents [] = []
descents xs :: [a]
xs = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Bool -> [Bool] -> [Int]
forall a. Eq a => a -> [a] -> [Int]
L.elemIndices Bool
True ([Bool] -> [Int]) -> [Bool] -> [Int]
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> [a] -> [a] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>) [a]
xs ([a] -> [a]
forall a. [a] -> [a]
tail [a]
xs)

-- The composition of [1..n] obtained by treating each descent as a cut
descentComposition :: [a] -> [a]
descentComposition [] = []
descentComposition xs :: [a]
xs = a -> [a] -> [a]
forall a a. (Ord a, Num a) => a -> [a] -> [a]
descComp 0 [a]
xs where
    descComp :: a -> [a] -> [a]
descComp c :: a
c (x1 :: a
x1:x2 :: a
x2:xs :: [a]
xs) = if a
x1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x2 then a -> [a] -> [a]
descComp (a
ca -> a -> a
forall a. Num a => a -> a -> a
+1) (a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) else (a
ca -> a -> a
forall a. Num a => a -> a -> a
+1) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a -> [a] -> [a]
descComp 0 (a
x2a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
    descComp c :: a
c [x :: a
x] = [a
ca -> a -> a
forall a. Num a => a -> a -> a
+1]

-- |Given a permutation of [1..n], its descents are those positions where the next number is less than the previous number.
-- For example, the permutation [2,3,5,1,6,4] has descents from 5 to 1 and from 6 to 4. The descents can be regarded as cutting
-- the permutation sequence into segments - 235-16-4 - and by counting the lengths of the segments, we get a composition 3+2+1.
-- This map between bases SSymF -> QSymF turns out to induce a morphism of Hopf algebras.
descentMap :: (Eq k, Num k) => Vect k SSymF -> Vect k QSymF
descentMap :: Vect k SSymF -> Vect k QSymF
descentMap = Vect k QSymF -> Vect k QSymF
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k QSymF -> Vect k QSymF)
-> (Vect k SSymF -> Vect k QSymF) -> Vect k SSymF -> Vect k QSymF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SSymF -> QSymF) -> Vect k SSymF -> Vect k QSymF
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SSymF xs :: [Int]
xs) -> [Int] -> QSymF
QSymF ([Int] -> [Int]
forall a a. (Ord a, Num a) => [a] -> [a]
descentComposition [Int]
xs))
-- descentMap == leftLeafCompositionMap . descendingTreeMap

underComposition :: QSymF -> SSymF
underComposition (QSymF ps :: [Int]
ps) = (SSymF -> SSymF -> SSymF) -> SSymF -> [SSymF] -> SSymF
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SSymF -> SSymF -> SSymF
under ([Int] -> SSymF
SSymF []) [[Int] -> SSymF
SSymF [1..Int
p] | Int
p <- [Int]
ps]
    where under :: SSymF -> SSymF -> SSymF
under (SSymF xs :: [Int]
xs) (SSymF ys :: [Int]
ys) = let q :: Int
q = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ys
                                            zs :: [Int]
zs = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
q) [Int]
xs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
ys -- so it has a global descent at the split
                                        in [Int] -> SSymF
SSymF [Int]
zs
-- This is a poset morphism (indeed, it forms a Galois connection with descentComposition)
-- but it does not extend to a Hopf algebra morphism.
-- (It does extend to a coalgebra morphism.)
-- (It is picking the maximum permutation having a given descent composition,
-- so there's an element of arbitrariness to it.)
-- This is the map called Z (Zeta?) in Loday.pdf

{-
-- This is O(n^2), whereas an O(n) implementation should be possible
-- Also, we would really like the associated composition (obtained by treating each global descent as a cut)?
globalDescents xs = globalDescents' 0 [] xs
    where globalDescents' i ls (r:rs) = (if minimum (infinity:ls) > maximum (0:r:rs) then [i] else [])
                                     ++ globalDescents' (i+1) (r:ls) rs
          globalDescents' n _ [] = [n]
          infinity = maxBound :: Int
-- The idea is that this leads to a map from SSymM to QSymM

globalDescentComposition [] = []
globalDescentComposition (x:xs) = globalDescents' 1 x xs
    where globalDescents' i minl (r:rs) = if minl > maximum (r:rs)
                                          then i : globalDescents' 1 r rs
                                          else globalDescents' (i+1) r rs
          globalDescents' i _ [] = [i]

globalDescentMap :: (Eq k, Num k) => Vect k SSymM -> Vect k QSymM
globalDescentMap = nf . fmap (\(SSymM xs) -> QSymM (globalDescentComposition xs))
-}

-- A multiplication operation on trees
-- (Connected with their being cofree)
-- (intended to be used as infix)
under :: PBT a -> PBT a -> PBT a
under E t :: PBT a
t = PBT a
t
under (T l :: PBT a
l x :: a
x r :: PBT a
r) t :: PBT a
t = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l a
x (PBT a -> PBT a -> PBT a
under PBT a
r PBT a
t)

isUnderIrreducible :: PBT a -> Bool
isUnderIrreducible (T l :: PBT a
l x :: a
x E) = Bool
True
isUnderIrreducible _ = Bool
False

underDecomposition :: PBT a -> [PBT a]
underDecomposition (T l :: PBT a
l x :: a
x r :: PBT a
r) = PBT a -> a -> PBT a -> PBT a
forall a. PBT a -> a -> PBT a -> PBT a
T PBT a
l a
x PBT a
forall a. PBT a
E PBT a -> [PBT a] -> [PBT a]
forall a. a -> [a] -> [a]
: PBT a -> [PBT a]
underDecomposition PBT a
r
underDecomposition E = []


-- GHC7.4.1 doesn't like the following type signature - a bug.
-- ysymmToSh :: (Eq k, Num k) => Vect k (YSymM) => Vect k (Shuffle (PBT ()))
ysymmToSh :: f YSymM -> f (Shuffle (PBT ()))
ysymmToSh = (YSymM -> Shuffle (PBT ())) -> f YSymM -> f (Shuffle (PBT ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap YSymM -> Shuffle (PBT ())
ysymmToSh'
    where ysymmToSh' :: YSymM -> Shuffle (PBT ())
ysymmToSh' (YSymM t :: PBT ()
t) = [PBT ()] -> Shuffle (PBT ())
forall a. [a] -> Shuffle a
Sh (PBT () -> [PBT ()]
forall a. PBT a -> [PBT a]
underDecomposition PBT ()
t)
-- This is a coalgebra morphism (but not an algebra morphism)
-- It shows that YSym is co-free
{-
-- This one not working yet - perhaps it needs an nf, or to go via S/YSymF, or ...
ssymmToSh = nf . fmap ssymmToSh'
    where ssymmToSh' (SSymM xs) = (Sh . underDecomposition . shape . descendingTree) xs
-}

-- |The injection of Sym into QSym (defined over the monomial basis)
symToQSymM :: (Eq k, Num k) => Vect k SymM -> Vect k QSymM
symToQSymM :: Vect k SymM -> Vect k QSymM
symToQSymM = (SymM -> Vect k QSymM) -> Vect k SymM -> Vect k QSymM
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear SymM -> Vect k QSymM
forall k. (Eq k, Num k) => SymM -> Vect k QSymM
symToQSymM' where
    symToQSymM' :: SymM -> Vect k QSymM
symToQSymM' (SymM ps :: [Int]
ps) = [Vect k QSymM] -> Vect k QSymM
forall k b. (Eq k, Num k, Ord b) => [Vect k b] -> Vect k b
sumv [QSymM -> Vect k QSymM
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> QSymM
QSymM [Int]
c) | [Int]
c <- [Int] -> [[Int]]
forall a. Eq a => [a] -> [[a]]
compositionsFromPartition [Int]
ps]

-- We could equally well send NSym -> SymE, since the algebra and coalgebra definitions for SymE and SymH are exactly analogous.
-- However, NSym -> SymH is more natural, since it is consistent with the duality pairings below.
-- eg Hazewinkel 238ff
-- (Why do SymE and SymH have the same definitions? They're not dual bases. It's because of the Wronski relations.)
-- |A surjection of NSym onto Sym (defined over the complete basis)
nsymToSymH :: (Eq k, Num k) => Vect k NSym -> Vect k SymH
nsymToSymH :: Vect k NSym -> Vect k SymH
nsymToSymH = (NSym -> Vect k SymH) -> Vect k NSym -> Vect k SymH
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear NSym -> Vect k SymH
forall (m :: * -> *). Monad m => NSym -> m SymH
nsymToSym' where
    nsymToSym' :: NSym -> m SymH
nsymToSym' (NSym zs :: [Int]
zs) = SymH -> m SymH
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SymH
SymH ([Int] -> SymH) -> [Int] -> SymH
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sortDesc [Int]
zs)

-- The Hopf algebra morphism NSym -> Sym factors through NSym -> SSym -> YSym -> Sym (contained in QSym)
-- (?? This map NSym -> SSym is the dual of the descent map SSym -> QSym ??)
-- (Loday.pdf, p30)
-- (See also Hazewinkel p267-9)
nsymToSSym :: Vect k NSym -> Vect k SSymF
nsymToSSym = (NSym -> Vect k SSymF) -> Vect k NSym -> Vect k SSymF
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear NSym -> Vect k SSymF
forall (m :: * -> *). (Num (m SSymF), Monad m) => NSym -> m SSymF
nsymToSSym' where
    nsymToSSym' :: NSym -> m SSymF
nsymToSSym' (NSym xs :: [Int]
xs) = [m SSymF] -> m SSymF
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [SSymF -> m SSymF
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> SSymF
SSymF [1..Int
n]) | Int
n <- [Int]
xs]


-- |A duality pairing between the complete and monomial bases of Sym, showing that Sym is self-dual.
instance (Eq k, Num k) => HasPairing k SymH SymM where
    pairing :: Vect k (Tensor SymH SymM) -> Vect k ()
pairing = (Tensor SymH SymM -> Vect k ())
-> Vect k (Tensor SymH SymM) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor SymH SymM -> Vect k ()
forall p. Num p => Tensor SymH SymM -> p
pairing' where
        pairing' :: Tensor SymH SymM -> p
pairing' (SymH alpha :: [Int]
alpha, SymM beta :: [Int]
beta) = [Int] -> [Int] -> p
forall a p. (Eq a, Num p) => a -> a -> p
delta [Int]
alpha [Int]
beta -- Kronecker delta
-- Hazewinkel p178
-- Actually to show duality you would need to show that the map SymH -> SymM*, v -> <v,.> is onto

-- |A duality pairing between NSym and QSymM (monomial basis), showing that NSym and QSym are dual.
instance (Eq k, Num k) => HasPairing k NSym QSymM where
    pairing :: Vect k (Tensor NSym QSymM) -> Vect k ()
pairing = (Tensor NSym QSymM -> Vect k ())
-> Vect k (Tensor NSym QSymM) -> Vect k ()
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear Tensor NSym QSymM -> Vect k ()
forall p. Num p => Tensor NSym QSymM -> p
pairing' where
        pairing' :: Tensor NSym QSymM -> p
pairing' (NSym alpha :: [Int]
alpha, QSymM beta :: [Int]
beta) = [Int] -> [Int] -> p
forall a p. (Eq a, Num p) => a -> a -> p
delta [Int]
alpha [Int]
beta -- Kronecker delta
-- Hazewinkel p236-7
-- Actually to show duality you would need to show that the map NSym -> QSymM*, v -> <v,.> is onto