Operads 0.7 → 1.0

raw patch · 14 files changed

+611/−446 lines, 14 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG +59/−0
• Math/Operad.hs +5/−17
• Math/Operad/MapOperad.hs +4/−0
• Math/Operad/OperadGB.hs +305/−165
• Math/Operad/OrderedTree.hs +114/−57
• Math/Operad/PPrint.hs +25/−2
• Math/Operad/PolyBag.hs +0/−117
• OperadTest.hs +23/−54
• Operads.cabal +13/−16
• README +1/−1
• examples/Alternative.hs +45/−0
• examples/altDual.hs +2/−2
• examples/example.hs +12/−12
• examples/preLieBad.hs +3/−3

@@ -1,3 +1,62 @@+Changes 0.7 -> 1.0+Fri Aug 14 13:59:24 IST 2009  mik@stanford.edu+  * Adapted tests to computing reduced Grobner bases.+  * Fixed README import example.+  * Added the Alternative operad as an example.+  * Adapted tests to API changes.+  * Removed non-used or badly written tests.+  * Refactored reduceBasis to do full reductions, with list reversals, and to include a type signature.+  * Pre-reduce input basis to operadicBuchberger.+  * Clean compile with -Wall+  * Examples all compile.+  * Refactored orderings applied to the examples.+  * Introduce non-symmetric Grobner basis computation. Refactor streamReduceBasis -> reduceBasis.+  * Types and comments completed.+  * Cleaning up monomial orderings, completing the list.+  * Removed the PolyBag implementation.++Thu Aug 13 14:26:33 IST 2009  mik@stanford.edu+  * Pretty printing no longer hangs waiting on the next element in a list.+  * allShuffles delegates to Dotsenko's shuffle permutations algorithm.+  * Fixed basisElements to a more efficient version.+  * Introduce reductions for the stable elements in the streamOperadicBuchberger pipeline+  * Zero elements of the generating set no longer break reduceCompletely+  * Sign mangling in reduceOE fixed.+  * Operadic Buchberger with lazy evaluation in place.+  * Extended traceing.+  * Fixed bad ordering of the SCM embeddings.+  * Fixed reconstructNode.+  * Fixed equivalentOrders+  * Safeguards to findBoundedSCM+  * Refactored findRootedEmbedding++Wed Aug 12 22:59:42 IST 2009  mik@stanford.edu+  * Fixing reductions.++Tue Aug 11 15:52:07 IST 2009  mik@stanford.edu+  * S Polynomials now use the right embeddings for the SCMs.+  * Improved algorithms for listing shuffle permutations and for constructing small common multiples.+  * Additional PPrint instances.+  * Mapping a function over all internal vertex labels.+  * Division methods.++Sun Aug  9 22:24:35 IST 2009  mik@stanford.edu+  * Fixing too large findAllLCM issue.+  The issue, as reported by Vladimir Dotsenko, was that the function findAllLCM would return many too many+  LCMs for even the simplest examples.+  +  It turned out that the filters excluding too many LCMs were erroneously written - we expect the deep +  implementations, findSmallBoundedLCM, to return LCMs with the second argument, t, +  occurring with root shared with the root of the LCM, and the first argument, s, to occur higher up in +  the tree.+  +  If findAllLCM was called with both arguments identical, the filtering code would identify s dividing the+  entire tree, missing that it occurs as a rooted divisor.++  * Updated changelog+++ Changes 0.6 -> 0.7 Sun May  3 22:18:13 CEST 2009  mik@stanford.edu   * Stopped building test file - bug report from dons

@@ -2,13 +2,7 @@ -- Released under a BSD license  module Math.Operad (module Math.Operad.PPrint, -#if defined USE_MAPOPERAD                     module Math.Operad.MapOperad,-#elif defined USE_POLYBAG-                    module Math.Operad.PolyBag,-#else-                    module Math.Operad.MapOperad,-#endif                     module Math.Operad.OrderedTree,                     module Math.Operad.OperadGB,                     m12_3,@@ -24,16 +18,10 @@ import Math.Operad.OperadGB import Math.Operad.OrderedTree import Math.Operad.PPrint-#if defined USE_MAPOPERAD import Math.Operad.MapOperad-#elif defined USE_POLYBAG-import Math.Operad.PolyBag-#else-import Math.Operad.MapOperad-#endif  type Tree = DecoratedTree Integer-type FreeOperad a = OperadElement a Rational PathLex+type FreeOperad a = OperadElement a Rational PathPerm  -- ** Examples and useful predefined operad elements. @@ -63,17 +51,17 @@  -- The Lie operad example computation -lo1 :: OperadElement Integer Rational PathLex+lo1 :: OperadElement Integer Rational PathPerm lo1 = oet m12_3 -lo2 :: OperadElement Integer Rational PathLex+lo2 :: OperadElement Integer Rational PathPerm lo2 = oet m13_2 -lo3 :: OperadElement Integer Rational PathLex+lo3 :: OperadElement Integer Rational PathPerm lo3 = oet m1_23  -- | The list of operad elements consisting of 'm12_3'-'m13_2'-'m1_23'. This generates the  -- ideal of relations for the operad Lie.-lgb :: [OperadElement Integer Rational PathLex]+lgb :: [OperadElement Integer Rational PathPerm] lgb = [lo1 - lo2 - lo3] 

@@ -88,6 +88,10 @@ isZero :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> Bool isZero (OE m) = Map.null $ Map.filter (/=0) m +-- | Extract the leading term of an operad element as an operad element.+leadingOTerm :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> OperadElement a n t+leadingOTerm om = oe [leadingTerm om]+ -- | Extract the leading term of an operad element.  leadingTerm :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> (OrderedTree a t, n) leadingTerm (OE om) = fromMaybe (ot (leaf 0), 0) $ do 

@@ -7,19 +7,13 @@ module Math.Operad.OperadGB where  import Prelude hiding (mapM, sequence)-import Data.List (sort, sortBy, findIndex, nub, (\\), permutations)+import Data.List (sort, sortBy, findIndex, nub, (\\)) import Data.Ord import Data.Foldable (foldMap, Foldable) import Control.Monad hiding (mapM) import Data.Maybe -#if defined USE_MAPOPERAD import Math.Operad.MapOperad-#elif defined USE_POLYBAG-import Math.Operad.PolyBag-#else-import Math.Operad.MapOperad-#endif  import Math.Operad.OrderedTree @@ -151,10 +145,18 @@ -- is guaranteed to restore the original leaf labels before the search. type Embedding a = DecoratedTree (Maybe a) --- | Returns True if there is a subtree of @t@ isomorphic to s, respecting leaf orders. +-- | Returns True if there is a subtree of @t@ isomorphic to @s@, respecting leaf orders.  divides :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Bool divides s t = not . null $ findAllEmbeddings s t +-- | Returns True if there is a subtree of @t@ isomorphic to @s@, respecting leaf orders, and not located at the root.+dividesHigh :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Bool+dividesHigh s t = not . null $ concatMap (findAllEmbeddings s) (subTrees t)++-- | Returns True if there is a rooted subtree of @t@ isomorphic to @s@, respecting leaf orders.+dividesRooted :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Bool+dividesRooted s t = isJust $ findRootedEmbedding s t+ -- | Finds all ways to embed s into t respecting leaf orders. findAllEmbeddings :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> [Embedding a] findAllEmbeddings _ (DTLeaf _) = []@@ -169,106 +171,180 @@       in map glueTree ems   in rootFind ++ concatMap reGlue (zip [1..] subFinds)     --- | Finds all ways to embed s into t, respecting leaf orders and mapping the root of s to the root of t.-findRootedEmbedding :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Maybe (Embedding a)-findRootedEmbedding (DTLeaf _) t = Just (DTVertex Nothing [toJustTree t])-findRootedEmbedding (DTVertex _ _) (DTLeaf _) = Nothing-findRootedEmbedding s t = do+-- | Helper function for 'findRootedEmbedding'.+findUnsortedRootedEmbedding :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Maybe (Embedding a)+findUnsortedRootedEmbedding (DTLeaf _) t = Just (DTVertex Nothing [toJustTree t])+findUnsortedRootedEmbedding (DTVertex _ _) (DTLeaf _) = Nothing+findUnsortedRootedEmbedding s t = do   guard $ vertexArity s == vertexArity t   guard $ vertexType s == vertexType t-  guard $ equivalentOrders (map minimalLeaf (subTrees s)) (map minimalLeaf (subTrees t))-  let mTreeFinds = zipWith findRootedEmbedding (subTrees s) (subTrees t)+  let mTreeFinds = zipWith findUnsortedRootedEmbedding (subTrees s) (subTrees t)   guard $ all isJust mTreeFinds   let treeFinds = map fromJust mTreeFinds   guard $ all (isNothing . vertexType) treeFinds   guard $ equivalentOrders (leafOrder s) (concatMap (map minimalLeaf . subTrees) treeFinds)-  return $ DTVertex Nothing (sortBy (comparing minimalLeaf) (concatMap subTrees treeFinds))---- | Finds a large common divisor of two trees, such that it embeds into both trees, mapping its root --- to the roots of the trees, respectively. -findRootedDecoratedGCD :: (Ord a, Show a) => -         DecoratedTree a -> DecoratedTree a -> Maybe (PreDecoratedTree a (DecoratedTree a,DecoratedTree a))-findRootedDecoratedGCD (DTLeaf k) t = Just $ DTLeaf (DTLeaf k, t)-findRootedDecoratedGCD s (DTLeaf k) = Just $ DTLeaf (s, DTLeaf k)-findRootedDecoratedGCD s t = do-  guard $ vertexArity s == vertexArity t-  guard $ vertexType s == vertexType t-  let mrdGCDs = zipWith findRootedDecoratedGCD (subTrees s) (subTrees t)-  guard $ all isJust mrdGCDs-  let rdGCDs = map fromJust mrdGCDs-  return $ DTVertex (vertexType s) rdGCDs---- | Finds all small common multiples of trees s and t, under the assumption that the common multiples shares--- root with both trees.-findRootedLCM :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]-findRootedLCM s t = filter (\tree -> divides s tree && divides t tree) $-    if operationDegree s < operationDegree t then findRootedLCM t s -    else -        do-  let mrdGCD = findRootedDecoratedGCD s t-  guard $ isJust mrdGCD -  let rdGCD = fromJust mrdGCD-      leafDecorations = foldMap (:[]) rdGCD-      rebuildRecipe = reverse . sortBy (comparing fst) $ filter (isLeaf . fst) leafDecorations-  accumulateTrees rebuildRecipe [s]+  return $ DTVertex Nothing (concatMap subTrees treeFinds) --- | Internal utility function. Reassembles a tree according to a "building recipe", and gives the orbit--- of the resulting tree under the symmetric group action back.-accumulateTrees :: (Ord a, Show a) => -                   [(DecoratedTree a, DecoratedTree a)] -> [DecoratedTree a] -> [DecoratedTree a]-accumulateTrees [] partialTrees = partialTrees-accumulateTrees ((aLeaf,tree):rs) partialTrees = -    if not $ isLeaf aLeaf then error "Should have a leaf" else-        let-            newTrees = do-              partialTree <- partialTrees-              let idx = minimalLeaf aLeaf-                  newTree = rePackLabels tree-                  packedPartialTree = rePackLabels partialTree-                  lookupList = zip (leafOrder partialTree) (leafOrder packedPartialTree)-                  i = fromJust $ lookup idx lookupList-              return $ nsCompose i packedPartialTree newTree-          in-            do-              t <- accumulateTrees rs newTrees-              p <- permutations [1..nLeaves t]-              let returnTree = relabelLeaves t p-              guard $ planarTree returnTree-              return $ returnTree+-- | Finds all ways to embed s into t, respecting leaf orders and mapping the root of s to the root of t.+findRootedEmbedding :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Maybe (Embedding a)+findRootedEmbedding s t = do+  re <- findUnsortedRootedEmbedding s t+  return $ DTVertex Nothing (sortBy (comparing minimalLeaf) (subTrees re))  -- | Checks a tree for planarity. planarTree :: (Ord a, Show a) => DecoratedTree a -> Bool planarTree (DTLeaf _) = True planarTree (DTVertex _ subs) = all planarTree subs && isSorted (map minimalLeaf subs) --- | Finds all small common multiples of s and t such that t glues into s from above, bounded in total operation degree.-findSmallBoundedLCM :: (Ord a, Show a) => Int -> DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]-findSmallBoundedLCM _ (DTLeaf _) _ = []-findSmallBoundedLCM _ _ (DTLeaf _) = []-findSmallBoundedLCM 0 _ _ = []-findSmallBoundedLCM n s t = nub $ filter (divides s) $ filter (isJust . findRootedEmbedding t) $ do-  -- find rLCMs of s and t.-  -- find LCMs of all subtrees of s with t-  -- for those, reglue the rest of t-  let rootedLCMs = if (operationDegree s) > n || (operationDegree t) > n then [] else findRootedLCM s t-      childLCMs = map (findSmallBoundedLCM (n-1) s) (subTrees t)-      reGlue (i,ems) = if i > length (subTrees t) then error "Too high composition point, findSmallLCM:reGlue" else let-                    template = rePackLabels $  -                               DTVertex -                               (vertexType t) -                               (take (i-1) (subTrees t) ++ [leaf (minimalLeaf (subTrees t !! (i-1)))] ++ drop i (subTrees t))-                  in concatMap (\emt -> accumulateTrees [(leaf i,emt)] [template]) ems-      zippedChildLCMs = zip [1..] childLCMs-  filter ((<=n) . operationDegree) rootedLCMs ++ (concatMap reGlue zippedChildLCMs)+-- | Returns True if s and t divide u, with different embeddings and t sharing root with u.+dividesDifferent :: (Ord a, Show a) => +                    DecoratedTree a -> DecoratedTree a -> DecoratedTree a -> Bool+dividesDifferent s t u = dividesRooted t u && +                         if s /= t +                         then+                             divides s u+                         else+                             dividesHigh s u --- | Finds all small common multiples of s and t.-findAllLCM :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]-findAllLCM s t = (findSmallBoundedLCM maxBound s t) ++ (findSmallBoundedLCM maxBound t s) --- | Finds all small common multiples of s and t, bounded in total operation degree. -findAllBoundedLCM :: (Ord a, Show a) => Int -> DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]-findAllBoundedLCM n s t = (findSmallBoundedLCM n s t) ++ (findSmallBoundedLCM n t s) +-- | Interchanges @Left@ to @Right@ and @Right@ to @Left@ for types @Either a a@+flipEither :: Either a a -> Either a a+flipEither (Left a) = Right a+flipEither (Right a) = Left a++-- | Projects the type @Either a a@ onto the type @a@ in the obvious manner.+stripEither :: Either a a -> a+stripEither (Left a) = a+stripEither (Right a) = a++-- | Applies @flipEither@ to the root vertex label of a tree.+flipEitherRoot :: (Ord a, Show a) =>  PreDecoratedTree (Either a a) b -> PreDecoratedTree (Either a a) b+flipEitherRoot l@(DTLeaf _) = l+flipEitherRoot (DTVertex t ts) = DTVertex (flipEither t) ts++-- | Projects vertex labels and applies leaf labels to a tree with internal labeling in @Either a a@.+fuseTree :: (Ord a, Show a) => DecoratedTree (Either a a) -> [Int] -> DecoratedTree (Either a a)+fuseTree t ls = flip relabelLeaves ls $ t++-- | Strips the @Either@ layer from internal vertex labels+stripTree :: (Ord a, Show a) => DecoratedTree (Either a a) -> DecoratedTree a+stripTree = vertexMap stripEither++-- | Acquires lists for resorting leaf labels according to the algorithm found for+-- constructing small common multiples with minimal work.+leafOrders :: (Ord a, Show a, Ord b, Show b) => DecoratedTree a -> DecoratedTree b -> [(Int,Int)]+leafOrders (DTLeaf si) u = [(si,minimalLeaf u)]+leafOrders s (DTLeaf ui) = [(minimalLeaf s, ui)]+leafOrders s u = concat $ zipWith leafOrders (subTrees s) (subTrees u)++-- | Locates the first vertex tagged with a @Right@ constructor in a tree labeled with @Either a b@.+findFirstRight :: (Ord a, Show a, Ord b, Show b) => DecoratedTree (Either a b) -> Maybe (DecoratedTree (Either a b))+findFirstRight (DTLeaf _) = Nothing+findFirstRight (DTVertex (Left _) ts) =  listToMaybe $ mapMaybe findFirstRight ts+findFirstRight v@(DTVertex (Right _) _) = Just v++-- | Equivalent to listToMaybe . reverse+maybeLast :: [a] -> Maybe a+maybeLast [] = Nothing+maybeLast as = Just $ last as++-- | Recursive algorithm to figure out correct leaf labels for a reconstructed small common multiple of two trees.+leafLabels :: (Ord a, Show a) =>+              DecoratedTree a -> [Int] -> [Int] -> [[Int]]+leafLabels u tl1 tl2 = let+    leafLabelsAcc :: Int -> [([Int], [Int], [Int])] -> [[Int]]+    leafLabelsAcc 0 accs = map (\(_,_,a) -> a) accs+    leafLabelsAcc n accs = let+        newaccs = do+          (tau1,tau2,out) <- accs+          let+              t1 = maybeLast tau1+              t2 = maybeLast tau2+              tt1 = if isNothing t1 || (fromJust t1) `elem` take (length tau2 - 1) tau2 then [] else maybeToList t1+              tt2 = if isNothing t2 || (fromJust t2) `elem` take (length tau1 - 1) tau1 then [] else maybeToList t2+              tt = nub $ tt1 ++ tt2+          t <- tt+          return $ (tau1 \\ [t], tau2 \\ [t], applyAt (const n) t out)+      in leafLabelsAcc (n-1) newaccs+  in leafLabelsAcc (nLeaves u) [(tl1, tl2, (replicate (nLeaves u) 0))]++-- | Finds rooted small common multiples of two trees.+findRootedSCM :: (Ord a, Show a) => +                 DecoratedTree a -> DecoratedTree a -> Maybe (DecoratedTree a)+findRootedSCM s (DTLeaf _) = Just s+findRootedSCM (DTLeaf _) t = Just t+findRootedSCM s t = do+  guard $ vertexType s == vertexType t+  let stSCMs = zipWith findRootedSCM (subTrees s) (subTrees t)+  guard $ all isJust stSCMs+  let stSCM = map fromJust stSCMs+  return $ relabelLeaves (DTVertex (vertexType s) (stSCM)) [1..]++-- | Finds structural small common multiples, disregarding leaf labels completely.+findNonSymmetricSCM :: (Ord a, Show a) =>+                       Int -> DecoratedTree (Either a a) -> DecoratedTree (Either a a) -> [DecoratedTree (Either a a)]+findNonSymmetricSCM _ _ (DTLeaf _) = []+findNonSymmetricSCM _ (DTLeaf _) _ = []+findNonSymmetricSCM 0 _ _ = []+findNonSymmetricSCM n s t = let+      rootedSCMs = if (operationDegree s) > n || (operationDegree t) > n then [] +                   else maybeToList $ fmap flipEitherRoot $ findRootedSCM s t+      childSCMs = map (findNonSymmetricSCM (n-1) s) (subTrees t)+      zippedChildSCMs = zip [0..] childSCMs+      zippedChildren = do +        (i, cSCMs) <- zippedChildSCMs+        child <- cSCMs+        return $ DTVertex (vertexType t) (applyAt (const child) i (subTrees t))+  in nub $ map (flip relabelLeaves [1..]) $ rootedSCMs ++ zippedChildren++-- | Finds small common multiples of two trees bounding internal operation degree.+findBoundedSCM :: (Ord a, Show a) => Int -> DecoratedTree a -> DecoratedTree a -> [DecoratedTree (Either a a)]+findBoundedSCM n s t = do +  em <- findNonSymmetricSCM n (vertexMap Left s) (vertexMap Left t)+  guard $ isJust $ findFirstRight em+  let lot = leafOrders t em+      los = leafOrders s (fromJust $ findFirstRight em)+      tau1 = map (subtract 1) $ map snd $ sort lot+      tau2 = map (subtract 1) $ map snd $ sort los+  leaves <- nub $ leafLabels em tau1 tau2+  let retTree = fuseTree em leaves+  guard $ operationDegree retTree <= n+  return retTree++-- | Finds all small common multiples of two trees.+findAllSCM :: (Ord a, Show a) =>+              DecoratedTree a -> DecoratedTree a -> [DecoratedTree (Either a a)]+findAllSCM s t = nub $ (findBoundedSCM maxBound s t)++-- | Finds all small common multiples of two trees, bounding the internal operation degree.+findAllBoundedSCM :: (Ord a, Show a) =>+                     Int -> DecoratedTree a -> DecoratedTree a -> [DecoratedTree (Either a a)]+findAllBoundedSCM n s t = nub $ (findBoundedSCM n s t)++-- | Constructs embeddings for @s@ and @t@ in @SCM(s,t)@ and returns these.+scmToEmbedding :: (Ord a, Show a) => +                  DecoratedTree (Either a a) -> DecoratedTree a -> DecoratedTree a -> (Embedding a, Embedding a)+scmToEmbedding scm s t = let+    lEm = findRootedEmbedding t (stripTree scm)+  --findHighEmbedding :: DecoratedTree (Either a a) -> Maybe (Embedding a)+    findHighEmbedding (DTLeaf _) = Nothing+    findHighEmbedding (DTVertex (Left tp) ts) = Just $ +                                               DTVertex +                                               (Just tp) +                                               (zipWith (\ss tt -> if isJust ss then fromJust ss else tt) +                                                            (map findHighEmbedding ts) +                                                            (map (vertexMap Just) $ map stripTree ts))+    findHighEmbedding v@(DTVertex (Right _) _) = findRootedEmbedding s (stripTree v)+    rEm = findHighEmbedding scm+  in if isNothing lEm || isNothing rEm +     then error ("Bad SCM in scmToEmbedding" +#ifdef TRACE+                 ++ ": lEm is " ++ pp lEm ++ " and rEm is " ++ pp rEm ++ " for\n\t" ++ show s ++ "\n\t" ++ show t ++ "\n\t" ++ show scm+#endif+                )+     else (fromJust lEm, fromJust rEm)+ -- | Relabels a tree in the right order, but with entries from [1..] rePackLabels :: (Ord a, Show a, Ord b) => PreDecoratedTree a b -> DecoratedTree a rePackLabels tree = fmap (fromJust . (flip lookup (zip (sort (foldMap (:[]) tree)) [1..]))) tree@@ -294,7 +370,11 @@ -- | Verifies that two integer sequences correspond to the same total ordering of the entries. equivalentOrders :: [Int] -> [Int] -> Bool equivalentOrders o1 o2 = if length o1 /= length o2 then False -           else and $ zipWith (==) (zipWith compare o1 (tail o1)) (zipWith compare o2 (tail o2))+                         else let+                             c1 = map snd . sort . zip o1 $ [(1::Int)..]+                             c2 = map snd . sort . zip o2 $ [(1::Int)..]+                           in+                             c1 == c2  -- | Returns True if any of the vertices in the given tree has been tagged. subTreeHasNothing :: (Ord a, Show a) => DecoratedTree (Maybe a) -> Bool@@ -312,12 +392,11 @@                                 newSubTrees = map fromJustTree (subTrees super)                            in                              if any isNothing newSubTrees then Nothing-                                else let-                                    newTrees = map fromJust newSubTrees-                                    leafs = concatMap leafOrder newTrees-                                    newTree = nsComposeAll sub newTrees+                             else let+                                 base = rePackLabels sub+                                 newTrees = map fromJust newSubTrees                                in-                                 Just $ fmap ((leafs!!) . (subtract 1)) newTree+                                 Just $ glueTrees $ fmap ((newTrees !!) . (subtract 1)) base  -- | The function that mimics resubstitution of a new tree into the hole left by finding embedding, -- called m_\alpha,\beta in Dotsenko-Khoroshkin. This version recurses down in the tree in order@@ -358,17 +437,40 @@ findInitialSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) =>                            Int -> [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t] findInitialSPolynomials n oldGb newGb = nub . map (\o -> (1/leadingCoefficient o) .*. o) . filter (not . isZero) $ do-  g1 <- oldGb ++ newGb-  g2 <- newGb-  let lmg1 = leadingMonomial g1+    g1 <- oldGb ++ newGb+    g2 <- newGb+    findSPolynomials n g1 g2 ++ findSPolynomials n g2 g1++-- | Finds all S polynomials for a given pair of operad elements, keeping a bound on operation degree.+findSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) =>+                           Int -> OperadElement a n t -> OperadElement a n t -> [OperadElement a n t]+findSPolynomials n g1 g2 = do+    let +        lmg1 = leadingMonomial g1+        lmg2 = leadingMonomial g2+        cf12 = (leadingCoefficient g1) / (leadingCoefficient g2)+    scm <- findAllBoundedSCM n lmg1 lmg2+    let (mg2, mg1) = scmToEmbedding scm lmg1 lmg2+    return $ (applyReconstruction mg1 g1) - (cf12 .*. (applyReconstruction mg2 g2))++-- | Non-symmetric version of 'findInitialSPolynomials'.+findNSInitialSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) =>+                           Int -> [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+findNSInitialSPolynomials n oldGB newGB = nub . map (\o -> (1/leadingCoefficient o) .*. o) . filter (not . isZero) $ do+    g1 <- oldGB ++ newGB+    g2 <- newGB+    findNSSPolynomials n g1 g2 ++ findNSSPolynomials n g2 g1++-- | Non-symmetric version of 'findSPolynomials'.+findNSSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) =>+                           Int -> OperadElement a n t -> OperadElement a n t -> [OperadElement a n t]+findNSSPolynomials n g1 g2 = do+  let +      lmg1 = leadingMonomial g1       lmg2 = leadingMonomial g2       cf12 = (leadingCoefficient g1) / (leadingCoefficient g2)-  gamma <- nub $ findAllBoundedLCM n lmg1 lmg2-#ifdef TRACE-  trace ("Found LCM: \n\t" ++ pp lmg1 ++ ", \n\t" ++ pp lmg2 ++ ": \n\t" ++ pp gamma ++ "\n") (return ())-#endif-  mg1 <- findAllEmbeddings lmg1 gamma-  mg2 <- findAllEmbeddings lmg2 gamma+  scm <- findNonSymmetricSCM n (vertexMap Left lmg1) (vertexMap Left lmg2)+  let (mg2,mg1) = scmToEmbedding scm lmg1 lmg2   return $ (applyReconstruction mg1 g1) - (cf12 .*. (applyReconstruction mg2 g2))  -- | Reduce g with respect to f and the embedding em: lt f -> lt g.@@ -379,11 +481,12 @@                       cgf = (leadingCoefficient g) / (leadingCoefficient f)                       ret = g - (cgf .*. (applyReconstruction em f))                     in-                      if isZero ret then ret else (1/leadingCoefficient ret) .*. ret+                      ret -reduceCompletely :: (Ord a, Show a, TreeOrdering t, Fractional n) => OperadElement a n t -> [OperadElement a n t] -> OperadElement a n t-reduceCompletely op [] = op-reduceCompletely op gb = if isZero op +-- | Reduce the leading monomial of @op@ with respect to @gb@.+reduceInitial :: (Ord a, Show a, TreeOrdering t, Fractional n) => OperadElement a n t -> [OperadElement a n t] -> OperadElement a n t+reduceInitial op [] = op+reduceInitial op gb = if isZero op                           then op                           else let                              divisorIdx = findIndex (flip divides (leadingMonomial op)) (map leadingMonomial gb)@@ -395,14 +498,30 @@                                  em = head $ findAllEmbeddings (leadingMonomial g1) (leadingMonomial op)                                  o1 = reduceOE em g1 op                                 in -                                 reduceCompletely o1 gb+                                 reduceInitial o1 gb +-- | Reduce all terms of @op@ with respect to @gbn@.+reduceCompletely :: (Ord a, Show a, TreeOrdering t, Fractional n) => OperadElement a n t -> [OperadElement a n t] -> OperadElement a n t+reduceCompletely op [] = op+reduceCompletely op gbn = +    if isZero op then op+    else let+        gb = filter (not . isZero) gbn+        nop = reduceInitial op gb+      in+        if nop == op then leadingOTerm op + (reduceCompletely (op - (leadingOTerm op)) gb)+        else reduceCompletely nop gb+ -- | Perform one iteration of the Buchberger algorithm: generate all S-polynomials. Reduce all S-polynomials. -- Return anything that survived the reduction. stepOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) =>                            [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t] stepOperadicBuchberger oldGb newGb = stepInitialOperadicBuchberger maxBound oldGb newGb +stepNSOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) => +                          [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+stepNSOperadicBuchberger oldGB newGB = stepNSInitialOperadicBuchberger maxBound oldGB newGB+ -- | Perform one iteration of the Buchberger algorithm: generate all S-polynomials. Reduce all S-polynomials. -- Return anything that survived the reduction. Keep the occurring operation degrees bounded.  stepInitialOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) => @@ -414,53 +533,82 @@   spol <- findInitialSPolynomials maxD oldGb newGb   guard $ maxOperationDegree spol <= maxD   let red = -#ifdef TRACE-          trace ("Reducing S-polynomial: " ++ pp spol ++ "\n") $-#endif           reduceCompletely spol (oldGb ++ newGb)   guard $ not . isZero $ red   return red +-- | Non-symmetric version of 'stepInitialOperadicBuchberger'.+stepNSInitialOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) => +                          Int -> [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+stepNSInitialOperadicBuchberger maxD oldGb newGb =+    nub $ +    filter (not . isZero) $ +    do+  spol <- findNSInitialSPolynomials maxD oldGb newGb+  guard $ maxOperationDegree spol <= maxD+  let red = +          reduceCompletely spol (oldGb ++ newGb)+  guard $ not . isZero $ red+  return red+                           -- | Perform the entire Buchberger algorithm for a given list of generators. Iteratively run the single iteration -- from 'stepOperadicBuchberger' until no new elements are generated. -- -- DO NOTE: This is entirely possible to get stuck in an infinite loop. It is not difficult to write down generators -- such that the resulting Groebner basis is infinite. No checking is performed to catch this kind of condition. operadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) => [OperadElement a n t] -> [OperadElement a n t]-operadicBuchberger gb = nub $ initialOperadicBuchberger maxBound gb+operadicBuchberger gb = nub $ streamOperadicBuchberger maxBound (reduceBasis [] gb) --- | Perform the entire Buchberger algorithm for a given list of generators. Iteratively run the single iteration--- from 'stepOperadicBuchberger' until no new elements are generated. While doing this, maintain an upper bound--- on the operation degree of any elements occurring.----initialOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) =>-                             Int -> [OperadElement a n t] -> [OperadElement a n t]-initialOperadicBuchberger maxOD gb = let-    operadicBuchbergerAcc oldgb [] = oldgb-    operadicBuchbergerAcc oldgb new = if minimum (map maxOperationDegree new) > maxOD then oldgb -                                   else let-                                       gbn = -#ifdef TRACE-                                           trace ("Stepping through\n") $-#endif-                                           stepInitialOperadicBuchberger maxOD oldgb new-                                       gbo = reduceBasis $ oldgb ++ new-                                       gbc = (reduceBasis (gbn ++ gbo)) \\ gbo-                                  in-                                    operadicBuchbergerAcc gbo gbc-  in nub $ operadicBuchbergerAcc [] gb +-- | Non-symmetric version of 'operadicBuchberger'.+nsOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) => [OperadElement a n t] -> [OperadElement a n t]+nsOperadicBuchberger gb = nub $ streamNSOperadicBuchberger maxBound (reduceBasis [] gb) +-- | Perform the entire Buchberger algorithm for a given list of generators. This iteratively runs single iterations+-- from 'stepOperadicBuchberger' until no new elements are generated.+streamOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) =>+                            Int -> [OperadElement a n t] -> [OperadElement a n t]+streamOperadicBuchberger maxOD gb = let+    stepOnce _ [] [] = []+    stepOnce stable unstable new = let+        newgb = stepInitialOperadicBuchberger maxOD (stable++unstable) new+        minArity = minimum (maxBound : (map (nLeaves . leadingMonomial) newgb))+        unstables = unstable ++ new+        newStable = reduceBasis stable $ reverse $ filter ((<minArity) . nLeaves . leadingMonomial) unstables+        stableCandidates = stable ++ reduceBasis stable (reverse newStable)+        unstableCandidates = reverse $ unstables \\ stableCandidates+        midUnstable = reduceBasis stableCandidates unstableCandidates+        newUnstable = reduceBasis stableCandidates (reverse midUnstable)+      in newStable ++ stepOnce stableCandidates newUnstable newgb+  in stepOnce [] [] gb++-- | Non-symmetric version of 'streamOperadicBuchberger'.+streamNSOperadicBuchberger :: (Ord a, Show a, TreeOrdering t, Fractional n) =>+                            Int -> [OperadElement a n t] -> [OperadElement a n t]+streamNSOperadicBuchberger maxOD gb = let+    stepOnce _ [] [] = []+    stepOnce stable unstable new = let+        newgb = stepNSInitialOperadicBuchberger maxOD (stable++unstable) new+        minArity = minimum (maxBound : (map (nLeaves . leadingMonomial) newgb))+        unstables = unstable ++ new+        newStable = reduceBasis stable $ filter ((<minArity) . nLeaves . leadingMonomial) unstables+        unstableCandidates = unstables \\ newStable+        newUnstable = reduceBasis newStable unstableCandidates+        newNew = reduceBasis [] newgb+      in newStable ++ stepOnce newStable newUnstable newNew+  in stepOnce [] [] gb+ -- | Reduces a list of elements with respect to all other elements occurring in that same list.-reduceBasis :: (Ord a, Show a, TreeOrdering t, Fractional n) => [OperadElement a n t] -> [OperadElement a n t]-reduceBasis gb = let-    reduceAcc ngb [] = ngb-    reduceAcc ngb (g:gs) = let-                     ng = reduceCompletely g ngb-                     ngb' = if isZero ng then ngb else ng:ngb-                in -                  reduceAcc ngb' gs+reduceBasis :: (Fractional n, TreeOrdering t, Show a, Ord a) =>+               [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+reduceBasis ogb ngb = let+    reduceStep _ [] = []+    reduceStep gb (g:gs) = let+                           ng = reduceCompletely g gb+                           output = if isZero ng then [] else [ng]+                      in+                        output ++ reduceStep (gb ++ output) gs   in-    reduceAcc [] (reverse . sortBy (comparing leadingMonomial) $ gb)+    reduceStep ogb (reverse $ reduceStep ogb (reverse ngb))  -- ** Low degree bases @@ -478,31 +626,23 @@   shuffle <- allShuffles i (degC - 1) (degT - i)   return $ shuffleCompose i shuffle tree gen --- | Generate basis trees for a given Groebner basis up through degree 'maxDegree'. 'divisors' is expected+-- | Generate basis trees for a given Groebner basis for degree 'maxDegree'. 'divisors' is expected -- to contain the leading monomials in the Groebner basis. basisElements :: (Ord a, Show a) =>                   [DecoratedTree a] -> [DecoratedTree a] -> Int -> [DecoratedTree a] basisElements generators divisors maxDegree = nub $-    if maxDegree <= 0 then [] else if maxDegree == 1 then generators---    else if null divisors then allTrees generators maxDegree+    if maxDegree <= 0 then [] +    else if maxDegree == 1 then generators          else do-  b <- basisElements' generators divisors (maxDegree-1)-  gen <- generators-  let degC = nLeaves gen-      degT = nLeaves b-  i <- [1..degT]-  shuffle <- allShuffles i (degC-1) (degT-i)-  let newB = shuffleCompose i shuffle b gen-  guard $ not $ any (flip divides newB) divisors-  return newB--basisElements' :: (Ord a, Show a) => -                 [DecoratedTree a] -> [DecoratedTree a] -> Int -> [DecoratedTree a]-basisElements' generators divisors maxDegree = if null divisors then allTrees generators maxDegree-                                              else do-  b <- allTrees generators maxDegree-  guard $ not $ any (flip divides b) divisors-  return b +           b <- basisElements generators divisors (maxDegree-1)+           gen <- generators+           let degC = nLeaves gen+               degT = nLeaves b+           i <- [1..degT]+           shuffle <- allShuffles i (degC-1) (degT-i)+           let newB = shuffleCompose i shuffle b gen+           guard $ not $ any (flip divides newB) divisors+           return newB  -- | Change the monomial order used for a specific tree. Use this in conjunction with mapMonomials -- in order to change monomial order for an entire operad element. 

@@ -11,7 +11,7 @@ import Prelude hiding (mapM) import Data.Foldable (Foldable, foldMap) import Data.Traversable-import Data.List (sort, sortBy, intersperse, (\\))+import Data.List (sort, sortBy, intersperse, nub, findIndices) import Control.Applicative import Data.Ord import Control.Monad.State hiding (mapM)@@ -51,6 +51,12 @@     pp (DTLeaf x) = show x     pp (DTVertex t ts) = "m" ++ show t ++ "(" ++ concat (intersperse "," (map pp ts)) ++ ")" +-- | Apply a function @f@ to all the internal vertex labels of a PreDecoratedTree.+vertexMap :: (Ord a, Show a, Ord b, Show b) => +             (a -> b) -> PreDecoratedTree a c -> PreDecoratedTree b c+vertexMap _ (DTLeaf i) = DTLeaf i+vertexMap f (DTVertex t ts) = DTVertex (f t) (map (vertexMap f) ts) + -- | If a tree has trees as labels for its leaves, we can replace the leaves with the roots of -- those label trees. Thus we may glue together trees, as required by the compositions. glueTrees :: (Ord a, Show a) => PreDecoratedTree a (PreDecoratedTree a b) -> PreDecoratedTree a b@@ -114,47 +120,49 @@ orderedPathSequence :: (Ord a, Show a) => DecoratedTree a -> ([[a]],Shuffle) orderedPathSequence t = (map fst . sortBy (comparing snd) $ zip ps1 ps2, ps2) where (ps1, ps2) = pathSequence t --- | Degree reverse lexicographic path sequence ordering.-data RPathLex = RPathLex deriving (Eq, Ord, Show, Read)- -- | Changes direction of an ordering. reverseOrder :: Ordering -> Ordering reverseOrder LT = GT reverseOrder GT = LT reverseOrder EQ = EQ -instance TreeOrdering RPathLex where++-- | Using the path sequence, the leaf orders and order reversal, we can get 8 different orderings+-- from one paradigm. These are given by 'PathPerm', 'RPathPerm', 'PathRPerm', 'RPathRPerm' for the +-- variations giving (possibly reversed) path sequence comparison precedence over (possibly reversed)+-- leaf permutations; additionally, there are 'PermPath', 'RPermPath', 'PermRPath' and 'RPermRPath'+-- for the variations with the opposite precedence.++data PathPerm = PathPerm deriving (Eq, Ord, Show, Read)+instance TreeOrdering PathPerm where     treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t                         else if s == t then EQ                          else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)     comparePathSequence _ _ (paths,perms) _ (patht,permt) = let                             clS = zipWith (comparing length) paths patht                             coS = zipWith compare paths patht-                            cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS+                            cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS                          in-                           if any (/= EQ) cS then head (filter (/=EQ) cS)+                           if any (/= EQ) cs then head (filter (/=EQ) cs)                            else compare perms permt-    ordering = RPathLex---- | Path lexicographic ordering. Orders trees first by lexicographic comparison on--- the ordered path sequence, and then by lexicographic comparison on the leaf orderings.-data PathLex = PathLex deriving (Eq, Ord, Show, Read)+    ordering = PathPerm -instance TreeOrdering PathLex where+data RPathPerm = RPathPerm deriving (Eq, Ord, Show, Read)+instance TreeOrdering RPathPerm where     treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t                         else if s == t then EQ                          else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)     comparePathSequence _ _ (paths,perms) _ (patht,permt) = let                             clS = zipWith (comparing length) paths patht                             coS = zipWith compare paths patht-                            cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS+                            cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS                          in-                           if any (/= EQ) cs then head (filter (/=EQ) cs)+                           if any (/= EQ) cS then head (filter (/=EQ) cS)                            else compare perms permt-    ordering = PathLex+    ordering = RPathPerm -data PathRLex = PathRLex deriving (Eq, Ord, Show, Read)-instance TreeOrdering PathRLex where+data PathRPerm = PathRPerm deriving (Eq, Ord, Show, Read)+instance TreeOrdering PathRPerm where     treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t                         else if s == t then EQ                          else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)@@ -165,10 +173,10 @@                          in                            if any (/= EQ) cs then head (filter (/=EQ) cs)                            else reverseOrder $ compare perms permt-    ordering = PathRLex+    ordering = PathRPerm -data RPathRLex = RPathRLex deriving (Eq, Ord, Show, Read)-instance TreeOrdering RPathRLex where+data RPathRPerm = RPathRPerm deriving (Eq, Ord, Show, Read)+instance TreeOrdering RPathRPerm where     treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t                         else if s == t then EQ                          else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)@@ -179,38 +187,71 @@                          in                            if any (/= EQ) cS then head (filter (/=EQ) cS)                            else reverseOrder $ compare perms permt-    ordering = RPathRLex+    ordering = RPathRPerm --- | Forest lexicographic ordering. Currently not implemented.-data ForestLex = ForestLex deriving (Eq, Ord, Show) -instance TreeOrdering ForestLex where-    treeCompare o s t = comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)-    comparePathSequence _ (DTLeaf k) _ (DTLeaf l) _ = compare l k-    comparePathSequence _ (DTLeaf _) _ _ _ = LT-    comparePathSequence _ _ _ (DTLeaf _) _  = GT-    comparePathSequence o s (paths, perms) t (patht, permt) = let-                                    c1 = compare (vertexArity s) (vertexArity t)-                                    c2 = compare (vertexType s) (vertexType t)-                                    ls = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees s))-                                    lt = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees t))-                                    c3s = zipWith (\sl tl -> case comparing length sl tl of -                                                         LT -> LT-                                                         GT -> GT-                                                         EQ -> reverseOrder $ compare sl tl) ls lt-                                    c3f = filter (/= EQ) c3s-                                    c4f = filter (/= EQ) $ zipWith -                                          (treeCompare o) -                                          (sortBy (comparing minimalLeaf) (subTrees s))-                                          (sortBy (comparing minimalLeaf) (subTrees t))                                    -                               in-                                 if c1 /= EQ then c1 -                                 else if c2 /= EQ then c2 -                                 else if not (null c3f) then head c3f -                                 else if null c4f then EQ -                                 else head c4f-    ordering = ForestLex+data PermPath = PermPath deriving (Eq, Ord, Show, Read)+instance TreeOrdering PermPath where+    treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else if s == t then EQ +                        else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)+    comparePathSequence _ _ (paths,perms) _ (patht,permt) = let+                            clS = zipWith (comparing length) paths patht+                            coS = zipWith compare paths patht+                            cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS+                            test1 = compare perms permt+                         in+                           if test1 /= EQ then test1+                           else if any (/= EQ) cs then head (filter (/=EQ) cs) else EQ+    ordering = PermPath +data PermRPath = PermRPath deriving (Eq, Ord, Show, Read)++instance TreeOrdering PermRPath where+    treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else if s == t then EQ +                        else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)+    comparePathSequence _ _ (paths,perms) _ (patht,permt) = let+                            clS = zipWith (comparing length) paths patht+                            coS = zipWith compare paths patht+                            cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS+                            test1 = compare perms permt+                         in+                           if test1 /= EQ then test1+                           else if any (/= EQ) cS then head (filter (/=EQ) cS) else EQ+    ordering = PermRPath++data RPermPath = RPermPath deriving (Eq, Ord, Show, Read)+instance TreeOrdering RPermPath where+    treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else if s == t then EQ +                        else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)+    comparePathSequence _ _ (paths,perms) _ (patht,permt) = let+                            clS = zipWith (comparing length) paths patht+                            coS = zipWith compare paths patht+                            cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS+                            test1 = reverseOrder $ compare perms permt+                         in+                           if test1 /= EQ then test1+                           else if any (/= EQ) cs then head (filter (/=EQ) cs) else EQ+    ordering = RPermPath++data RPermRPath = RPermRPath deriving (Eq, Ord, Show, Read)+instance TreeOrdering RPermRPath where+    treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else if s == t then EQ +                        else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t)+    comparePathSequence _ _ (paths,perms) _ (patht,permt) = let+                            clS = zipWith (comparing length) paths patht+                            coS = zipWith compare paths patht+                            cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS+                            test1 = reverseOrder $ compare perms permt+                         in+                           if test1 /= EQ then test1 +                           else if any (/= EQ) cS then head (filter (/=EQ) cS) else EQ+    ordering = RPermRPath++ -- ** Utility functions on trees -- -- Trees are represented rooted, and all operations act on a specific root, and may recurse from there. @@ -309,13 +350,29 @@                 else do                   map sort $ (map ((head ss):) $ kSubsets (k-1) (tail ss)) ++ kSubsets k (tail ss) +-- | Applies @f@ only at the @n@th place in a list.+applyAt :: (a -> a) -> Int -> [a] -> [a]+applyAt f n as = take n as ++ [f (as !! n)] ++ drop (n+1) as +-- | Picks out the last nonzero entry in a list.+lastNonzero :: (Num a) => [a] -> Int+lastNonzero as = let+    ras = reverse as+    dwz = dropWhile (==0) ras+    lnzi = length dwz - 1+  in lnzi++-- | Generates shuffle permutations by filling buckets.+allShPerm :: Int -> [Int] -> [[[Int]]]+allShPerm 0 as = [replicate (length as) []]+allShPerm n as = do+  let +      lastIndex = filter (>=0) [lastNonzero as]+      indices = nub $ (findIndices (>1) as) ++ lastIndex+  i <- indices+  p <- allShPerm (n-1) (applyAt (subtract 1) i as)+  return (applyAt (++[n]) i p)+ -- | Generates all shuffles from Sh_i(p,q).  allShuffles :: Int -> Int -> Int -> [Shuffle]-allShuffles i p q = if p<0 || q<0 || i<0 then error "Positive numbers, please!" else -    do-      let later = [i+1..i+p+q]-      pS <- kSubsets p later-      let qS = later \\ pS-      return $ [1..i] ++ pS ++ qS-  +allShuffles i p q = map concat $ allShPerm (i+p+q) ((replicate (i-1) 1) ++ [p+1] ++ (replicate q 1))

@@ -18,7 +18,30 @@     pP = putStrLn . pp  instance (PPrint a) => PPrint [a] where-    pp rs = "[" ++ (intercalate ",\n" (map pp rs)) ++ "]"+    pp rs = "[" ++ (unlines . map ((++",") . pp) $ rs) ++ "]"  instance (PPrint a, PPrint b) => PPrint (a,b) where-    pp (r,t) = "(" ++ pp r ++ "," ++ pp t ++ ")"+    pp (r,t) = "(" ++ (intercalate "," [pp r, pp t]) ++ ")"++instance (PPrint a, PPrint b, PPrint c) => PPrint (a,b,c) where+    pp (r,s,t) = "(" ++ (intercalate "," [pp r, pp s, pp t]) ++ ")"++instance (PPrint a, PPrint b, PPrint c, PPrint d) => PPrint (a,b,c,d) where+    pp (r,s,t,u) = "(" ++ (intercalate "," [pp r, pp s, pp t, pp u]) ++ ")"++instance (PPrint a, PPrint b, PPrint c, PPrint d, PPrint e) => PPrint (a,b,c,d,e) where+    pp (r,s,t,u,v) = "(" ++ (intercalate "," [pp r, pp s, pp t, pp u, pp v]) ++ ")"++instance PPrint Int where+    pp i = show i++instance PPrint Integer where+    pp i = show i++instance (PPrint a) => PPrint (Maybe a) where+    pp Nothing = "Nothing"+    pp (Just a) = "Just " ++ pp a++instance (PPrint a, PPrint b) => PPrint (Either a b) where+    pp (Left a) = "Left " ++ pp a+    pp (Right a) = "Right " ++ pp a

@@ -1,117 +0,0 @@--- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>--- Released under a BSD license---- | Implements the operad element storage using a class that tries to delay all comparisons as long--- as possible, by maintaining the initial term of any operad element in a separate storage. --module Math.Operad.PolyBag where--import qualified Data.Map as Map-import Data.Maybe-import Math.Operad.PPrint-import Math.Operad.OrderedTree-import Control.Arrow-import Data.List (nub)---- | The type carrying operadic elements. An element in an operad is the leading monomial tree, its coefficient,--- and a list of all other elements stored as (tree, coefficient) pairs. -data (Show a, Ord a, Num n, TreeOrdering t) => OperadElement a n t = PB (OrderedTree a t) n [(OrderedTree a t,n)] deriving (Ord, Eq, Show, Read)--instance (Show a, Ord a, Num n, TreeOrdering t) => Num (OperadElement a n t) where-  a@(PB ma ca baga) + b@(PB mb cb bagb)-      | ma > mb = PB ma ca (baga ++ ((mb,cb):bagb))-      | ma < mb = b + a-      | ca+cb /= 0 = PB ma (ca+cb) (baga++bagb)-      | otherwise = let-        combinedMap = Map.fromListWith (+) (baga ++ bagb)-        maybeSum = Map.maxViewWithKey combinedMap-   in-     if isNothing maybeSum then PB ma 0 [] -     else let-         ((mP,cP),mapP) = fromJust maybeSum-    in-      PB mP cP (Map.toList mapP)-  (*) = undefined-  negate pb = (-1) .*. pb-  abs = undefined-  signum = undefined-  fromInteger = undefined ---- | Collapse the storage, removing duplicates from the list carrying the tail of the element.-collate :: (Show a, Ord a, Num n, TreeOrdering t) => OperadElement a n t -> OperadElement a n t-collate  = fromList . toList---- | Given a list of (tree,coefficient)-pairs, reconstruct the corresponding operad element.-fromList :: (TreeOrdering t, Num n, Ord a, Show a) => [(OrderedTree a t,n)] -> OperadElement a n t-fromList lst = fromMaybe (PB (ot $ leaf 1) 0 []) $ do-    ((mP,cP),mapP) <- Map.maxViewWithKey (Map.fromList lst)-    return $ PB mP cP (Map.toList mapP)---- | Given an operad element, extract a list of (tree, coefficient) pairs. -toList :: (TreeOrdering t, Num n, Ord a, Show a) => OperadElement a n t -> [(OrderedTree a t, n)]-toList (PB m c bag) = (m,c):bag---- | Apply a function to each monomial tree in the operad element.-mapMonomials :: (Show a, Ord a, Show b, Ord b, Num n, TreeOrdering s, TreeOrdering t) =>-                (OrderedTree a s -> OrderedTree b t) -> OperadElement a n s -> OperadElement b n t-mapMonomials f (PB m c bag) = collate (PB (f m) c (map (first f) bag))---- | Fold a function over all monomial trees in an operad element, collating the results in a list.-foldMonomials :: (Show a, Ord a, Num n, TreeOrdering t) => -                 ((OrderedTree a t,n) -> [b] -> [b]) -> OperadElement a n t -> [b]-foldMonomials f (PB m c bag) = foldr f [] ((m,c):bag)--instance (Ord a, Show a, Num n, TreeOrdering t) => PPrint (OperadElement a n t) where-      pp m = if str == "" then "0" else str -          where str = foldMonomials (\(k,a) pstr -> pstr ++ "\n+" ++ show a ++ "*" ++ pp k) m---- | Extract all occurring monomial trees from an operad element.-getTrees :: (Ord a, Show a, TreeOrdering t, Num n) =>-            OperadElement a n t -> [OrderedTree a t]-getTrees (PB m _ bag) = nub $ m : (map fst bag)---- | Scalar multiplication.-(.*.) :: (Show a, Ord a, Num n, TreeOrdering t) => n -> OperadElement a n t -> OperadElement a n t-0 .*. (PB ma _ _) = PB ma 0 []-x .*. (PB ma ca baga) = PB ma (x*ca) (map (\(m,c) -> (m,x*c)) baga)------ ** Handling polynomials in the free operad---- | Construct an element in the free operad from its internal structure. Use this instead of the constructor.-oe :: (Ord a, Show a, TreeOrdering t, Num n) => [(OrderedTree a t, n)] -> OperadElement a n t-oe = fromList---- | Construct a monomial in the free operad from a tree and a tree ordering. It's coefficient will be 1.-oet :: (Ord a, Show a, TreeOrdering t, Num n) => DecoratedTree a -> OperadElement a n t-oet dect = PB (ot dect) 1 [] -- oe $ Map.singleton (OT dt o) 1---- | Construct a monomial in the free operad from a tree, a tree ordering and a coefficient.-oek :: (Ord a, Show a, TreeOrdering t, Num n) => DecoratedTree a -> n -> OperadElement a n t-oek dect n = PB (ot dect) n [] -- oe $ Map.singleton (OT dt o) n---- | Return the zero of the corresponding operad, with type appropriate to the given element.--- Can be given an appropriately casted undefined to construct a zero.-zero :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -zero = PB (ot $ leaf 1) 0 [] -- oe (Map.empty)---- | Check whether an element is equal to 0. -isZero :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> Bool-isZero m = 0 == leadingCoefficient m -- Map.null m---- | Extract the leading term of an operad element. -leadingTerm :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> (OrderedTree a t, n)-leadingTerm (PB m c _) = (m,c) -- Map.findMax $ m --  (t, m Map.! t) where t = maximum $ Map.keys m ------ | Extract the ordered tree for the leading term of an operad element.-leadingOMonomial :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> OrderedTree a t-leadingOMonomial = fst . leadingTerm---- | Extract the tree for the leading term of an operad element.-leadingMonomial :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> DecoratedTree a-leadingMonomial = dt .leadingOMonomial---- | Extract the leading coefficient of an operad element.-leadingCoefficient :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> n-leadingCoefficient = snd . leadingTerm

@@ -11,34 +11,14 @@  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 PathPerm ordering+(.>.) s t = GT == (treeCompare PathPerm s t) --- 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])@@ -51,23 +31,19 @@ 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+    g1 = (oet g1t1) + (oet g1t2) :: OperadElement Integer Rational PathPerm+    g2 = (oet g2t2) - (oet g1t2) :: OperadElement Integer Rational PathPerm     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)]))]")+     (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]}]}) PathPerm),(-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]}) PathPerm),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]}]}) PathPerm),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]}) PathPerm),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]}]}]}) PathPerm),2 % 1)]))]" :: [OperadElement Integer Rational PathPerm])        prop_noncom = let@@ -78,13 +54,13 @@     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+    ox2y = oet x2y  :: OperadElement Integer Rational PathPerm+    oxy2 = oet xy2  :: OperadElement Integer Rational PathPerm+    oxy = oet xy  :: OperadElement Integer Rational PathPerm+    oyx = oet yx  :: OperadElement Integer Rational PathPerm+    oone = oet one  :: OperadElement Integer Rational PathPerm     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])+  in (sort . operadicBuchberger $ gb) == (sort . read $ "[OE (TM (fromList [(ST [[1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}) PathPerm),(-1) % 1),(ST [[2]] [1] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1]}) PathPerm),1 % 1)])),OE (TM (fromList [(ST [[]] [1] (OT (DTLeaf 1) PathPerm),(-1) % 1),(ST [[1,1,1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}]}]}) PathPerm),1 % 1)]))]" :: [OperadElement Integer Rational PathPerm])   prop_preliekoszul = let@@ -106,9 +82,9 @@     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+    g1 = (oet t1 ) - (oet t2 ) - (oet t3 ) + (oet t4 ) :: OperadElement Integer Rational PathPerm+    g2 = (oet t5 ) - (oet t6 ) - (oet t7 ) + (oet t8 ) :: OperadElement Integer Rational PathPerm+    g3 = (oet t9 ) - (oet ta ) - (oet tb ) + (oet tc ) :: OperadElement Integer Rational PathPerm      pl = [g1, g2, g3]     plGB = operadicBuchberger pl@@ -133,9 +109,9 @@     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+    g1 = (oet t1 ) - (oet t2 ) - (oet t3 ) + (oet t4 ) :: OperadElement Integer Rational PathPerm+    g2 = (oet t5 ) - (oet t6 ) - (oet t7 ) + (oet t8 ) :: OperadElement Integer Rational PathPerm+    g3 = (oet t9 ) - (oet ta ) - (oet tb ) + (oet tc ) :: OperadElement Integer Rational PathPerm      pl = [g1, g2, g3]     plGB = operadicBuchberger pl@@ -143,18 +119,11 @@   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),--}+        ("Paper example 1 for PathPerm ordering",test prop_paperpathlex1),+        ("Paper example 2 for PathPerm ordering",test prop_paperpathlex1),+        ("Paper example 3 for PathPerm ordering",test prop_paperpathlex1),         ("Anticommutative has 3 element basis",test prop_anticom),---        ("Pre-Lie with the wrong order",test prop_prelie),+        --("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)         ]

@@ -1,6 +1,6 @@ Name:                   Operads-Version:                0.7-Stability:              alpha+Version:                1.0+Stability:              beta License:                BSD3 License-file:           LICENSE Category:               Math@@ -9,10 +9,10 @@ Maintainer:             mik@stanford.edu Bug-reports:            mailto:mik@stanford.edu Homepage:               http://math.stanford.edu/~mik/operads-Package-URL:            http://hackage.haskell.org/packages/archive/Operads/0.4/Operads-0.4.tar.gz+Package-URL:            http://hackage.haskell.org/packages/archive/Operads/1.0/Operads-1.0.tar.gz Build-Type:             Simple Cabal-Version:          >=1.2-Extra-source-files:     README CHANGELOG examples/preLieBad.hs examples/example.hs examples/altDual.hs OperadTest.hs+Extra-source-files:     README CHANGELOG examples/preLieBad.hs examples/example.hs examples/altDual.hs examples/Alternative.hs OperadTest.hs Synopsis:               Groebner basis computation for Operads. Description:               This is an implementation of the operadic Buchberger algorithm from Vladimir Dotsenko & @@ -55,8 +55,11 @@       buildingblocks and 'nsCompose', 'shuffleCompose' and 'symmetricCompose' to assemble        them into trees. The trees, subsequently, may be assembled into tree polynomials by   .-      * picking an ordering. We have currently 'PathLex' and 'ForestLex' implemented, and -        recommend using 'PathLex'. +      * picking an ordering. The orderings available are +        'PathPerm', 'RPathPerm', 'PathRPerm', 'RPathRPerm', +        'PermPath', 'RPermPath', 'PermRPath' and 'RPermRPath', distinguished by reversal +        of order for either the path comparison or the permutation comparison, as well as+        by whether path or permutation comparison takes precedence.   .       * assembling trees and coefficients into an element of the free operad, using '+' for         addition of operadic elements and '.*.' for scalar multiplication.@@ -68,13 +71,13 @@               'FreeOperad' that only asks for a /LabelType/ to cover most common uses:   .     @-    oet tree :: OperadElement /LabelType/ /ScalarType/ /TreeOrdering +    oet tree :: OperadElement /LabelType/ /ScalarType/ /TreeOrdering/     @   .     [@'oek'@] takes a tree, an ordering and a coefficient and gives an operad element   .     @-    oek tree PathLex (3::Rational)+    oek tree PathPerm (3::Rational)     @   .   Example: @@ -144,10 +147,6 @@      Description:       Use the Data.Map based storage for formal linear combinations.      Default:           False -Flag PolyBag-     Description:       Use the head bag based storage for formal linear combinations.-     Default:           False- Flag UseOldMap      Description:       Don't use the Data.Map wrapper class Math.Operad.Map. This will slow down computation.      Default:           False@@ -155,15 +154,13 @@   Library -        Build-Depends:          base, array, mtl, containers+        Build-Depends:          base <= 4, array, mtl, containers         Exposed-Modules:        Math.Operad-        Other-Modules:          Math.Operad.OperadGB, Math.Operad.OrderedTree, Math.Operad.PPrint, Math.Operad.PolyBag, Math.Operad.MapOperad Math.Operad.Map+        Other-Modules:          Math.Operad.OperadGB, Math.Operad.OrderedTree, Math.Operad.PPrint, Math.Operad.MapOperad Math.Operad.Map         ghc-options:            -Wall         ghc-prof-options:       -auto-all         Extensions:             CPP              if flag(mapoperad)            CPP-Options:         -DUSE_MAPOPERAD-        if flag(polybag)-           CPP-Options:         -DUSE_POLYBAG         if flag(useoldmap)            CPP-Options:         -DUSE_OLDMAP

@@ -33,7 +33,7 @@    You can get a computation system by running      ghci    and then inside ghci running-     :m + Operad+     :m + Math.Operad     You can also write your own scripts for computation, and run them    as Haskell programs. This will allow more latitude in using

@@ -0,0 +1,45 @@+import Math.Operad++a = corolla 1 [1,2]+b = corolla 2 [1,2]++aa123 = nsCompose 1 a a+a1a23 = nsCompose 2 a a+aa132 = shuffleCompose 1 [1,3,2] a a++ab123 = nsCompose 1 a b+a1b23 = nsCompose 2 a b+ab132 = shuffleCompose 1 [1,3,2] a b++ba123 = nsCompose 1 b a+b1a23 = nsCompose 2 b a+ba132 = shuffleCompose 1 [1,3,2] b a++bb123 = nsCompose 1 b b+b1b23 = nsCompose 2 b b+bb132 = shuffleCompose 1 [1,3,2] b b++oaa123 = oet aa123 :: FreeOperad Integer+oab123 = oet ab123 :: FreeOperad Integer+oba123 = oet ba123 :: FreeOperad Integer+obb123 = oet bb123 :: FreeOperad Integer++oa1a23 = oet a1a23 :: FreeOperad Integer+oa1b23 = oet a1b23 :: FreeOperad Integer+ob1a23 = oet b1a23 :: FreeOperad Integer+ob1b23 = oet b1b23 :: FreeOperad Integer++oaa132 = oet aa132 :: FreeOperad Integer+oab132 = oet ab132 :: FreeOperad Integer+oba132 = oet ba132 :: FreeOperad Integer+obb132 = oet bb132 :: FreeOperad Integer++r1 = oaa123 - oa1a23 + oaa132 - oa1b23+r2 = oaa123 - oa1a23 + ob1b23 - obb123+r3 = oaa123 - oa1a23 + oab123 - oba132+r4 = oaa123 - oa1a23 - ob1a23 + obb132+r5 = oaa123 - oa1a23 - oab132 + oba123++gens = [r1,r2,r3,r4,r5]++main = putStrLn . show $ operadicBuchberger gens

@@ -7,7 +7,7 @@ a = corolla 1 [1,2] b = corolla 2 [1,2] -ts :: [OperadElement Integer Rational RPathLex]+ts :: [OperadElement Integer Rational RPathPerm] ts = map oet      [shuffleCompose 1 [1,2,3] a a, shuffleCompose 2 [1,2,3] a a, shuffleCompose 1 [1,3,2] a a,        shuffleCompose 2 [1,2,3] a b, shuffleCompose 1 [1,2,3] a b, shuffleCompose 1 [1,3,2] b a, @@ -45,4 +45,4 @@   putStrLn $ "length nub (map leadingMonomial) ad2:\t" ++ (show $ length $ nub $ map leadingMonomial ad2)   putStrLn $ "length nub (map leadingMonomial) ad3:\t" ++ (show $ length $ nub $ map leadingMonomial ad3)   putStrLn $ unlines $ map show $ operadicBuchberger ad0-  putStrLn $ unlines $ map show $ map length $ map (basisElements' [a, b] (map leadingMonomial ad3)) $ [1,2,3,4,5]+  putStrLn $ unlines $ map show $ map length $ map (basisElements [a, b] (map leadingMonomial ad3)) $ [1,2,3,4,5]

@@ -20,21 +20,21 @@ ld2 = shuffleCompose 1 [1,3,2] a b ld3 = shuffleCompose 2 [1,2,3] a b -oa1 = oet la1 :: OperadElement Integer Rational RPathLex-oa2 = oet la2 :: OperadElement Integer Rational RPathLex-oa3 = oet la3 :: OperadElement Integer Rational RPathLex+oa1 = oet la1 :: OperadElement Integer Rational RPathPerm+oa2 = oet la2 :: OperadElement Integer Rational RPathPerm+oa3 = oet la3 :: OperadElement Integer Rational RPathPerm          -ob1 = oet lb1 :: OperadElement Integer Rational RPathLex-ob2 = oet lb2 :: OperadElement Integer Rational RPathLex-ob3 = oet lb3 :: OperadElement Integer Rational RPathLex+ob1 = oet lb1 :: OperadElement Integer Rational RPathPerm+ob2 = oet lb2 :: OperadElement Integer Rational RPathPerm+ob3 = oet lb3 :: OperadElement Integer Rational RPathPerm -oc1 = oet lc1 :: OperadElement Integer Rational RPathLex-oc2 = oet lc2 :: OperadElement Integer Rational RPathLex-oc3 = oet lc3 :: OperadElement Integer Rational RPathLex+oc1 = oet lc1 :: OperadElement Integer Rational RPathPerm+oc2 = oet lc2 :: OperadElement Integer Rational RPathPerm+oc3 = oet lc3 :: OperadElement Integer Rational RPathPerm -od1 = oet ld1 :: OperadElement Integer Rational RPathLex-od2 = oet ld2 :: OperadElement Integer Rational RPathLex-od3 = oet ld3 :: OperadElement Integer Rational RPathLex+od1 = oet ld1 :: OperadElement Integer Rational RPathPerm+od2 = oet ld2 :: OperadElement Integer Rational RPathPerm+od3 = oet ld3 :: OperadElement Integer Rational RPathPerm   ra = oa1 - oa2 - oa3

@@ -18,9 +18,9 @@ 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+g1 = (oet t1) - (oet t2) - (oet t3) + (oet t4) :: OperadElement Integer Rational PathPerm+g2 = (oet t5) - (oet t6) - (oet t7) + (oet t8) :: OperadElement Integer Rational PathPerm+g3 = (oet t9) - (oet ta) - (oet tb) + (oet tc) :: OperadElement Integer Rational PathPerm  pl0 = [g1, g2, g3] pln0 = stepOperadicBuchberger [] pl0