Operads 0.3 → 0.4
raw patch · 6 files changed
+80/−68 lines, 6 filessetup-changed
Files
- CHANGELOG +20/−0
- Math/Operad/OperadGB.hs +25/−39
- Math/Operad/OrderedTree.hs +15/−14
- OperadTest.hs +5/−1
- Operads.cabal +7/−13
- Setup.hs +8/−1
+ CHANGELOG view
@@ -0,0 +1,20 @@+Tue Apr 28 23:12:25 CEST 2009 mik@stanford.edu+ * Automated testing with Cabal.++Tue Apr 28 23:11:45 CEST 2009 mik@stanford.edu+ * Noncritical minor mistake.++Tue Apr 28 23:03:25 CEST 2009 mik@stanford.edu+ * Preparing for release 0.4++Tue Apr 28 22:52:05 CEST 2009 mik@stanford.edu+ * Tree ordering tweaks.++Tue Apr 28 22:51:16 CEST 2009 mik@stanford.edu+ * Cabal standards adaptation++Tue Apr 28 22:48:57 CEST 2009 mik@stanford.edu+ * Percolate maximal degree through the Buchberger computation down to the LCM computation.++Mon Apr 27 18:48:05 CEST 2009 mik@stanford.edu+ * Adapting to HackageDB source code standards
Math/Operad/OperadGB.hs view
@@ -238,16 +238,17 @@ 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+-- | 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 = findRootedLCM s t- childLCMs = map (findSmallLCM s) (subTrees 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 @@ -255,12 +256,16 @@ (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)+ filter ((<=n) . operationDegree) 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)+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)+ -- | 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@@ -351,16 +356,7 @@ -- | 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))+findAllSPolynomials = findInitialSPolynomials maxBound -- | Finds all S polynomials for which the operationdegree stays bounded. findInitialSPolynomials :: (Ord a, Show a, TreeOrdering t, Fractional n) =>@@ -371,8 +367,7 @@ let lmg1 = leadingMonomial g1 lmg2 = leadingMonomial g2 cf12 = (leadingCoefficient g1) / (leadingCoefficient g2)- gamma <- nub $ findAllLCM lmg1 lmg2- guard $ (operationDegree gamma) <= n+ gamma <- nub $ findAllBoundedLCM n lmg1 lmg2 mg1 <- findAllEmbeddings lmg1 gamma mg2 <- findAllEmbeddings lmg2 gamma return $ (applyReconstruction mg1 g1) - (cf12 .*. (applyReconstruction mg2 g2))@@ -407,11 +402,7 @@ -- 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+stepOperadicBuchberger oldGb newGb = stepInitialOperadicBuchberger 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. @@ -430,13 +421,7 @@ -- 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+operadicBuchberger gb = nub $ initialOperadicBuchberger maxBound 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@@ -447,12 +432,13 @@ 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 + else let+ gbn = stepInitialOperadicBuchberger maxOD oldgb new+ gbo = nub $ oldgb ++ new+ gbc = gbn \\ gbo+ in+ operadicBuchbergerAcc gbo gbc+ in nub $ 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]
Math/Operad/OrderedTree.hs view
@@ -26,7 +26,7 @@ -- 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 { + DTVertex { vertexType :: !a, subTrees :: ![PreDecoratedTree a b]} deriving (Eq, Ord, Read, Show)@@ -96,6 +96,8 @@ -- | 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+ treeCompare o t1 t2 = comparePathSequence o (orderedPathSequence t1) (orderedPathSequence t2)+ comparePathSequence :: (Ord a, Show a) => t -> ([[a]],Shuffle) -> ([[a]],Shuffle) -> Ordering ordering :: t -- | Finding the path sequences. cf. Dotsenko-Khoroshkin.@@ -121,16 +123,15 @@ 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+ treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+ else if s == t then EQ + else comparePathSequence o (orderedPathSequence s) (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 in- if s == t then EQ - else if any (/= EQ) cS then head (filter (/=EQ) cS)+ if any (/= EQ) cS then head (filter (/=EQ) cS) else compare perms permt ordering = RPathLex @@ -139,16 +140,15 @@ 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+ treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t+ else if s == t then EQ + else comparePathSequence o (orderedPathSequence s) (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 in- if s == t then EQ - else if any (/= EQ) cs then head (filter (/=EQ) cs)+ if any (/= EQ) cs then head (filter (/=EQ) cs) else compare perms permt ordering = PathLex @@ -157,8 +157,9 @@ instance TreeOrdering ForestLex where- treeCompare = error "Forest lexicographic ordering is not yet implemented."+ comparePathSequence = error "Forest lexicographic ordering is not yet implemented." ordering = ForestLex+ -- ** Utility functions on trees --
OperadTest.hs view
@@ -65,7 +65,11 @@ 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+ acGB = operadicBuchberger ac+ in ((3==) . length $ acGB) &&+ (sort acGB) == (sort . read $ "[OE (fromList [(OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex,1 % 1),(OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 2]},DTLeaf 3]}) PathLex,1 % 1)]),OE (fromList [(OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex,(-1) % 1),(OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 3]},DTLeaf 2]}) PathLex,1 % 1)]),OE (fromList [(OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTVertex {vertexType = 2, subTrees = [DTLeaf 3,DTLeaf 4]}]}]}) PathLex,1 % 1)])]")++ prop_preliekoszul = let a = corolla 2 [1,2]
Operads.cabal view
@@ -1,14 +1,18 @@ Name: Operads-Version: 0.3+Version: 0.4+Stability: alpha License: BSD3 License-file: LICENSE Category: Math+Copyright: © 2009 Mikael Vejdemo Johansson Author: Mikael Vejdemo Johansson 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 Build-Type: Simple Cabal-Version: >=1.2-Extra-source-files: README+Extra-source-files: README CHANGELOG examples/preLieBad.hs examples/example.hs examples/altDual.hs Synopsis: Groebner basis computation for Operads. Description: This is an implementation of the operadic Buchberger algorithm from Vladimir Dotsenko & @@ -144,28 +148,18 @@ 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+ ghc-prof-options: -auto-all Extensions: CPP if flag(mapoperad) CPP-Options: -DUSE_MAPOPERAD
Setup.hs view
@@ -1,3 +1,10 @@ import Distribution.Simple+import Distribution.PackageDescription(PackageDescription)+import Distribution.Simple.LocalBuildInfo(LocalBuildInfo)+import System.Cmd(system)+import Distribution.Simple.LocalBuildInfo -main = defaultMain+main = defaultMainWithHooks (simpleUserHooks {runTests = runzeTests})++runzeTests:: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runzeTests a b pd lb = system ( "./dist/build/OperadTest/OperadTest") >> return()