packages feed

Operads (empty) → 0.2

raw patch · 14 files changed

+1605/−0 lines, 14 filesdep +QuickCheckdep +arraydep +basesetup-changed

Dependencies added: QuickCheck, array, base, containers, mtl

Files

+ LICENSE view
@@ -0,0 +1,10 @@+Copyright (c) 2009, Mikael Vejdemo Johansson+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+    * Neither the name of the Stanford University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Math/Operad.hs view
@@ -0,0 +1,79 @@+-- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>+-- 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,+                    m13_2,+                    m1_23,+                    m2,+                    m3,+                    yTree,+                    lgb, +                    Tree, +                    FreeOperad) where++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++-- ** Examples and useful predefined operad elements.++-- | The element m2(m2(1,2),3)+m12_3 :: DecoratedTree Integer+m12_3 = symmetricCompose 1 [1,2,3] (corolla 2 [1,2]) (corolla 2 [1,2])++-- | The element m2(m2(1,3),2)+m13_2 :: DecoratedTree Integer+m13_2 = symmetricCompose 1 [1,3,2] (corolla 2 [1,2]) (corolla 2 [1,2])++-- | The element m2(1,m2(2,3))+m1_23 :: DecoratedTree Integer+m1_23 = symmetricCompose 2 [1,2,3] (corolla 2 [1,2]) (corolla 2 [1,2])++-- | The element m2(1,2)+m2 :: DecoratedTree Integer+m2 = corolla 2 [1,2] ++-- | The element m3(1,2,3)+m3 :: DecoratedTree Integer+m3 = corolla 3 [1,2,3]++-- | The element m2(m2(1,2),m2(3,4))+yTree :: DecoratedTree Integer+yTree = nsCompose 1 (nsCompose 2 m2 m2) m2++-- The Lie operad example computation++lo1 :: OperadElement Integer Rational PathLex+lo1 = oet m12_3++lo2 :: OperadElement Integer Rational PathLex+lo2 = oet m13_2++lo3 :: OperadElement Integer Rational PathLex+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 = [lo1 - lo2 - lo3]+
+ Math/Operad/MapOperad.hs view
@@ -0,0 +1,101 @@+-- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>+-- Released under a BSD license++-- | Implements the operad element storage using the Haskell native Data.Map storage type.++module Math.Operad.MapOperad where++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Maybe+import Control.Arrow+import Math.Operad.OrderedTree+import Math.Operad.PPrint++-- | The type carrying operadic elements. An element in an operad is an associative array +-- with keys being labeled trees and values being their coefficients. +newtype (Ord a, Show a, TreeOrdering t) => OperadElement a n t = OE (Map (OrderedTree a t) n) deriving (Eq, Ord, Show, Read)++instance (Ord a, Show a, Show n, TreeOrdering t) => PPrint (OperadElement a n t) where+      pp (OE m) = if str == "" then "0" else str +          where str = Map.foldWithKey (\k a result -> result ++ "\n+" ++ show a ++ "*" ++ pp k) "" m++-- | Extracting the internal structure of the an element of the free operad.+extractMap :: (Ord a, Show a, TreeOrdering t) => OperadElement a n t -> Map (OrderedTree a t) n+extractMap (OE m) = m++-- | Arithmetic in the operad.+instance (Ord a, Show a, Num n, TreeOrdering t) => Num (OperadElement a n t) where+    (OE m) + (OE n) = OE $ Map.filter (/=0) $ Map.unionWith (+) m n+    negate on = (-1).*.on+    (OE m) * (OE n) = OE $ Map.filter (/=0) $ Map.intersectionWith (*) m n+    abs _ = undefined+    signum _ = undefined+    fromInteger _ = undefined++-- | Scalar multiplication in the operad.+(.*.) :: (Ord a, Show a, Eq n, Show n, Num n, TreeOrdering t) => n -> OperadElement a n t -> OperadElement a n t+nn .*. (OE m) = OE $ Map.map (nn*) m++-- | 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 (OE m) = OE $ Map.fromListWith (+) $ map (first f) (Map.toList m)++-- | 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 (OE m) = Map.foldWithKey (curry f) [] m++-- | Given a list of (tree,coefficient)-pairs, reconstruct the corresponding operad element.+fromList :: (TreeOrdering t, Show a, Ord a, Num n) => [(OrderedTree a t,n)] -> OperadElement a n t+fromList = OE . Map.filter (/=0) . Map.fromListWith (+)++-- | Given an operad element, extract a list of (tree, coefficient) pairs. +toList :: (TreeOrdering t, Show a, Ord a) => OperadElement a n t -> [(OrderedTree a t, n)]+toList (OE m) = Map.toList m++-- ** 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 = oe $ [(OT dect ordering, 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 = oe $ [(OT dect ordering, 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 = oe [(ot $ leaf 1, 0)]++-- | Check whether an element is equal to 0. +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. +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 +                        ((m,c),_) <- Map.maxViewWithKey om+                        return (m,c) ++-- | 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++-- | Extract all occurring monomial trees from an operad element.+getTrees :: (TreeOrdering t, Show a, Ord a) => OperadElement a n t -> [OrderedTree a t]+getTrees (OE m) = Map.keys m
+ Math/Operad/OperadGB.hs view
@@ -0,0 +1,506 @@+-- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>+-- Released under a BSD license++-- | The module 'OperadGB' carries the implementations of the Buchberger algorithm and most utility functions +-- related to this.++module Math.Operad.OperadGB where++import Prelude hiding (mapM, sequence)+import Data.List (sort, sortBy, findIndex, nub, (\\), permutations)+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++--import Debug.Trace++-- * Fundamental data types and instances++-- | The number of internal vertices of a tree.+operationDegree :: (Ord a, Show a) => DecoratedTree a -> Int+operationDegree (DTLeaf _) = 0+operationDegree vertex = 1 + sum (map operationDegree (subTrees vertex))++-- | A list of operation degrees occurring in the terms of the operad element+operationDegrees :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> [Int]+operationDegrees op = foldMonomials (\(k,_) lst -> lst ++ [(operationDegree . dt $ k)]) op++-- | The maximal operation degree of an operadic element+maxOperationDegree :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> Int+maxOperationDegree = maximum . operationDegrees++-- | Check that an element of a free operad is homogenous+isHomogenous :: (Ord a, Show a, TreeOrdering t, Num n) => OperadElement a n t -> Bool+isHomogenous m = let +    trees = getTrees m+--    equalityCheck :: OrderedTree a t -> OrderedTree a t -> Bool+    equalityCheck s t = arityDegree (dt s) == arityDegree (dt t) &&+                        operationDegree (dt s) == operationDegree (dt t)+  in and $ zipWith (equalityCheck) trees (tail trees)++-- * Free operad++-- ** Operadic compositions++-- | Composition in the shuffle operad+shuffleCompose :: (Ord a, Show a) => Int -> Shuffle -> DecoratedTree a -> DecoratedTree a -> DecoratedTree a+shuffleCompose i sh s t | not (isPermutation sh) = error "shuffleCompose: sh needs to be a permutation\n"+                        | (nLeaves s) + (nLeaves t) - 1 /= length sh = +                            error $ "Permutation permutes the wrong number of things:" ++ show i ++ " " ++ show sh ++ " " ++ show s ++ " " ++ show t ++ "\n"+                        | not (isShuffleIPQ sh i (nLeaves t-1)) = +                            error $ "Need a correct pointed shuffle permutation!\n" ++ +                                  show sh ++ " is not in Sh" ++ show i ++ +                                           "(" ++ show (nLeaves t-1) ++ "," ++ show (nLeaves s-i) ++ ")\n"+                        | otherwise = symmetricCompose i sh s t++-- | Composition in the non-symmetric operad. We compose s o_i t. +nsCompose :: (Ord a, Show a) => Int -> DecoratedTree a -> DecoratedTree a -> DecoratedTree a+nsCompose i s t = if i-1 > nLeaves s then error "Composition point too large"+                  else let+                      pS = rePackLabels s+                      lookupList = zip (leafOrder s) (leafOrder pS)+                      idx = if isNothing newI then error "Index not in tree" else fromJust newI where newI = lookup i lookupList+                      trees = map DTLeaf [1..nLeaves s]+                      newTrees = take (idx-1) trees ++ [t] ++ drop idx trees+                 in+                   if length newTrees /= nLeaves s then error "Shouldn't happen" +                   else +                     nsComposeAll s newTrees++-- | Composition in the symmetric operad+symmetricCompose :: (Ord a, Show a) => Int -> Shuffle -> DecoratedTree a -> DecoratedTree a -> DecoratedTree a+symmetricCompose i sh s t = if not (isPermutation sh) then error "symmetricCompose: sh needs to be a permutation\n"+                            else if (nLeaves s) + (nLeaves t) - 1 /= length sh then error "Permutation permutes the wrong number of things.\n"+                            else fmap ((sh!!) . (subtract 1)) $  nsCompose i s t++-- | Non-symmetric composition in the g(s;t1,...,tk) style. +nsComposeAll :: (Ord a, Show a) => DecoratedTree a -> [DecoratedTree a] -> DecoratedTree a+nsComposeAll s trees = if nLeaves s /= length trees then error "NS: Need as many trees as leaves\n"+                        else if length trees == 0 then s+                        else let +                            treesArities = map nLeaves trees+                            packedTrees = map rePackLabels trees+                            offSets = (0:) $ scanl1 (+) treesArities+                            newTrees = zipWith (\t n -> fmap (+n) t) packedTrees offSets+                          in+                            rePackLabels $ glueTrees $ fmap ((newTrees!!) . (subtract 1)) $ rePackLabels s+                        +-- | Verification for a shuffle used for the g(s;t1,..,tk) style composition in the shuffle operad.+checkShuffleAll :: Shuffle -> [Int] -> Bool+checkShuffleAll sh blockL = let+      checkOrders :: Shuffle -> [Int] -> Bool+      checkOrders [] _ = True+      checkOrders _ [] = True+      checkOrders restSh restBlock = (isSorted (take (head restBlock) restSh)) && +                                     (length restSh <= head restBlock || +                                      (head restSh) < (head (drop (head restBlock) restSh))) &&+                                     checkOrders (drop (head restBlock) restSh) (tail restBlock)+    in+      sum blockL == length sh &&+      checkOrders sh blockL+                            +-- | Sanity check for permutations. +isPermutation :: Shuffle -> Bool+isPermutation sh = and ((zipWith (==) [1..]) (sort sh))++-- | Shuffle composition in the g(s;t1,...,tk) style. +shuffleComposeAll :: (Ord a, Show a) => Shuffle -> DecoratedTree a -> [DecoratedTree a] -> DecoratedTree a+shuffleComposeAll sh s trees = if nLeaves s /= length trees then error "Shuffle: Need as many trees as leaves\n"+                               else if sum (map nLeaves trees) /= length sh then error "Permutation permutes the wrong number of things.\n"+                               else if not (isPermutation sh) then error "shuffleComposeAll: sh needs to be a permutation\n"+                               else if length trees == 0 then s+                                    else if not (checkShuffleAll sh (map nLeaves trees)) then error "Bad shuffle"+                                         else let+      newTree = nsComposeAll s trees+   in+            fmap ((sh!!) . (subtract 1)) newTree++-- | Symmetric composition in the g(s;t1,...,tk) style. +symmetricComposeAll :: (Ord a, Show a) => Shuffle -> DecoratedTree a -> [DecoratedTree a] -> DecoratedTree a+symmetricComposeAll sh s trees = if nLeaves s /= length trees then error "Symm: Need as many trees as leaves\n"+                               else if sum (map nLeaves trees) /= length sh then error "Permutation permutes the wrong number of things.\n"+                               else if not (isPermutation sh) then error "sh needs to be a permutation"+                               else if length trees == 0 then s+                                         else let+      newTree = nsComposeAll s trees+   in+            fmap ((sh!!) . (subtract 1)) newTree+++++-- ** Divisibility among trees++-- | Data type to move the results of finding an embedding point for a subtree in a larger tree+-- around. The tree is guaranteed to have exactly one corolla tagged Nothing, the subtrees on top of+-- that corolla sorted by minimal covering leaf in the original setting, and the shuffle carried around+-- 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. +divides :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> Bool+divides s t = not . null $ findAllEmbeddings 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 _) = []+findAllEmbeddings s t = let +    rootFind = maybeToList $ findRootedEmbedding s t+    subFinds = map (findAllEmbeddings s) (subTrees t)+    reGlue (i, ems) = let+        glueTree tree = +            (DTVertex +             (Just $ vertexType t) +             (take (i-1) (map toJustTree $ subTrees t) ++ [tree] ++ drop i (map toJustTree $ subTrees t)))+      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+  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)+  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]++-- | 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++-- | 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.+findSmallLCM :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]+findSmallLCM (DTLeaf _) _ = []+findSmallLCM _ (DTLeaf _) = []+findSmallLCM 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 = findRootedLCM s t+      childLCMs = map (findSmallLCM 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+  rootedLCMs ++ (concatMap reGlue zippedChildLCMs)++-- | Finds all small common multiples of s and t.+findAllLCM :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree a -> [DecoratedTree a]+findAllLCM s t = (findSmallLCM s t) ++ (findSmallLCM t s)++-- | 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++-- | Removes vertex type encapsulations.+fromJustTree :: (Ord a, Show a) => DecoratedTree (Maybe a) -> Maybe (DecoratedTree a)+fromJustTree (DTLeaf k) = Just (DTLeaf k)+fromJustTree (DTVertex Nothing _) = Nothing+fromJustTree (DTVertex (Just l) sts) = let+    newsts = map fromJustTree sts+  in+    if all isJust newsts then Just $ DTVertex l (map fromJust newsts)+    else Nothing++-- | Adds vertex type encapsulations. +toJustTree :: (Ord a, Show a) => DecoratedTree a -> DecoratedTree (Maybe a)+toJustTree (DTLeaf k) = DTLeaf k+toJustTree (DTVertex a sts) = DTVertex (Just a) (map toJustTree sts)++-- replace the following function by one that zips lists, sorts them once, and then unsplits them,+-- verifying both lists to be sorted afterwards?++-- | Verifies that two integer sequences correspond to the same total ordering of the entries.+equivalentOrders :: [Int] -> [Int] -> Bool+equivalentOrders ss ts = let+    sLookup :: [(Int,Int)]+    sLookup = zip (sort ss) [1..]+    tLookup :: [(Int,Int)]+    tLookup = zip (sort ts) [1..]+    sOrder = map (fromJust . flip lookup sLookup) ss+    tOrder = map (fromJust . flip lookup tLookup) ts+  in+    sOrder == tOrder++-- | Returns True if any of the vertices in the given tree has been tagged.+subTreeHasNothing :: (Ord a, Show a) => DecoratedTree (Maybe a) -> Bool+subTreeHasNothing (DTLeaf _) = False+subTreeHasNothing (DTVertex Nothing _) = True+subTreeHasNothing (DTVertex (Just _) sts) = any subTreeHasNothing sts++-- | 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 only attempts to resubstitute the tree+-- at the root, bailing out if not possible.+reconstructNode :: (Ord a, Show a) => DecoratedTree a -> Embedding a -> Maybe (DecoratedTree a)+reconstructNode sub super = if isJust (vertexType super) then Nothing+                            else if (nLeaves sub) /= (vertexArity super) then Nothing+                            else let +                                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+                               in+                                 Just $ fmap ((leafs!!) . (subtract 1)) newTree++-- | 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+-- to find exactly one hole, and substitute the tree sub into it.+reconstructTree :: (Ord a, Show a) => DecoratedTree a -> Embedding a -> Maybe (DecoratedTree a)+reconstructTree sub super = if isLeaf super then Nothing+                            else if isNothing (vertexType super) then reconstructNode sub super+                            else if (1/=) . sum . map fromEnum $ map subTreeHasNothing (subTrees super) then Nothing+                            else+                                      let+                                          fromMaybeBy f s t = if isNothing t then f s else t+                                          subtreesSuper = subTrees super+                                          reconstructions = map (reconstructTree sub) subtreesSuper+                                          results = zipWith (fromMaybeBy fromJustTree) subtreesSuper reconstructions+                                      in+                                        if any isNothing results then Nothing+                                           else Just $ DTVertex (fromJust $ vertexType super) (map fromJust results)+++-- ** Groebner basis methods++-- | Applies the reconstruction map represented by em to all trees in the operad element op. Any operad element that +-- fails the reconstruction (by having the wrong total arity, for instance) will be silently dropped. We recommend+-- you apply this function only to homogenous operad elements, but will not make that check.+applyReconstruction :: (Ord a, Show a, TreeOrdering t, Num n) => Embedding a -> OperadElement a n t -> OperadElement a n t+applyReconstruction em m = let+      reconstructor (ordT, n) = do+        newDT <- reconstructTree (dt ordT) em+        return $ (ot newDT, n)+    in oe $ mapMaybe reconstructor (toList m)++-- | Finds all S polynomials for a given list of operad elements. +findAllSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) => +                       [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+findAllSPolynomials oldGb newGb = nub . map (\o -> (1/leadingCoefficient o) .*. o) . filter (not . isZero) $ do+  g1 <- oldGb ++ newGb+  g2 <- newGb+  let lmg1 = leadingMonomial g1+      lmg2 = leadingMonomial g2+      cf12 = (leadingCoefficient g1) / (leadingCoefficient g2)+  gamma <- nub $ findAllLCM lmg1 lmg2+  mg1 <- findAllEmbeddings lmg1 gamma+  mg2 <- findAllEmbeddings lmg2 gamma+  return $ (applyReconstruction mg1 g1) - (cf12 .*. (applyReconstruction mg2 g2))++-- | Finds all S polynomials for which the operationdegree stays bounded.+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+      lmg2 = leadingMonomial g2+      cf12 = (leadingCoefficient g1) / (leadingCoefficient g2)+  gamma <- nub $ findAllLCM lmg1 lmg2+  guard $ (operationDegree gamma) <= n+  mg1 <- findAllEmbeddings lmg1 gamma+  mg2 <- findAllEmbeddings lmg2 gamma+  return $ (applyReconstruction mg1 g1) - (cf12 .*. (applyReconstruction mg2 g2))++-- | Reduce g with respect to f and the embedding em: lt f -> lt g.+reduceOE :: (Ord a, Show a, TreeOrdering t, Fractional n) => Embedding a -> OperadElement a n t -> OperadElement a n t -> OperadElement a n t+reduceOE em f g = if not (divides (leadingMonomial f) (leadingMonomial g)) +                  then g +                  else let+                      cgf = (leadingCoefficient g) / (leadingCoefficient f)+                      ret = g - (cgf .*. (applyReconstruction em f))+                    in+                      if isZero ret then ret else (1/leadingCoefficient 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 +                         then op +                         else let+                             divisorIdx = findIndex (flip divides (leadingMonomial op)) (map leadingMonomial gb)+                           in+                             if isNothing divisorIdx then op+                             else +                               let +                                 g1 = gb!!(fromJust divisorIdx) +                                 em = head $ findAllEmbeddings (leadingMonomial g1) (leadingMonomial op)+                                 o1 = reduceOE em g1 op+                                in +                                 reduceCompletely o1 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 = nub $ do+  spol <- findAllSPolynomials oldGb newGb+  let red = reduceCompletely spol (oldGb ++ newGb)+  guard $ not . isZero $ red+  return red++-- | 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) => +                          Int -> [OperadElement a n t] -> [OperadElement a n t] -> [OperadElement a n t]+stepInitialOperadicBuchberger maxD oldGb newGb = nub $ do+  spol <- findInitialSPolynomials 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 = let+    operadicBuchbergerAcc oldgb [] = oldgb+    operadicBuchbergerAcc oldgb new = operadicBuchbergerAcc +                                      (newGB) +                                      ((nub $ stepOperadicBuchberger oldgb new) \\ newGB) +                                          where newGB = gb ++ new+  in operadicBuchbergerAcc [] 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+                                       operadicBuchbergerAcc +                                       (newGB) +                                       ((nub $ stepInitialOperadicBuchberger maxOD gb new) \\ newGB) +                                           where newGB = gb ++ new+  in operadicBuchbergerAcc [] 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 = map (\g -> reduceCompletely g (gb \\ [g])) gb++-- ** Low degree bases++-- | All trees composed from the given generators of operation degree n.+allTrees :: (Ord a, Show a) => +            [DecoratedTree a] -> Int -> [DecoratedTree a]+allTrees _ 0 = []+allTrees gens 1 = gens+allTrees gens k = nub $ do+  gen <- gens+  tree <- allTrees gens (k-1)+  let degC = nLeaves gen+      degT = nLeaves tree+  i <- [1..degT]+  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+-- 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+         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 ++-- | 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. +changeOrder :: (Ord a, Show a, TreeOrdering s, TreeOrdering t) => t -> OrderedTree a s -> OrderedTree a t+changeOrder o' (OT t _) = OT t o'
+ Math/Operad/OrderedTree.hs view
@@ -0,0 +1,270 @@+-- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>+-- Released under a BSD license++-- | Implements decorated and ordered trees, and most operations acting only on these.+-- The decorated tree is the most fundamental part of the implementation, and the internal+-- structure of the tree is to the largest extent what determines the actual identity+-- of a given element of the free operad.++module Math.Operad.OrderedTree where++import Prelude hiding (mapM)+import Data.Foldable (Foldable, foldMap)+import Data.Traversable+import Data.List (sort, sortBy, intersperse, (\\))+import Control.Applicative+import Data.Ord+import Control.Monad.State hiding (mapM)+import Data.Monoid++import PPrint++-- * Decorated and ordered trees++-- | The fundamental tree data type used. Leaves carry labels - most often integral -+-- and these are expected to control, e.g., composition points in shuffle operad compositions.+-- The vertices carry labels, used for the ordering on trees and to distinguish different+-- basis corollas of the same arity. +data (Ord a, Show a) => PreDecoratedTree a b = DTLeaf !b | +                                       DTVertex { +                                         vertexType :: !a, +                                         subTrees :: ![PreDecoratedTree a b]}+                                       deriving (Eq, Ord, Read, Show)++-- | The arity of a corolla+vertexArity :: (Ord a, Show a) => PreDecoratedTree a b -> Int+vertexArity t = length (subTrees t)++instance (Ord a, Show a) => Functor (PreDecoratedTree a) where+    fmap f (DTLeaf b) = DTLeaf (f b)+    fmap f (DTVertex t ts) = DTVertex t (map (fmap f) ts)++instance (Ord a, Show a) => Foldable (PreDecoratedTree a) where+    foldMap f (DTLeaf b) = f b+    foldMap f (DTVertex _ ts) = mconcat (map (foldMap f) ts)++instance (Ord a, Show a) => Traversable (PreDecoratedTree a) where+    traverse f (DTLeaf b) = DTLeaf <$> f b+    traverse f (DTVertex t ts) = DTVertex t <$> traverse (traverse f) ts++instance (Ord a, Show a, Show b) => PPrint (PreDecoratedTree a b) where+    pp (DTLeaf x) = show x+    pp (DTVertex t ts) = "m" ++ show t ++ "(" ++ concat (intersperse "," (map pp 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+glueTrees (DTLeaf newRoot) = newRoot+glueTrees (DTVertex t ts) = DTVertex t (map glueTrees ts)++instance (Ord a, Show a) => Monad (PreDecoratedTree a) where +    return = DTLeaf; +    a >>= f = glueTrees (fmap f a)++-- | This is the fundamental datatype of the whole project. Monomials in a free operad+-- are decorated trees, and we build a type for decorated trees here. We require our +-- trees to have Int labels, limiting us to at most 2 147 483 647 leaf labels.+type DecoratedTree a = PreDecoratedTree a Int++-- | Monomial orderings on the free operad requires us to choose an ordering for the+-- trees. These are parametrized by types implementing the type class 'TreeOrdering', +-- and this is a data type for a tree carrying its comparison type. We call these +-- /ordered trees/. +data (Ord a, Show a, TreeOrdering t) => OrderedTree a t = OT (DecoratedTree a) t deriving (Eq, Show, Read)++instance (Ord a, Show a, TreeOrdering t) => PPrint (OrderedTree a t) where+    pp (OT dect _) = pp dect++-- | Monomial ordering for trees. We require this to be a total well-ordering, compatible+-- with the operadic compositions.+instance (Ord a, Show a, TreeOrdering t) => Ord (OrderedTree a t) where+    compare (OT s o1) (OT t _) = treeCompare o1 s t++-- | Building an ordered tree with 'PathLex' ordering from a decorated tree.+ot :: (Ord a, Show a, TreeOrdering t) => DecoratedTree a -> OrderedTree a t+ot t = OT t ordering++-- | Extracting the underlying tree from an ordered tree.+dt :: (Ord a, Show a, TreeOrdering t) => OrderedTree a t -> DecoratedTree a+dt (OT t _) = t+++++-- ** Monomial orderings on the free operad++-- | The type class that parametrizes types implementing tree orderings.+class (Eq t, Show t) => TreeOrdering t where+    treeCompare :: (Ord a, Show a) => t -> DecoratedTree a -> DecoratedTree a -> Ordering+    ordering :: t++-- | Finding the path sequences. cf. Dotsenko-Khoroshkin.+pathSequence :: (Ord a, Show a) => DecoratedTree a -> ([[a]],Shuffle)+pathSequence (DTLeaf j) = ([[]],[j])+pathSequence (DTVertex l ts) = let+    pathSequences = map pathSequence $! ts+    paths = concatMap fst $! pathSequences+    leaves = concatMap snd $! pathSequences+  in (map (l:) $! paths, leaves)++-- | Reordering the path sequences to mirror the actual leaf ordering.+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+    treeCompare _ s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else let+                            (paths,perms) = orderedPathSequence s +                            (patht,permt) = orderedPathSequence t+                            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+                         in+                           if s == t then EQ +                           else 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)++instance TreeOrdering PathLex where+    treeCompare _ s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+                        else let+                            (paths,perms) = orderedPathSequence s +                            (patht,permt) = orderedPathSequence t+                            clS = zipWith (comparing length) paths patht+                            coS = zipWith compare paths patht+                            cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS+                         in+                           if s == t then EQ +                           else if any (/= EQ) cs then head (filter (/=EQ) cs)+                           else compare perms permt+    ordering = PathLex++-- | Forest lexicographic ordering. Currently not implemented.+data ForestLex = ForestLex deriving (Eq, Ord, Show)+++instance TreeOrdering ForestLex where+    treeCompare = error "Forest lexicographic ordering is not yet implemented."+    ordering = ForestLex++-- ** Utility functions on trees+--+-- Trees are represented rooted, and all operations act on a specific root, and may recurse from there. ++-- | Build a single corolla in a decorated tree. Takes a list for labels for the leaves, and derives+-- the arity of the corolla from those. This, and the composition functions, form the preferred method+-- to construct trees.+corolla :: (Ord a, Show a) => a -> [Int] -> DecoratedTree a+corolla label leaflabels = +    if null leaflabels +    then error "The operadic Buchberger, and many other algorithms, require the absence of 0-ary operations."+    else DTVertex label (map DTLeaf leaflabels)++-- | Build a single leaf.+leaf :: (Ord a, Show a) => Int -> DecoratedTree a+leaf n = DTLeaf n++-- | Check whether a given root is a leaf.+isLeaf :: (Ord a, Show a) => DecoratedTree a -> Bool+isLeaf (DTLeaf _) = True+isLeaf _ = False++-- | Check whether a given root is a corolla.+isCorolla :: (Ord a, Show a) => DecoratedTree a -> Bool+isCorolla = not . isLeaf++-- | Change the leaves of a tree to take their values from a given list.+relabelLeaves :: (Ord a, Show a) => DecoratedTree a -> [b] -> PreDecoratedTree a b+relabelLeaves tree newLabels = fst $ runState (mapM (\_ -> do; (x:xs) <- get; put xs; return x) tree) newLabels++-- | Find the permutation the leaf labeling ordains for inputs.+leafOrder :: (Ord a, Show a) => DecoratedTree a -> [Int]+leafOrder = foldMap (:[])+++-- | Find the minimal leaf covering any given vertex.+minimalLeaf :: (Ord a, Show a, Ord b) => PreDecoratedTree a b -> b+minimalLeaf (DTLeaf lbl) = lbl+minimalLeaf vertex = minimum $ map minimalLeaf (subTrees vertex)++-- | Compute the number of leaves of the entire tree covering a given vertex.+nLeaves :: (Ord a, Show a) => DecoratedTree a -> Int+nLeaves (DTLeaf _) = 1+nLeaves vertex = sum $ map nLeaves (subTrees vertex)++-- | 'arityDegree' is one less than 'nLeaves'.+arityDegree :: (Ord a, Show a) => DecoratedTree a -> Int+arityDegree t = nLeaves t - 1++-- * Shuffles+-- Basic handling functions for building, recognizing and applying shuffle permutations.++-- | A shuffle is a special kind of sequence of integers.+type Shuffle = [Int]++-- | We need to recognize sorted sequences of integers.+isSorted :: (Ord a, Show a) => [a] -> Bool+isSorted xs = and $ zipWith (<=) xs (tail xs)++-- | This tests whether a given sequence of integers really is a shuffle.+isShuffle :: Shuffle -> Bool+isShuffle as = (sort as) == [1..length as] &&+               any (\k -> isShuffleIJ as k (length as-k)) [1..length as]++-- | This tests whether a given sequence of integers is an (i,j)-shuffle+isShuffleIJ :: Shuffle -> Int -> Int -> Bool+isShuffleIJ as i j = isSorted [a | a <- as, a <= i] &&+                     isSorted [a | a <- as, a > i] &&+                     length as == i+j++-- | This tests whether a given sequence of integers is admissible for a specific composition operation.+isShuffleIPQ :: Shuffle -> Int -> Int -> Bool+isShuffleIPQ as i p = let +    initSegment = take i as+    finalSegment = drop i as+    upperTree = take p finalSegment+    latterTree = drop p finalSegment+  in initSegment == [1 .. length initSegment] &&+     isSorted upperTree &&+     isSorted latterTree++-- | This applies the resulting permutation from a shuffle to a set of elements+applyPerm :: Show a => Shuffle -> [a] -> [a]+applyPerm s is = --trace ("applyPerm " ++ show s ++ " " ++ show (length is) ++ "\n") $ +                 map (is!!) (map (subtract 1) s)++-- | Apply the permutation inversely to 'applyPerm'.+invApplyPerm :: Shuffle -> [a] -> [a]+invApplyPerm sh lst = map snd . sortBy (comparing fst) $ zip sh lst++-- | Generate all subsets of length k from a given list. +kSubsets :: Int -> [Int] -> [[Int]]+kSubsets 0 _ = [[]]+kSubsets k ss = if length ss == k then [ss]+                else if length ss < k then []+                else do+                  map sort $ (map ((head ss):) $ kSubsets (k-1) (tail ss)) ++ kSubsets k (tail ss)+++-- | 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+
+ Math/Operad/PPrint.hs view
@@ -0,0 +1,24 @@+-- Copyright 2009 Mikael Vejdemo Johansson <mik@stanford.edu>+-- Released under a BSD license++-- | Pretty printing for user interaction.++module Math.Operad.PPrint where++import Data.List (intercalate)++-- * Pretty printing++-- | This yields user interface functions for human readable printing of objects.+-- The idea is to use 'Show' instances for marshalling of data, and 'PPrint' for+-- user interaction.+class PPrint a where+    pp :: a -> String+    pP :: a -> IO ()+    pP = putStrLn . pp++instance (PPrint a) => PPrint [a] where+    pp rs = "[" ++ (intercalate ",\n" (map pp rs)) ++ "]"++instance (PPrint a, PPrint b) => PPrint (a,b) where+    pp (r,t) = "(" ++ pp r ++ "," ++ pp t ++ ")"
+ Math/Operad/PolyBag.hs view
@@ -0,0 +1,117 @@+-- 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
+ OperadTest.hs view
@@ -0,0 +1,139 @@+import Test.QuickCheck+import Text.Printf+import Data.List (sort, nub)+import Data.Ord+import Control.Monad++import OperadGB+import PPrint+import MapOperad+import 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)+        ]
+ Operads.cabal view
@@ -0,0 +1,173 @@+Name:                   Operads+Version:                0.2+License:                BSD3+License-file:           LICENSE+Category:               Math+Author:                 Mikael Vejdemo Johansson+Maintainer:             mik@stanford.edu+Bug-reports:            mailto:mik@stanford.edu+Build-Type:             Simple+Cabal-Version:          >=1.2+Extra-source-files:     README+Synopsis:               Groebner basis computation for Operads.+Description:            +  This is an implementation of the operadic Buchberger algorithm from Vladimir Dotsenko & +  Anton Khoroshkin: Groebner bases for operads (arXiv:0812.4069).+  .+  In writing this package, invaluable help has been given by Vladimir Dotsenko and Eric Hoffbeck.+  .+  The user is recommended to run this from within the GHC interpreter+  for exploration, and to write small Haskell scripts for batch+  processing. We hope herewithin to give enough of an overview of the+  available functionality to help the user figure out how to use the+  software package.+  .+  A declaration of a new variable is done in a Haskell script by a+  statement on the form+  .+  @+  var = value+  @+  .+  and in the interpreter by a statement on the form+  .+  @+  let var = value+  @+  .+  Using these, the following instructions should help get you started. I will be writing +  the instructions aiming for use in the interpreter, for quick starts.+  .+  It is possible to force types by following a declaration by :: and the type signature +  you'll which. This enables you, for instance, to pick a ground ring without having to set+  coefficients explicitly - see the examples below.+  .+  Note that the Buchberger algorithm in its current shape expects at least a division ring+  as scalar ring.+  .+  The expected workflow for a normal user is as follows.+  .+   1. write the generators of the operadic ideal using 'corolla' and 'leaf' to construct +      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'. +  .+      * assembling trees and coefficients into an element of the free operad, using '+' for+        addition of operadic elements and '.*.' for scalar multiplication.+  .+  Useful functions for doing this includes, furthermore:+  .+    [@'oet'@] takes a tree and an ordering and gives an operad element. You will have to+              specify the relevant type for this to work -- but we provide the extra type+              'FreeOperad' that only asks for a /LabelType/ to cover most common uses:+  .+    @+    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)+    @+  .+  Example: +  .+  @+  let t1 = nsCompose 1 (corolla 'a' [2,1]) (corolla 'b' [1,2])+  .+  let b = corolla 'l' [1,2]+  .+  let lb1 = shuffleCompose 1 [1,2,3] b b+  .+  let lb2 = shuffleCompose 1 [1,3,2] b b+  .+  let lb3 = shuffleCompose 2 [1,2,3] b b+  .+  let lo1 = oet lb1 :: FreeOperad Char+  .+  let lo2 = oet lb2 :: FreeOperad Char+  .+  let lo3 = oet lb3 :: FreeOperad Char+  @+  .+  Note that while the Haskell compiler in general is very skilled at guessing types of objects, +  the system guessing will give up if the type is not well defined. There are several different+  monomial orders allowed, and they are encoded in the type system -- hence the need to annotate+  the instantiation of elements in the free operad with appropriate types.+  .+  2. assemble all generators into a list. Lists are formed by enclosing the elements, +     separated by commas, in square brackets. Lists must have identical type on all its +     elements - hence, for instance, you cannot have operadic elements with different monomial+     orderings in the same list. +  .+  Example:+  .+  @+  let lgb = [lo1 - lo2 - lo3, 2.*.lo1 + 3.*. lo3]+  @+  .+  3. run the algorithm on your basis and wait for it to finish. The entry point to the Buchberger+     algorithm is, not surprisingly, 'operadicBuchberger'.+  .+  Example: +  .+  @+  let grobner = operadicBuchberger lgb+  @+  .+  The output of 'operadicBuchberger', if it finishes, is a finite Gröbner basis for the ideal spanned +  by the original generators. If this is quadratic then the operad presented by this ideal is Koszul -+  this may be tested with something like:+  .+  @+  all (==2) $ concatMap operationDegrees grobner+  @+  .+  If you wish to inspect elements yourself, the recommended way to do it is by using the 'pP' function, +  which outputs most of the interesting elements in a human-readable format. For objects that don't work +  with pP, just writing the variable name on its own will print it in some format.+  .+  The difference here is related to the ability to save computational states to disk. There are two +  different functions that will represent a tree or an element of an operad as a String: 'show' and 'pp'.+  Using the former guarantees (with the same version of the source code) that the data can be read back +  into the system and reused later one; whereas using 'pp' will build a human readable string.+++Flag MapOperad+     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++Executable preLieBad+           Extensions:          CPP+           Main-is:             examples/preLieBad.hs++Executable altDual+           Extensions:          CPP+           Main-is:             examples/altDual.hs++Executable OperadTest+           Main-is:             OperadTest.hs+           Extensions:          CPP+           Build-Depends:       QuickCheck++Executable example+           Main-is:             examples/example.hs+           Extensions:          CPP++Library +        Build-Depends:          base, array, mtl, containers+        Exposed-Modules:        Math.Operad+        Other-Modules:          Math.Operad.OperadGB, Math.Operad.OrderedTree, Math.Operad.PPrint, Math.Operad.PolyBag, Math.Operad.MapOperad+        ghc-options:            -Wall+        Extensions:             CPP     +        if flag(mapoperad)+           CPP-Options:         -DUSE_MAPOPERAD+        if flag(polybag)+           CPP-Options:         -DUSE_POLYBAG
+ README view
@@ -0,0 +1,45 @@+This Haskell software package implements the Gröbner basis algorithm+as described in Vladimir Dotsenko, Anton Khoroshkin: "Gröbner bases+for operads" (arXiv:0812.4096).++In order to use it, make sure you install ghc, cabal and haddock (see+http://haskell.org for more details). These are available directly in+most Linux and BSD distributions, and there are installers for MacOSX+and Windows available on http://haskell.org.++Once ghc is installed, install cabal-install, and then use that to+install everything else needed. This tool will make the installation+of everything else painless.++To install the package, download the most recent tar ball+Operads-n.n.tar.gz, and then perform the following steps:++1) copy the tarball into an appropriate temporary directory+2) in this temporary directory, execute +     tar -xzvf Operads-n.n.tar.gz+3) enter the directory Operads-0.2+4) run the following commands+     ghc --make Setup.hs+     ./Setup configure+     ./Setup build+     ./Setup install+5) look through the example files+     example.hs+     altDual.hs+     preLieBad.hs+   to get a feeling for the syntax for interaction, and read the+   documentation. ++   You can get a computation system by running+     ghci+   and then inside ghci running+     :m + Operad++   You can also write your own scripts for computation, and run them+   as Haskell programs. This will allow more latitude in using+   parallel processing and advanced computation techniques, but+   exceeds the scope of this README.++Pitfalls: +  * Make sure you run the program from somewhere else than the+    temporary building directory, as this would load the wrong files.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ examples/altDual.hs view
@@ -0,0 +1,48 @@+module Main where++import Math.Operad +import Data.List (nub)+import Control.Concurrent++a = corolla 1 [1,2]+b = corolla 2 [1,2]++ts :: [OperadElement Integer Rational RPathLex]+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, +      shuffleCompose 2 [1,2,3] b a, shuffleCompose 1 [1,3,2] b b, shuffleCompose 1 [1,3,2] a b, +      shuffleCompose 1 [1,2,3] b a, shuffleCompose 2 [1,2,3] b b, shuffleCompose 1 [1,2,3] b b]+opSum = foldr (+) zero+g1 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [1,2]+g2 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [3,4]+g3 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [5,6]+g4 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [7,8]+g5 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [9,10]+g6 = opSum $ zipWith (.*.) [1,-1] $ map ((ts!!) . (subtract 1)) [11,12]+g7 = opSum $ zipWith (.*.) (repeat 1) $ map ((ts!!) . (subtract 1)) [1,3,6,10,8,12]+ad0 = [g1,g2,g3,g4,g5,g6,g7]+adn1 = stepOperadicBuchberger [] ad0+ad1 = nub $ ad0 ++ adn1+adn2 = stepOperadicBuchberger ad0 adn1+ad2 = nub $ ad1 ++ adn2+adn3 = stepOperadicBuchberger ad1 adn2+ad3 = nub $ ad2 ++ adn3++second_us = 1000000+main = do+  threadID <- forkIO func+  threadDelay (600*second_us)+  killThread threadID+++func = do+  putStrLn $ "length ad1:\t" ++ (show $ length ad1)+  putStrLn $ "length ad2:\t" ++ (show $ length ad2)+  putStrLn $ "length ad3:\t" ++ (show $ length ad3)+  putStrLn $ "ad2 == ad3:\t" ++ (show $ ad2 == ad3)+  putStrLn $ "length nub (map leadingMonomial) ad1:\t" ++ (show $ length $ nub $ map leadingMonomial ad1)+  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]
+ examples/example.hs view
@@ -0,0 +1,58 @@+import Math.Operad+import Data.List++a = corolla 1 [1,2]+b = corolla 2 [1,2]++la1 = shuffleCompose 1 [1,2,3] a a+la2 = shuffleCompose 1 [1,3,2] a a+la3 = shuffleCompose 2 [1,2,3] a a+         +lb1 = shuffleCompose 1 [1,2,3] b b+lb2 = shuffleCompose 1 [1,3,2] b b+lb3 = shuffleCompose 2 [1,2,3] b b+         +lc1 = shuffleCompose 1 [1,2,3] b a+lc2 = shuffleCompose 1 [1,3,2] b a+lc3 = shuffleCompose 2 [1,2,3] b a+         +ld1 = shuffleCompose 1 [1,2,3] a b+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+         +ob1 = oet lb1 :: OperadElement Integer Rational RPathLex+ob2 = oet lb2 :: OperadElement Integer Rational RPathLex+ob3 = oet lb3 :: OperadElement Integer Rational RPathLex++oc1 = oet lc1 :: OperadElement Integer Rational RPathLex+oc2 = oet lc2 :: OperadElement Integer Rational RPathLex+oc3 = oet lc3 :: OperadElement Integer Rational RPathLex++od1 = oet ld1 :: OperadElement Integer Rational RPathLex+od2 = oet ld2 :: OperadElement Integer Rational RPathLex+od3 = oet ld3 :: OperadElement Integer Rational RPathLex+++ra = oa1 - oa2 - oa3+rb = ob1 - ob2 - ob3++r1 = oc1 - oc2 - oc3+r2 = od1 - od2 - od3+r3 = oc1 - od1+r4 = oc2 - od2+r5 = oc3 - od3++gens = [ra,rb,r1,r2,r3,r4]+gb0 = gens+gbn0 = stepInitialOperadicBuchberger 4 [] gb0+gb1 = nub $ gb0 ++ gbn0+gbn1 = stepInitialOperadicBuchberger 4 gb0 gbn0+gb2 = nub $ gb1 ++ gbn1 +gbn2 = stepInitialOperadicBuchberger 4 gb1 gbn1+++main = putStrLn . unlines . map pp $ gbn1
+ examples/preLieBad.hs view
@@ -0,0 +1,32 @@+import Math.Operad ++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++pl0 = [g1, g2, g3]+pln0 = stepOperadicBuchberger [] pl0+pl1 = pl0 ++ pln0+pln1 = stepOperadicBuchberger pl0 pln0+pl2 = pl1 ++ pln1 ++main = do +  putStr . show $ length (take 25 pln1)