diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,31 @@ +Changes 0.6 -> 0.7 +Sun May 3 22:18:13 CEST 2009 mik@stanford.edu + * Stopped building test file - bug report from dons + + + +Changes 0.5 -> 0.6 +Thu Apr 30 10:25:29 CEST 2009 mik@stanford.edu + * ForestLex implemented + +Thu Apr 30 09:13:50 CEST 2009 mik@stanford.edu + * Path sequence comparisons have trees around if they need them. + +Thu Apr 30 09:12:30 CEST 2009 mik@stanford.edu + * Added flag controlling which Map data structure to use. + +Thu Apr 30 09:11:16 CEST 2009 mik@stanford.edu + * Adding and interleaving reductions in the Buchberger algorithm + +Wed Apr 29 11:41:03 CEST 2009 mik@stanford.edu + * Hackage rerelease - forgot to include one vital module. + +Wed Apr 29 11:40:48 CEST 2009 mik@stanford.edu + * Optimized order comparison + +Wed Apr 29 11:14:59 CEST 2009 mik@stanford.edu + * Changelog update + Changes 0.4 -> 0.5 Wed Apr 29 11:12:12 CEST 2009 mik@stanford.edu * Preparing for v0.5 diff --git a/Math/Operad/Map.hs b/Math/Operad/Map.hs --- a/Math/Operad/Map.hs +++ b/Math/Operad/Map.hs @@ -23,9 +23,8 @@ dot (ST _ _ pdt) = pdt instance (Ord a, Show a, TreeOrdering t) => Ord (StoredTree a t) where - compare (ST pathseq pathperm (OT _ o)) (ST pathseq' pathperm' (OT _ _)) = - comparePathSequence o (pathseq,pathperm) (pathseq', pathperm') --- where _ = ordering :: t + compare (ST pathseq pathperm (OT t o)) (ST pathseq' pathperm' (OT s _)) = + comparePathSequence o t (pathseq,pathperm) s (pathseq', pathperm') data (Ord a, Show a, TreeOrdering t) => Map a t v = TM (M.Map (StoredTree a t) v) deriving (Show, Read, Eq, Ord) diff --git a/Math/Operad/MapOperad.hs b/Math/Operad/MapOperad.hs --- a/Math/Operad/MapOperad.hs +++ b/Math/Operad/MapOperad.hs @@ -5,22 +5,33 @@ module Math.Operad.MapOperad where +#ifndef USE_OLDMAP import qualified Math.Operad.Map as Map import Math.Operad.Map (Map) +#else +import qualified Data.Map as Map +import Data.Map (Map) +#endif import Data.Maybe import Math.Operad.OrderedTree import Math.Operad.PPrint +#ifndef USE_OLDMAP +type MonomialMap a t n = Map a t n +#else +type MonomialMap a t n = Map (OrderedTree a t) n +#endif + -- | 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 a t n) deriving (Eq, Ord, Show, Read) +newtype (Ord a, Show a, TreeOrdering t) => OperadElement a n t = OE (MonomialMap 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 a t n +extractMap :: (Ord a, Show a, TreeOrdering t) => OperadElement a n t -> MonomialMap a t n extractMap (OE m) = m -- | Arithmetic in the operad. diff --git a/Math/Operad/OperadGB.hs b/Math/Operad/OperadGB.hs --- a/Math/Operad/OperadGB.hs +++ b/Math/Operad/OperadGB.hs @@ -452,7 +452,15 @@ -- | 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 +reduceBasis gb = let + reduceAcc ngb [] = ngb + reduceAcc ngb (g:gs) = let + ng = reduceCompletely g ngb + ngb' = if isZero ng then ngb else ng:ngb + in + reduceAcc ngb' gs + in + reduceAcc [] (reverse . sortBy (comparing leadingMonomial) $ gb) -- ** Low degree bases diff --git a/Math/Operad/OrderedTree.hs b/Math/Operad/OrderedTree.hs --- a/Math/Operad/OrderedTree.hs +++ b/Math/Operad/OrderedTree.hs @@ -96,8 +96,9 @@ -- | 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 + treeCompare o t1 t2 = comparePathSequence o t1 (orderedPathSequence t1) t2 (orderedPathSequence t2) + comparePathSequence :: (Ord a, Show a) => + t -> DecoratedTree a -> ([[a]],Shuffle) -> DecoratedTree a -> ([[a]],Shuffle) -> Ordering ordering :: t -- | Finding the path sequences. cf. Dotsenko-Khoroshkin. @@ -125,8 +126,8 @@ instance TreeOrdering RPathLex where 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 + else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t) + comparePathSequence _ _ (paths,perms) _ (patht,permt) = let clS = zipWith (comparing length) paths patht coS = zipWith compare paths patht cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS @@ -142,8 +143,8 @@ instance TreeOrdering PathLex where 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 + else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t) + comparePathSequence _ _ (paths,perms) _ (patht,permt) = let clS = zipWith (comparing length) paths patht coS = zipWith compare paths patht cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS @@ -152,14 +153,63 @@ else compare perms permt ordering = PathLex +data PathRLex = PathRLex deriving (Eq, Ord, Show, Read) +instance TreeOrdering PathRLex where + treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t + else if s == t then EQ + else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t) + comparePathSequence _ _ (paths,perms) _ (patht,permt) = let + clS = zipWith (comparing length) paths patht + coS = zipWith compare paths patht + cs = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else comp1) clS coS + in + if any (/= EQ) cs then head (filter (/=EQ) cs) + else reverseOrder $ compare perms permt + ordering = PathRLex + +data RPathRLex = RPathRLex deriving (Eq, Ord, Show, Read) +instance TreeOrdering RPathRLex where + treeCompare o s t = if (nLeaves s) /= (nLeaves t) then comparing nLeaves s t + else if s == t then EQ + else comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t) + comparePathSequence _ _ (paths,perms) _ (patht,permt) = let + clS = zipWith (comparing length) paths patht + coS = zipWith compare paths patht + cS = zipWith (\comp1 comp2 -> if comp1 == EQ then comp2 else reverseOrder comp1) clS coS + in + if any (/= EQ) cS then head (filter (/=EQ) cS) + else reverseOrder $ compare perms permt + ordering = RPathRLex + -- | Forest lexicographic ordering. Currently not implemented. data ForestLex = ForestLex deriving (Eq, Ord, Show) - instance TreeOrdering ForestLex where - comparePathSequence = error "Forest lexicographic ordering is not yet implemented." + treeCompare o s t = comparePathSequence o s (orderedPathSequence s) t (orderedPathSequence t) + comparePathSequence _ (DTLeaf k) _ (DTLeaf l) _ = compare l k + comparePathSequence _ (DTLeaf _) _ _ _ = LT + comparePathSequence _ _ _ (DTLeaf _) _ = GT + comparePathSequence o s (paths, perms) t (patht, permt) = let + c1 = compare (vertexArity s) (vertexArity t) + c2 = compare (vertexType s) (vertexType t) + ls = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees s)) + lt = map (sort . leafOrder) (sortBy (comparing minimalLeaf) (subTrees t)) + c3s = zipWith (\sl tl -> case comparing length sl tl of + LT -> LT + GT -> GT + EQ -> reverseOrder $ compare sl tl) ls lt + c3f = filter (/= EQ) c3s + c4f = filter (/= EQ) $ zipWith + (treeCompare o) + (sortBy (comparing minimalLeaf) (subTrees s)) + (sortBy (comparing minimalLeaf) (subTrees t)) + in + if c1 /= EQ then c1 + else if c2 /= EQ then c2 + else if not (null c3f) then head c3f + else if null c4f then EQ + else head c4f ordering = ForestLex - -- ** Utility functions on trees -- diff --git a/OperadTest.hs b/OperadTest.hs --- a/OperadTest.hs +++ b/OperadTest.hs @@ -70,7 +70,23 @@ (sort acGB) == (sort . read $ "[OE (TM (fromList [(ST [[2],[2,2],[2,2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex),1 % 1),(ST [[2,2],[2,2],[2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 2]},DTLeaf 3]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[2],[2,2],[2,2]] [1,2,3] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTLeaf 3]}]}) PathLex),(-1) % 1),(ST [[2,2],[2],[2,2]] [1,3,2] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTLeaf 3]},DTLeaf 2]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[2],[2,2],[2,2,2],[2,2,2]] [1,2,3,4] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1,DTVertex {vertexType = 2, subTrees = [DTLeaf 2,DTVertex {vertexType = 2, subTrees = [DTLeaf 3,DTLeaf 4]}]}]}) PathLex),1 % 1)]))]") +prop_noncom = let + x = corolla 1 [1] + y = corolla 2 [1] + x2y = nsCompose 1 x (nsCompose 1 x y) + xy2 = nsCompose 1 x (nsCompose 1 y y) + xy = nsCompose 1 x y + yx = nsCompose 1 y x + one = head $ subTrees x + ox2y = oet x2y :: OperadElement Integer Rational PathLex + oxy2 = oet xy2 :: OperadElement Integer Rational PathLex + oxy = oet xy :: OperadElement Integer Rational PathLex + oyx = oet yx :: OperadElement Integer Rational PathLex + oone = oet one :: OperadElement Integer Rational PathLex + gb = [ox2y-oone, oxy2-oone, oxy-oyx] + in (sort . operadicBuchberger $ gb) == (sort . read $ "[OE (TM (fromList [(ST [[]] [1] (OT (DTLeaf 1) PathLex),(-1) % 1),(ST [[1,1,1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}]}]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[1]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}) PathLex),(-1) % 1),(ST [[2]] [1] (OT (DTVertex {vertexType = 2, subTrees = [DTLeaf 1]}) PathLex),1 % 1)])),OE (TM (fromList [(ST [[1,2]] [1] (OT (DTVertex {vertexType = 1, subTrees = [DTVertex {vertexType = 2, subTrees = [DTLeaf 1]}]}) PathLex),1 % 1),(ST [[2,1]] [1] (OT (DTVertex {vertexType = 2, subTrees = [DTVertex {vertexType = 1, subTrees = [DTLeaf 1]}]}) PathLex),(-1) % 1)]))]" :: [OperadElement Integer Rational PathLex]) + prop_preliekoszul = let a = corolla 2 [1,2] b = corolla 1 [1,2] @@ -139,5 +155,6 @@ -} ("Anticommutative has 3 element basis",test prop_anticom), -- ("Pre-Lie with the wrong order",test prop_prelie), - ("Pre-Lie is Koszul",test prop_preliekoszul) + ("Pre-Lie is Koszul",test prop_preliekoszul), + ("Sample non-commutative algebra grobner basis",test prop_noncom) ] diff --git a/Operads.cabal b/Operads.cabal --- a/Operads.cabal +++ b/Operads.cabal @@ -1,5 +1,5 @@ Name: Operads -Version: 0.6 +Version: 0.7 Stability: alpha License: BSD3 License-file: LICENSE @@ -12,7 +12,7 @@ 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 CHANGELOG examples/preLieBad.hs examples/example.hs examples/altDual.hs +Extra-source-files: README CHANGELOG examples/preLieBad.hs examples/example.hs examples/altDual.hs OperadTest.hs Synopsis: Groebner basis computation for Operads. Description: This is an implementation of the operadic Buchberger algorithm from Vladimir Dotsenko & @@ -148,12 +148,12 @@ Description: Use the head bag based storage for formal linear combinations. Default: False -Executable OperadTest - Main-is: OperadTest.hs - Extensions: CPP - Build-Depends: QuickCheck +Flag UseOldMap + Description: Don't use the Data.Map wrapper class Math.Operad.Map. This will slow down computation. + Default: False + Library Build-Depends: base, array, mtl, containers Exposed-Modules: Math.Operad @@ -165,3 +165,5 @@ CPP-Options: -DUSE_MAPOPERAD if flag(polybag) CPP-Options: -DUSE_POLYBAG + if flag(useoldmap) + CPP-Options: -DUSE_OLDMAP