TCombinatorialHopfAlgebra.hs

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

{-# LANGUAGE FlexibleInstances #-}

module Math.Test.TCombinatorics.TCombinatorialHopfAlgebra where

import Data.List as L

import Math.Core.Field

import Math.Algebras.VectorSpace hiding (E)
import Math.Algebras.Structures

import Math.Combinatorics.CombinatorialHopfAlgebra

import Math.Test.TAlgebras.TVectorSpace hiding (T, f)
import Math.Test.TAlgebras.TTensorProduct
import Math.Test.TAlgebras.TStructures

import Test.QuickCheck
import Test.HUnit

quickCheckCombinatorialHopfAlgebra = do
    quickCheckShuffleAlgebra
    quickCheckSSymF
    quickCheckSSymM
    quickCheckYSymF
    quickCheckYSymM
    quickCheckQSymM
    quickCheckQSymF
    quickCheckCHAIsomorphism
    quickCheckCHAMorphism


instance Arbitrary a => Arbitrary (Shuffle a) where
    arbitrary = fmap (Sh . take 3) arbitrary

quickCheckShuffleAlgebra = do
    putStrLn "Checking shuffle algebra"
    -- quickCheck (prop_Algebra :: (Q, Vect Q (Shuffle Int), Vect Q (Shuffle Int), Vect Q (Shuffle Int)) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q (Shuffle Int) -> Bool)
    quickCheck (prop_Bialgebra :: (Q, Vect Q (Shuffle Int), Vect Q (Shuffle Int)) -> Bool) -- slow
    quickCheck (prop_HopfAlgebra :: Vect Q (Shuffle Int) -> Bool)


instance Arbitrary SSymF where
    arbitrary = do xs <- elements permsTo3
                   return (SSymF xs)
        where permsTo3 = concatMap (\n -> L.permutations [1..n]) [0..3]

instance Arbitrary SSymM where
    arbitrary = do xs <- elements permsTo3
                   return (SSymM xs)
        where permsTo3 = concatMap (\n -> L.permutations [1..n]) [0..3]

quickCheckSSymF = do
    putStrLn "Checking SSymF"
    -- quickCheck (prop_Algebra :: (Q, Vect Q SSymF, Vect Q SSymF, Vect Q SSymF) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q SSymF -> Bool)
    quickCheck (prop_Bialgebra :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool)
    quickCheck (prop_HopfAlgebra :: Vect Q SSymF -> Bool)

quickCheckSSymM = do
    putStrLn "Checking SSymM"
    -- quickCheck (prop_Algebra :: (Q, Vect Q SSymM, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q SSymM -> Bool)
    -- quickCheck (prop_Bialgebra :: (Q, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow
    quickCheck (prop_HopfAlgebra :: Vect Q SSymM -> Bool)


instance Arbitrary (YSymF ()) where
    arbitrary = fmap (YSymF . shape . descendingTree . take 3) (arbitrary :: Gen [Int])
-- We use descendingTree because it can make trees of interesting shapes from a given list
-- but we could equally have used other tree construction methods such as binary search tree

instance Arbitrary (YSymF Int) where
    arbitrary = fmap (YSymF . descendingTree . take 3) (arbitrary :: Gen [Int])
-- It seems to all work even if we leave the labels on. Perhaps we should really put random labels on though,
-- rather than leaving the descendingTree labels

instance Arbitrary (YSymM) where
    arbitrary = fmap (YSymM . shape . descendingTree . take 3) (arbitrary :: Gen [Int])

quickCheckYSymF = do
    putStrLn "Checking YSymF"
    -- quickCheck (prop_Algebra :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q (YSymF ()) -> Bool)
    quickCheck (prop_Bialgebra :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool)
    quickCheck (prop_HopfAlgebra :: Vect Q (YSymF ()) -> Bool)

quickCheckYSymM = do
    putStrLn "Checking YSymM"
    -- quickCheck (prop_Algebra :: (Q, Vect Q YSymM, Vect Q YSymM, Vect Q YSymM) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q YSymM -> Bool)
    -- quickCheck (prop_Bialgebra :: (Q, Vect Q YSymM, Vect Q YSymM) -> Bool)
    quickCheck (prop_HopfAlgebra :: Vect Q YSymM -> Bool)


instance Arbitrary QSymM where
    arbitrary = do xs <- elements compositionsTo3
                   return (QSymM xs)
        where compositionsTo3 = concatMap compositions [0..3]

instance Arbitrary QSymF where
    arbitrary = do xs <- elements compositionsTo3
                   return (QSymF xs)
        where compositionsTo3 = concatMap compositions [0..3]

quickCheckQSymM = do
    putStrLn "Checking QSymM"
    quickCheck (prop_Algebra :: (Q, Vect Q QSymM, Vect Q QSymM, Vect Q QSymM) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q QSymM -> Bool)
    quickCheck (prop_Bialgebra :: (Q, Vect Q QSymM, Vect Q QSymM) -> Bool)
    quickCheck (prop_HopfAlgebra :: (Vect Q QSymM) -> Bool)

quickCheckQSymF = do
    putStrLn "Checking QSymF"
    quickCheck (prop_Algebra :: (Q, Vect Q QSymF, Vect Q QSymF, Vect Q QSymF) -> Bool) -- too slow
    quickCheck (prop_Coalgebra :: Vect Q QSymF -> Bool)
    quickCheck (prop_Bialgebra :: (Q, Vect Q QSymF, Vect Q QSymF) -> Bool)
    quickCheck (prop_HopfAlgebra :: (Vect Q QSymF) -> Bool)

quickCheckCHAIsomorphism = do
    putStrLn "Checking CHA isomorphism (change of basis)"
    putStrLn "Checking bijections"
    quickCheck (prop_Id (toSSymF . toSSymM) :: Vect Q SSymF -> Bool)
    quickCheck (prop_Id (toSSymM . toSSymF) :: Vect Q SSymM -> Bool)
    quickCheck (prop_Id (toYSymF . toYSymM) :: Vect Q (YSymF ()) -> Bool)
    quickCheck (prop_Id (toYSymM . toYSymF) :: Vect Q YSymM -> Bool)
    quickCheck (prop_Id (toQSymF . toQSymM) :: Vect Q QSymF -> Bool)
    quickCheck (prop_Id (toQSymM . toQSymF) :: Vect Q QSymM -> Bool)
    putStrLn "Checking morphisms"
    putStrLn "SSym"
    -- quickCheck (prop_AlgebraMorphism toSSymF :: (Q, Vect Q SSymM, Vect Q SSymM) -> Bool) -- too slow
    -- quickCheck (prop_AlgebraMorphism toSSymM :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool) -- too slow
    quickCheck (prop_CoalgebraMorphism toSSymF :: Vect Q SSymM -> Bool)
    quickCheck (prop_CoalgebraMorphism toSSymM :: Vect Q SSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toSSymM :: Vect Q SSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toSSymF :: Vect Q SSymM -> Bool)
    putStrLn "YSym"
    -- quickCheck (prop_AlgebraMorphism toYSymF :: (Q, Vect Q YSymM, Vect Q YSymM) -> Bool) -- too slow
    quickCheck (prop_AlgebraMorphism toYSymM :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool)
    quickCheck (prop_CoalgebraMorphism toYSymF :: Vect Q YSymM -> Bool)
    quickCheck (prop_CoalgebraMorphism toYSymM :: Vect Q (YSymF ()) -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toYSymF :: Vect Q YSymM -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toYSymM :: Vect Q (YSymF ()) -> Bool)
    putStrLn "QSym"
    quickCheck (prop_AlgebraMorphism toQSymF :: (Q, Vect Q QSymM, Vect Q QSymM) -> Bool)
    quickCheck (prop_AlgebraMorphism toQSymM :: (Q, Vect Q QSymF, Vect Q QSymF) -> Bool)
    quickCheck (prop_CoalgebraMorphism toQSymF :: Vect Q QSymM -> Bool)
    quickCheck (prop_CoalgebraMorphism toQSymM :: Vect Q QSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toQSymM :: Vect Q QSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism toQSymF :: Vect Q QSymM -> Bool)
    where prop_Id f x = f x == x 

quickCheckCHAMorphism = do
    putStrLn "Checking morphisms between CHAs"
    quickCheck (prop_AlgebraMorphism descendingTreeMap :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool)
    quickCheck (prop_CoalgebraMorphism descendingTreeMap :: Vect Q SSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism descendingTreeMap :: Vect Q SSymF -> Bool)
    quickCheck (prop_AlgebraMorphism descentMap :: (Q, Vect Q SSymF, Vect Q SSymF) -> Bool)
    quickCheck (prop_CoalgebraMorphism descentMap :: Vect Q SSymF -> Bool)
    quickCheck (prop_HopfAlgebraMorphism descentMap :: Vect Q SSymF -> Bool)
    quickCheck (prop_AlgebraMorphism leftLeafCompositionMap :: (Q, Vect Q (YSymF ()), Vect Q (YSymF ())) -> Bool)
    quickCheck (prop_CoalgebraMorphism leftLeafCompositionMap :: Vect Q (YSymF ()) -> Bool)
    quickCheck (prop_HopfAlgebraMorphism leftLeafCompositionMap :: Vect Q (YSymF ()) -> Bool)
    quickCheck (\x -> descentMap x == (leftLeafCompositionMap . descendingTreeMap) (x :: Vect Q SSymF))
    -- Coalgebra morphisms showing that various Hopf algebras are cofree
    quickCheck (prop_CoalgebraMorphism ysymmToSh :: Vect Q YSymM -> Bool)


testlistCHA = TestList [
    TestCase $ assertEqual "toYSymF" (toYSymF $ ysymM $ T (T E () E) () (T (T E () E) () E))
               ( ysymF (T (T E () E) () (T (T E () E) () E)) - ysymF (T (T E () E) () (T E () (T E () E)))
               - ysymF (T E () (T E () (T (T E () E) () E))) + ysymF (T E () (T E () (T E () (T E () E)))) ), -- Loday.pdf, p10
    TestCase $ assertEqual "leftLeafComposition" [2,3,2,1]
               (leftLeafComposition $ T (T (T E 1 E) 2 (T (T E 3 E) 4 E)) 5 (T (T E 6 E) 7 (T E 8 E))) -- Loday.pdf, p6
    ]