diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -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 diff --git a/Math/Operad/OperadGB.hs b/Math/Operad/OperadGB.hs --- a/Math/Operad/OperadGB.hs +++ b/Math/Operad/OperadGB.hs @@ -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] diff --git a/Math/Operad/OrderedTree.hs b/Math/Operad/OrderedTree.hs --- a/Math/Operad/OrderedTree.hs +++ b/Math/Operad/OrderedTree.hs @@ -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 -- diff --git a/OperadTest.hs b/OperadTest.hs --- a/OperadTest.hs +++ b/OperadTest.hs @@ -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] diff --git a/Operads.cabal b/Operads.cabal --- a/Operads.cabal +++ b/Operads.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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()