monoids 0.1.25 → 0.1.28

raw patch · 6 files changed

+352/−6 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Monoid/Combinators.hs +0/−1
• Data/Monoid/Union.hs +3/−3
• Data/Ring/Module.hs +12/−0
• Data/Ring/Semi/BitSet.hs +279/−0
• Data/Ring/Semi/Near/Trie.hs +54/−0
• monoids.cabal +4/−2

@@ -27,7 +27,6 @@     ) where  import Prelude hiding (replicate, cycle, repeat)-import Control.Monad (MonadPlus) import Data.Monoid.Reducer import Test.QuickCheck 

@@ -29,7 +29,7 @@  import Control.Functor.Pointed -import Data.Monoid.Reducer (Reducer, unit, cons, snoc, Monoid, mappend, mempty)+import Data.Monoid.Reducer  -- | A Container suitable for the 'Union' 'Monoid' class HasUnion f where@@ -82,7 +82,7 @@     extract = getUnion  -- | Polymorphic containers that we can supply an operation to handle unions with-class HasUnionWith f where+class Functor f => HasUnionWith f where     {-# SPECIALIZE unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a #-}     {-# SPECIALIZE unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a #-}     unionWith :: (a -> a -> a) -> f a -> f a -> f a@@ -96,7 +96,6 @@     emptyWith = Map.empty     unionWith = Map.unionWith - -- | The 'Monoid' @('unionWith mappend','empty')@ for containers full of monoids. newtype UnionWith f m = UnionWith { getUnionWith :: f m }      deriving (Eq,Ord,Show,Read,Functor,Pointed,Monad)@@ -108,3 +107,4 @@ instance (HasUnionWith f, Monoid m) => Reducer (f m) (UnionWith f m) where     unit = UnionWith +-- we want an absorbing 0, for that we need a seminearring and a notion of equality

@@ -24,6 +24,8 @@     ) where  import Data.Ring+import Data.Monoid.Union+ -- import qualified Data.Monoid.Combinators as Monoid  -- | @ (x * y) *. m = x * (y *. m) @@@ -59,3 +61,13 @@ instance (Module r m, Module r n, Module r o) => Module r (m,n,o) instance (Module r m, Module r n, Module r o, Module r p) => Module r (m,n,o,p) instance (Module r m, Module r n, Module r o, Module r p, Module r q) => Module r (m,n,o,p,q)+++-- we want an absorbing 0, for that we need a seminearring and a notion of equality+instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => LeftModule r (UnionWith f r) where+    r *. m | r == zero = zero+           | otherwise = fmap (r `times`) m+instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => RightModule r (UnionWith f r) where+    m .* r | r == zero = zero+           | otherwise = fmap (`times` r) m+instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => Module r (UnionWith f r) where

@@ -0,0 +1,279 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable, BangPatterns, PatternGuards, TypeFamilies #-}+module Data.Ring.Semi.BitSet+    ( module Data.Monoid.Reducer+    , BitSet+    , empty+    , singleton+    , null+    , full+    , complement+    , insert+    , delete+    , fromList+    , fromDistinctAscList+    , toInteger+    , (\\)+    , member+    , size+    ) where++import Prelude hiding ( null, exponent, toInteger )+import Data.Bits hiding ( complement )+import qualified Data.Bits as Bits+import Data.Data+import Data.Ring.Semi.Natural+import Data.Monoid.Reducer+import Data.Generator+import Data.Ring.Algebra++data BitSet a = BS +        { _countAtLeast  :: {-# UNPACK #-} !Int       -- ^ a conservative upper bound on the element count+        , _countAtMost   :: {-# UNPACK #-} !Int       -- ^ a conservative lower bound on the element count+        , _count         :: Int                       -- ^ the actual element count (lazy) used when the above two disagree+        , exponent       :: {-# UNPACK #-} !Int       -- ^ low water mark+        , _hwm           :: {-# UNPACK #-} !Int       -- ^ high water mark+        , mantissa       :: {-# UNPACK #-} !Integer   -- ^ the set of bits. TODO: negative mantissa = complement+        , _universe      :: (Int,Int)                 -- ^ invariant: mantissa < 0 => universe = (fromEnum minBound,fromEnum maxBound)+        } deriving (Data, Typeable,Show)++debug :: BitSet a -> (Int,Int,Int,Int,Int,Integer)+debug (BS a b c d e f _) = (a,b,c,d,e,f)++-- | internal smart constructor: makes sure the count is forced when known+bs :: Int -> Int -> Int -> Int -> Int -> Integer -> (Int,Int) -> BitSet a+bs !a !b c !l !h !m u | a == b = BS a a a l h m u+                      | otherwise = BS a b c l h m u+{-# INLINE bs #-}++-- instance (Enum a, Show a) => Show (BitSet a) where+--    show s = "fromDistinctAscList " ++ show (toList s) ++ ++-- | /O(d)/ where /d/ is absolute deviation in fromEnum from the least element in the set.+toList :: Enum a => BitSet a -> [a]+toList (BS _ _ _ l h m u) +    | m < 0 = map toEnum [ul..max (pred l) ul] ++ toList' l (map toEnum [min (succ h) uh..uh])+    | otherwise = toList' 0 []+    where+        ~(ul,uh) = u+        toList' :: Enum a => Int -> [a] -> [a]+        toList' !n t | n > h = t+                     | testBit m (n - l) = toEnum n : toList' (n+1) t+                     | otherwise         = toList' (n+1) t+{-# INLINE toList #-}++-- | The empty bit set.+empty :: BitSet a+empty = BS 0 0 0 0 0 0 undefined+{-# INLINE empty #-}++singleton :: Enum a => a -> BitSet a +singleton x = BS 1 1 1 e e 1 undefined where e = fromEnum x+{-# INLINE singleton #-}++-- | Is the bit set empty? Asymptotically faster than checking if size == 0 in some cases.+null :: BitSet a -> Bool+null (BS a b c _ _ _ _) +    | a > 0     = False+    | b == 0    = True+    | otherwise = c == 0 +{-# INLINE null #-}++full :: (Enum a, Bounded a) => BitSet a+full = complement empty ++universeOf :: (Bounded a, Enum a) => BitSet a -> (Int,Int)+universeOf x = (fromEnum (minBound `asArgTypeOf` x), fromEnum (maxBound `asArgTypeOf` x))++-- ensures valid universe, may result in negative bitset, note recalculation of universe+complement :: (Enum a, Bounded a) => BitSet a -> BitSet a +complement r@(BS a b c l h m _) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) (universeOf r)++-- proof obligation: either the value is already complemented or it is a complement-complement, note retention of u+recomplement :: BitSet a -> BitSet a +recomplement (BS a b c l h m u) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u++-- | /O(d * n)/ Make a @BitSet@ from a list of items.+fromList :: Enum a => [a] -> BitSet a+fromList = foldr insert empty +{-# INLINE fromList #-}++fromDistinctAscList :: Enum a => [a] -> BitSet a +fromDistinctAscList [] = empty+fromDistinctAscList (c:cs) = fromDistinctAscList' cs 1 0 1 +    where+        l = fromEnum c+        fromDistinctAscList' :: Enum a => [a] -> Int -> Int -> Integer -> BitSet a+        fromDistinctAscList' [] !n !h !m  = BS n n n l h m undefined+        fromDistinctAscList' (c':cs') !n _ !m = fromDistinctAscList' cs' (n+1) h' (setBit m (h' - l))+            where+                h' = fromEnum c'+{-# INLINE fromDistinctAscList #-}++-- | /O(d)/ Insert an item into the bit set.+insert :: Enum a => a -> BitSet a -> BitSet a+insert x r@(BS a b c l h m u) +    | m < 0, e < l = r +    | m < 0, e > h = r+    | e < l = bs (a+1) (b+1) (c+1) e (h - e) (shiftL m (l - e) .|. 1) u+    | e > h = bs (a+1) (b+1) (c+1) l p (setBit m p) u+    | testBit m (e - l) = r +    | otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) u+    where +        e = fromEnum x+        p = e - l +{-# INLINE insert #-}++-- | /O(d)/ Delete an item from the bit set.+delete :: Enum a => a -> BitSet a -> BitSet a+delete x r@(BS a b c l h m u) +    | m < 0, e < l = bs (a+1) (b+1) (c+1) e (h - e) (shiftL m (l - e) .&. Bits.complement 1) u+    | m < 0, e > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u+    | e < l       = r+    | e > h       = r+    | testBit m p = bs (a-1) (b-1) (c-1) l h (clearBit m p) u+    | otherwise   = r+    where +        e = fromEnum x+        p = e - l+{-# INLINE delete #-}++-- | /O(testBit on Integer)/ Ask whether the item is in the bit set.+member :: Enum a => a -> BitSet a -> Bool+member x (BS _ _ _ l h m _) +    | e < l     = m < 0 +    | e > h     = m > 0+    | otherwise = testBit m (e - l)+    where +        e = fromEnum x+{-# INLINE member #-}++-- | /O(1)/ or /O(d)/ The number of elements in the bit set.+size :: BitSet a -> Int+size (BS a b c _ _ m (ul,uh)) +    | a == b, m >= 0 = a+    | a == b         = uh - ul - a +    | m >= 0         = c+    | otherwise      = uh - ul - c ++-- | /O(d)/ convert to an Integer representation. Discards negative elements+toInteger :: BitSet a -> Integer+toInteger x = mantissa x `shift` exponent x++union :: BitSet a -> BitSet a -> BitSet a +union x@(BS a b c l h m u) y@(BS a' b' c' l' h' m' u')+    | l' < l    = union y x                                                         -- ensure left side has lower exponent+    | b == 0    = y                                                                 -- fast empty union+    | b' == 0   = x                                                                 -- fast empty union+    | a == -1   = BS (-1) (-1) (-1) 0 0 (-1) u                                      -- fast full union, recomplement obligation met by negative size+    | a' == -1  = BS (-1) (-1) (-1) 0 0 (-1) u'                                     -- fast full union, recomplement obligation met by negative size+    | m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y)) -- appeal to intersection, recomplement obligation met by 2s complement+    | m' < 0    = recomplement (pseudoDiff (recomplement y) x u')                      -- union with complement, recomplement obligation met by 2s complement -- THESE ARE WRONG FIX!+    | m < 0     = recomplement (pseudoDiff (recomplement x) y u)                      -- union with complement, recomplement obligation met by 2s complement -- THESE ARE WRONG FIX!+    | h < l'    = bs (a + a') (b + b') (c + c') l h' m'' u                          -- disjoint positive ranges+    | otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' u       -- overlapped positives+    where +        m'' = m .|. shiftL m' (l' - l)++intersection :: BitSet a -> BitSet a -> BitSet a +intersection x@(BS a b _ l h m u) y@(BS a' b' _ l' h' m' u')+    | l' < l = intersection y x                                 +    | b == 0 = empty+    | b' == 0 = empty+    | a == -1 = y+    | a' == -1 = x+    | m < 0, m' < 0 = recomplement (union (recomplement x) (recomplement y))+    | m' < 0 = pseudoDiff x (recomplement y) u'+    | m < 0 = pseudoDiff y (recomplement x) u+    | h < l' = empty +    | otherwise = bs 0 (b `min` b') (recount m'') l'' (h `min` h') m'' u+    where+        l'' = max l l'+        m'' = shift m (l'' - l) .&. shift m' (l'' - l')++-- we know m >= 0, m' >= 0, a /= -1, a' /= -1, b /= 0, b' /= 0, u' is the universe of discourse+pseudoDiff :: BitSet a -> BitSet a -> (Int,Int) -> BitSet a +pseudoDiff x@(BS a _ _ l h m _) (BS _ b' _ l' h' m' _) u''+    | h < l' = x+    | h' < l = x+    | otherwise = bs (max (a - b') 0) a (recount m'') l h m'' u''+    where m'' = m .&. shift (Bits.complement m') (l' - l)++(\\) :: (Enum a, Bounded a) => BitSet a -> BitSet a -> BitSet a +x \\ y = x `intersection` complement y++-- TODO: fix this so that it handles complements correctly+instance Eq (BitSet a) where+    BS _ _ _ l _ m _ == BS _ _ _ l' _ m' _ = shift m (l'' - l) == shift m' (l'' - l) where l'' = min l l'+    BS _ _ _ l _ m _ /= BS _ _ _ l' _ m' _ = shift m (l'' - l) /= shift m' (l'' - l) where l'' = min l l'++instance Ord (BitSet a) where+    BS _ _ _ l _ m _ `compare` BS _ _ _ l' _ m' _ = shift m (l'' - l) `compare` shift m' (l'' - l) where l'' = min l l'++instance (Enum a, Bounded a) => Bounded (BitSet a) where+    minBound = empty+    maxBound = result where+        result = BS n n n l h m (l,h)+        n = h - l + 1+        l = fromEnum (minBound `asArgTypeOf` result)+        h = fromEnum (maxBound `asArgTypeOf` result)+        m = setBit 0 n - 1++asArgTypeOf :: a -> f a -> a+asArgTypeOf = const+{-# INLINE asArgTypeOf #-}++recount :: Integer -> Int+recount = recount' 0 where+    recount' :: Int -> Integer -> Int+    recount' !n 0 = n+    recount' !n !m = recount' (if testBit m 0 then n+1 else n) (shiftR m 1)++-- note that operations on values generated by toEnum are pretty slow because the bounds are suboptimal+instance (Enum a, Bounded a) => Enum (BitSet a) where+    fromEnum b@(BS _ _ _ l _ m _) = fromInteger (shiftL m (l - l'))+        where +            l' = fromEnum (minBound `asArgTypeOf` b)+    toEnum i = result +        where+            result = BS a i (recount m) l h m undefined -- n <= 2^n, so i serves as a valid upper bound+            l = fromEnum (minBound `asArgTypeOf` result)+            h = fromEnum (maxBound `asArgTypeOf` result)+            m = fromIntegral i+            a | m /= 0 = 1 -- allow a fast null check, but not much else+              | otherwise = 0+        +instance Enum a => Monoid (BitSet a) where+    mempty = empty+    mappend = union++instance Enum a => Reducer a (BitSet a) where+    unit = singleton+    snoc = flip insert+    cons = insert++instance (Bounded a, Enum a) => Multiplicative (BitSet a) where+    one = full+    times = intersection++instance (Bounded a, Enum a) => LeftSemiNearRing (BitSet a)+instance (Bounded a, Enum a) => RightSemiNearRing (BitSet a)+instance (Bounded a, Enum a) => SemiRing (BitSet a)++-- idempotent monoid+instance Enum a => LeftModule Natural (BitSet a) where+    0 *. _ = empty+    _ *. m = m+instance Enum a => RightModule Natural (BitSet a) where+    _ .* 0 = empty+    m .* _ = m+instance Enum a => Module Natural (BitSet a)++instance (Bounded a, Enum a) => LeftModule (BitSet a) (BitSet a) where (*.) = times+instance (Bounded a, Enum a) => RightModule (BitSet a) (BitSet a) where (.*) = times+instance (Bounded a, Enum a) => Module (BitSet a) (BitSet a)++instance (Bounded a, Enum a) => Algebra Natural (BitSet a)+    +instance Enum a => Generator (BitSet a) where+    type Elem (BitSet a) = a+    mapReduce f = mapReduce f . toList

@@ -0,0 +1,54 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+module Data.Ring.Semi.Near.Trie +    ( module Data.Ring.Semi.Near+    , Trie(Trie, total, label, children)+    , singleton+    , empty+    , null+    ) where+    ++import Data.Map (Map)+import qualified Data.Map as Map+--import Data.Monoid.Multiplicative+--import Data.Monoid.Reducer+import Data.Monoid.Union hiding (empty)+--import Data.Ring.Module+import Data.Ring.Semi.Near+import Prelude hiding (null)++singleton :: (Ord c, c `Reducer` m) => c -> Trie c m +singleton = unit++empty :: (Ord c, Monoid m) => Trie c m+empty = zero++null :: Ord c => Trie c m -> Bool+null = Map.null . getUnionWith . children++data Trie c m = Trie { total :: m, label :: m, children :: UnionWith (Map c) (Trie c m) }+    deriving (Eq,Show)++instance Functor (Trie c) where+    fmap f (Trie t e r) = Trie (f t) (f e) (fmap (fmap f) r)++instance (Ord c, Monoid m) => Monoid (Trie c m) where+    mempty = Trie mempty mempty mempty+    Trie x y z `mappend` Trie x' y' z' = Trie (x `mappend` x') (y `mappend` y') (z `mappend` z')++instance (Ord c, c `Reducer` m) => Reducer c (Trie c m) where+    unit c = Trie r zero . UnionWith $ flip Map.singleton (Trie r r zero) c where r = unit c++{-+instance (Ord c, Eq r, RightSemiNearRing r) => Multiplicative (Trie c r) where+    one = Trie one one zero+    Trie t e r `times` rhs@(Trie t' e' r') = +        Trie (t `times` t') (e `times` e') (r .* rhs `plus` lhs *. r') where+            lhs = Trie e e zero `asTypeOf` rhs++instance (Ord c, Eq r, RightSemiNearRing r) => RightSemiNearRing (Trie c r)++toList :: (Ord c, c `Reducer` [c]) => Trie c m -> [[c]]+toList = fmap merge . Map.assocs . getUnionWith . children where+    merge (k,t) = k `times` toList t+-}

@@ -1,12 +1,12 @@ name:		    monoids-version:	    0.1.25+version:	    0.1.28 license:	    BSD3 license-file:   LICENSE author:		    Edward A. Kmett maintainer:	    Edward A. Kmett <ekmett@gmail.com> stability:	    experimental homepage:	    http://comonad.com/reader-category:	    Data+category:	    Data, Math, Numerical, Natural Language Processing, Parsing synopsis:	    Monoids, specialized containers and a general map/reduce framework description:    Monoids, specialized containers and a general map/reduce framework copyright:      (c) 2009 Edward A. Kmett@@ -69,7 +69,9 @@     Data.Ring.Module     Data.Ring.Module.AutomaticDifferentiation     Data.Ring.Semi+    Data.Ring.Semi.BitSet     Data.Ring.Semi.Near+    Data.Ring.Semi.Near.Trie     Data.Ring.Semi.Natural     Data.Ring.Semi.Ord     Data.Ring.Semi.Tropical