Operads-0.7: 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]
    acGB = operadicBuchberger ac
  in ((3==) . length $ acGB) &&
     (sort acGB) == (sort . read $ "[OE (TM (fromList [(ST [[2],[2,2],[2,2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex),1 % 1),(ST [[2,2],[2,2],[2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 2]},DTLeaf 3]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[2],[2,2],[2,2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex),(-1) % 1),(ST [[2,2],[2],[2,2]] [1,3,2] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 3]},DTLeaf 2]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[2],[2,2],[2,2,2],[2,2,2]] [1,2,3,4] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTVertex {vertexType = 2, subTrees = [DTLeaf 3,DTLeaf 4]}]}]}) PathLex),1 % 1)]))]")

     
prop_noncom = let
    x = corolla 1 [1]
    y = corolla 2 [1]
    x2y = nsCompose 1 x (nsCompose 1 x y)
    xy2 = nsCompose 1 x (nsCompose 1 y y)
    xy = nsCompose 1 x y
    yx = nsCompose 1 y x
    one = head $ subTrees x
    ox2y = oet x2y  :: OperadElement Integer Rational PathLex
    oxy2 = oet xy2  :: OperadElement Integer Rational PathLex
    oxy = oet xy  :: OperadElement Integer Rational PathLex
    oyx = oet yx  :: OperadElement Integer Rational PathLex
    oone = oet one  :: OperadElement Integer Rational PathLex
    gb = [ox2y-oone, oxy2-oone, oxy-oyx]
  in (sort . operadicBuchberger $ gb) == (sort . read $ "[OE (TM (fromList [(ST [[]] [1] (OT (DTLeaf 1) PathLex),(-1) % 1),(ST [[1,1,1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}]}]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}) PathLex),(-1) % 1),(ST [[2]] [1] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[1,2]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1]}]}) PathLex),1 % 1),(ST [[2,1]] [1] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}]}) PathLex),(-1) % 1)]))]" :: [OperadElement Integer Rational PathLex])


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),
        ("Sample non-commutative algebra grobner basis",test prop_noncom)
        ]