Operads-0.3: OperadTest.hs

import Test.QuickCheck
import Text.Printf
import Data.List (sort, nub)
import Data.Ord
import Control.Monad

import Math.Operad.OperadGB
import Math.Operad.PPrint
import Math.Operad.MapOperad
import Math.Operad.OrderedTree

main = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests

data ShuffleInput = SI (Int,Int,Int) deriving (Eq, Ord, Show, Read)

instance Arbitrary ShuffleInput where
    arbitrary = do
      n <- fmap ((+1) . abs) arbitrary -- at least one element!
      i <- choose (0,n)
      p <- choose (0,n-i)
      return $ SI (i, p, n-i-p)
    coarbitrary = undefined

{-
pdTree = sized spdTree where
    spdTree 0 = liftM leaf arbitrary
    spdTree n | n > 0 = oneof [liftM leaf arbitrary,
                               liftM2 (\l m -> DTVertex l m) arbitrary [spdTree (n `div` 2)]]
-}

newtype Tree = Tree (DecoratedTree Int) deriving (Ord, Eq, Show, Read)

instance PPrint Tree where
    pp (Tree t) = pp t

-- All shuffles are shuffles
prop_shufflesareshuffles (SI (i, p, q)) = all (\sh -> isShuffleIPQ sh i p)  (allShuffles i p q) 

-- The paper examples for the PathLex ordering
(.>.) s t = GT == (treeCompare PathLex s t)
--(.>..) s t = GT == (treeCompare ForestLex s t)
l1 = symmetricCompose 1 [1,2,3] (corolla 6 [1,2]) (corolla 5 [1,2])
l2 = symmetricCompose 1 [1,2,3] (corolla 3 [1,2]) (corolla 2 [1,2])
l3 = symmetricCompose 1 [1,2,3] (corolla 3 [1,2]) (corolla 2 [1,2])
l4 = symmetricCompose 1 [1,2,3] (corolla 2 [1,2]) (corolla 2 [1,2])
r1 = symmetricCompose 1 [1,3,2] (corolla 3 [1,2]) (corolla 2 [1,2])
r2 = symmetricCompose 1 [1,3,2] (corolla 3 [1,2]) (corolla 2 [1,2])
r3 = symmetricCompose 1 [1,3,2] (corolla 3 [1,2]) (corolla 2 [1,2])
r4 = symmetricCompose 1 [1,3,2] (corolla 3 [1,2]) (corolla 2 [1,2])

prop_paperpathlex1 = l1 .>. r1
prop_paperpathlex2 = l2 .>. r2
prop_paperpathlex3 = l3 .>. r3
{-
prop_paperforestlex1 = l1 .>.. r1
prop_paperforestlex2 = l2 .>.. r2
prop_paperforestlex3 = l3 .>.. r3
prop_paperforestlex4 = not $ l4 .>.. r4
-}
prop_anticom = let
    v = corolla 2 [1,2]
    g1t1 = nsCompose 1 v v
    g1t2 = nsCompose 2 v v
    g2t2 = shuffleCompose 1 [1,3,2] v v
    g1 = (oet g1t1) + (oet g1t2) :: OperadElement Integer Rational PathLex
    g2 = (oet g2t2) - (oet g1t2) :: OperadElement Integer Rational PathLex
    ac = [g1,g2]
  in (3==) . length . operadicBuchberger $ ac

prop_preliekoszul = let
    a = corolla 2 [1,2]
    b = corolla 1 [1,2]

    t1 = shuffleCompose 1 [1,2,3] a a
    t2 = shuffleCompose 2 [1,2,3] a a
    t3 = shuffleCompose 1 [1,3,2] a a
    t4 = shuffleCompose 2 [1,2,3] a b

    t5 = shuffleCompose 1 [1,2,3] a b
    t6 = shuffleCompose 1 [1,3,2] b a
    t7 = shuffleCompose 2 [1,2,3] b a
    t8 = shuffleCompose 1 [1,3,2] b b

    t9 = shuffleCompose 1 [1,3,2] a b
    ta = shuffleCompose 1 [1,2,3] b a
    tb = shuffleCompose 2 [1,2,3] b b
    tc = shuffleCompose 1 [1,2,3] b b

    g1 = (oet t1 ) - (oet t2 ) - (oet t3 ) + (oet t4 ) :: OperadElement Integer Rational PathLex
    g2 = (oet t5 ) - (oet t6 ) - (oet t7 ) + (oet t8 ) :: OperadElement Integer Rational PathLex
    g3 = (oet t9 ) - (oet ta ) - (oet tb ) + (oet tc ) :: OperadElement Integer Rational PathLex

    pl = [g1, g2, g3]
    plGB = operadicBuchberger pl
  in (length plGB == 3) && (([2]==) . sort . nub $ concatMap operationDegrees plGB)

prop_prelie = let
    a = corolla 1 [1,2]
    b = corolla 2 [1,2]

    t1 = shuffleCompose 1 [1,2,3] a a
    t2 = shuffleCompose 2 [1,2,3] a a
    t3 = shuffleCompose 1 [1,3,2] a a
    t4 = shuffleCompose 2 [1,2,3] a b

    t5 = shuffleCompose 1 [1,2,3] a b
    t6 = shuffleCompose 1 [1,3,2] b a
    t7 = shuffleCompose 2 [1,2,3] b a
    t8 = shuffleCompose 1 [1,3,2] b b

    t9 = shuffleCompose 1 [1,3,2] a b
    ta = shuffleCompose 1 [1,2,3] b a
    tb = shuffleCompose 2 [1,2,3] b b
    tc = shuffleCompose 1 [1,2,3] b b

    g1 = (oet t1 ) - (oet t2 ) - (oet t3 ) + (oet t4 ) :: OperadElement Integer Rational PathLex
    g2 = (oet t5 ) - (oet t6 ) - (oet t7 ) + (oet t8 ) :: OperadElement Integer Rational PathLex
    g3 = (oet t9 ) - (oet ta ) - (oet tb ) + (oet tc ) :: OperadElement Integer Rational PathLex

    pl = [g1, g2, g3]
    plGB = operadicBuchberger pl
  in (length plGB == 16) && (([2..6]==) . sort . nub $ concatMap operationDegrees plGB)


tests = [
        --("shuffles are shuffles", test prop_shufflesareshuffles),
        ("Paper example 1 for PathLex ordering",test prop_paperpathlex1),
        ("Paper example 2 for PathLex ordering",test prop_paperpathlex1),
        ("Paper example 3 for PathLex ordering",test prop_paperpathlex1),
{-
        ("Paper example 1 for ForestLex ordering",test prop_paperforestlex1),
        ("Paper example 2 for ForestLex ordering",test prop_paperforestlex2),
        ("Paper example 3 for ForestLex ordering",test prop_paperforestlex3),
        ("Paper example 4 for ForestLex ordering",test prop_paperforestlex4),
-}
        ("Anticommutative has 3 element basis",test prop_anticom),
--        ("Pre-Lie with the wrong order",test prop_prelie),
        ("Pre-Lie is Koszul",test prop_preliekoszul)
        ]