packages feed

monoids 0.1.32 → 0.1.33

raw patch · 16 files changed

+1440/−121 lines, 16 files

Files

Data/Monoid/Applicative.hs view
@@ -73,6 +73,8 @@ instance Alternative f => Reducer (f a) (Alt f a) where     unit = Alt  +instance (Alternative f, Monoid a) => Ringoid (Alt f a)+ instance (Alternative f, Monoid a) => RightSemiNearRing (Alt f a)  -- | if @m@ is a 'Module' over @r@ and @f@ is a 'Applicative' then @f `App` m@ is a 'Module' over @r@ as well
Data/Monoid/Lexical/SourcePosition.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, BangPatterns #-}  ----------------------------------------------------------------------------- -- |@@ -44,15 +44,15 @@ -- | A 'Monoid' of partial information about locations in a source file. --   This is polymorphic in the kind of information you want to maintain about each source file. data SourcePosition file -        = Pos file {-# UNPACK #-} !SourceLine !SourceColumn -- ^ An absolute position in a file is known, or an overriding #line directive has been seen-        | Lines {-# UNPACK #-} !SourceLine !SourceColumn    -- ^ We've seen some carriage returns.-        | Columns {-# UNPACK #-} !SourceColumn              -- ^ We've only seen part of a line.-        | Tab {-# UNPACK #-} !SourceColumn !SourceColumn    -- ^ We have an unhandled tab to deal with.+        = Pos file {-# UNPACK #-} !SourceLine {-# UNPACK #-} !SourceColumn -- ^ An absolute position in a file is known, or an overriding #line directive has been seen+        | Lines {-# UNPACK #-} !SourceLine {-# UNPACK #-} !SourceColumn    -- ^ We've seen some carriage returns.+        | Columns {-# UNPACK #-} !SourceColumn                             -- ^ We've only seen part of a line.+        | Tab {-# UNPACK #-} !SourceColumn {-# UNPACK #-} !SourceColumn    -- ^ We have an unhandled tab to deal with.     deriving (Read,Show,Eq)  -- | Compute the location of the next standard 8-column aligned tab nextTab :: Int -> Int-nextTab x = x + (8 - (x-1) `mod` 8)+nextTab !x = x + (8 - (x-1) `mod` 8)  instance Functor SourcePosition where     fmap g (Pos f l c) = Pos (g f) l c
Data/Monoid/Monad.hs view
@@ -83,6 +83,8 @@ instance MonadPlus m => Reducer (m a) (MonadSum m a) where     unit = MonadSum +instance (MonadPlus m, Monoid a) => Ringoid (MonadSum m a)+ instance (MonadPlus m, Monoid a) => RightSemiNearRing (MonadSum m a)  -- | if @m@ is a 'Module' over @r@ and @f@ is a 'Monad' then @f `Mon` m@ is a 'Module' as well
Data/Ring/Algebra.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} module Data.Ring.Algebra     ( module Data.Ring.Module-    , Algebra+    , RAlgebra     ) where  import Data.Ring.Module --- |  +-- | Algebra over a (near) (semi) ring.+-- -- @r *. (x * y) = (r *. x) * y = x * (r *. y)@ -- -- @(x * y) .* r = y * (x .* r) = (y .* r) * x@-class (r `Module` m, Multiplicative m) => Algebra r m +class (r `Module` m, Multiplicative m) => RAlgebra r m
Data/Ring/Boolean.hs view
@@ -37,6 +37,7 @@     one = BoolRing True     BoolRing a `times` BoolRing b = BoolRing (a && b) +instance Ringoid BoolRing instance LeftSemiNearRing BoolRing instance RightSemiNearRing BoolRing instance SemiRing BoolRing
Data/Ring/FromNum.hs view
@@ -38,6 +38,7 @@     times = (*)  -- you can assume these, but you're probably lying to yourself+instance Num a => Ringoid (FromNum a) instance Num a => LeftSemiNearRing (FromNum a) instance Num a => RightSemiNearRing (FromNum a) instance Num a => SemiRing (FromNum a)
Data/Ring/ModularArithmetic.hs view
@@ -65,6 +65,7 @@     minus = (-)     gsubtract = subtract +instance (Modular s a, Integral a) => Ringoid (a `Mod` s) instance (Modular s a, Integral a) => LeftSemiNearRing (a `Mod` s) instance (Modular s a, Integral a) => RightSemiNearRing (a `Mod` s) instance (Modular s a, Integral a) => SemiRing (a `Mod` s)
Data/Ring/Module/AutomaticDifferentiation.hs view
@@ -26,10 +26,10 @@  data D s r m = D r m deriving (Show,Read) -lift :: Monoid m => r -> D s r m+lift :: (r `Module` m) => r -> D s r m lift x = D x zero -infinitesimal :: (Monoid r, Multiplicative m) => D s r m+infinitesimal :: (r `Module` m, Ringoid m) => D s r m infinitesimal = D zero one  instance Eq r => Eq (D s r m) where@@ -38,7 +38,7 @@ instance Ord r => Ord (D s r m) where     D x _ `compare` D y _ = compare x y -instance (Monoid r, Monoid m) => Monoid (D s r m) where+instance (r `Module` m) => Monoid (D s r m) where     mempty = D mempty mempty     D x m `mappend` D y n = D (x `mappend` y) (m `mappend` n) @@ -64,12 +64,13 @@     recip (D x x') = D (recip x) (-x'/x/x)     fromRational x = D (fromRational x) 0 +instance (Ringoid r, r `Module` m) => Ringoid (D s r m) instance (LeftSemiNearRing r, Module r m) => LeftSemiNearRing (D s r m) instance (RightSemiNearRing r, Module r m) => RightSemiNearRing (D s r m)-instance (SemiRing r, Module r m) => SemiRing (D s r m)-instance (Ring r, Module r m, Group m) => Ring (D s r m)+instance (SemiRing r, r `Module` m) => SemiRing (D s r m)+instance (Ring r, r `Module` m, Group m) => Ring (D s r m) -instance (c `Reducer` r, c `Reducer` m) => Reducer c (D s r m) where+instance (r `Module` m, c `Reducer` r, c `Reducer` m) => Reducer c (D s r m) where     unit c = D (unit c) (unit c)     c `cons` D x m = D (c `cons` x) (c `cons` m)     D x m `snoc` c = D (x `snoc` c) (m `snoc` c)@@ -81,6 +82,6 @@ instance (CoArbitrary r, CoArbitrary m) => CoArbitrary (D s r m) where     coarbitrary (D r m) = coarbitrary r >< coarbitrary m -d :: (Monoid r, Multiplicative m) => (forall s. D s r m -> D s r m) -> (r,m)+d :: (r `Module` m, Ringoid m) => (forall s. D s r m -> D s r m) -> (r,m) d f = (y,y') where D y y' = f infinitesimal
Data/Ring/Semi/BitSet.hs view
@@ -14,6 +14,7 @@ -- can return negative values, support efficient intersection and union -- and allow complementing of the set with respect to the bounds of the -- enumeration+-- -------------------------------------------------------------------------------  module Data.Ring.Semi.BitSet@@ -41,9 +42,10 @@     , toInteger     ) where -import Prelude hiding ( null, exponent, toInteger )+import Prelude hiding ( null, exponent, toInteger, foldl, foldr, foldl1, foldr1 ) import Data.Bits hiding ( complement ) import qualified Data.Bits as Bits+import Data.Foldable hiding ( toList ) import Data.Data import Data.Ring.Semi.Natural import Data.Ring.Semi@@ -53,60 +55,71 @@ import Text.Read import Text.Show +-- | Set operations optimized for tightly grouped sets or nearly universal sets with a close by group of elements missing.+--   Stores itself like an arbitrary precision floating point number, tracking the least valued member of the set and an+--   Integer comprised of the members.  data BitSet a = BS          { _countAtLeast  :: {-# UNPACK #-} !Int       -- ^ A conservative upper bound on the element count.                                                       --   If negative, we are complemented with respect to the universe         , _countAtMost   :: {-# UNPACK #-} !Int       -- ^ A conservative lower bound on the element count.                                                       --   If negative, we are complemented with respect to the universe-        , _count         :: Int                       -- ^ Lazy element count used when the above two disagree. O(1) environment size+        , _count         ::                 Int       -- ^ Lazy element count used when the above two disagree. O(1) environment size         , exponent       :: {-# UNPACK #-} !Int       -- ^ Low water mark. index of the least element potentially in the set.         , _hwm           :: {-# UNPACK #-} !Int       -- ^ High water mark. index of the greatest element potentially in the set.         , mantissa       :: {-# UNPACK #-} !Integer   -- ^ the set of bits starting from the exponent.                                                       --   if negative, then we are complmenented with respect to universe-        , _universe      :: (Int,Int)                 -- ^ invariant: whenever mantissa < 0 => universe = (fromEnum minBound,fromEnum maxBound)-        } deriving (Data, Typeable)+        , _universe      ::                 (Int,Int) -- ^ invariant: whenever mantissa < 0, universe = (fromEnum minBound,fromEnum maxBound)+        , _fromEnum      ::                 Int -> a  -- ^ self-contained extraction behavior, enables Foldable+        } deriving (Typeable) +-- | omit reflection to preserve abstraction+instance (Enum a, Data a) => Data (BitSet a) where+    gfoldl f z im = z fromList `f` toList im+    toConstr _ = error "toConstr"+    gunfold _ _ = error "gunfold"+    dataTypeOf _ = mkNorepType "Data.Ring.Semi.BitSet.BitSet"+    dataCast1 f = gcast1 f + -- | Internal smart constructor. Forces count whenever it is pigeonholed.-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+bs :: Enum a => 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 toEnum+                      | otherwise = BS a b c l h m u toEnum {-# INLINE bs #-} --- | /O(d)/ where /d/ is absolute deviation in fromEnum over 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])+-- | /O(d)/ where /d/ is absolute deviation in the output of fromEnum over the set+toList :: BitSet a -> [a]+toList (BS _ _ _ l h m u f) +    | m < 0 = map f [ul..max (pred l) ul] ++ toList' l (map f [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+        toList' !n t +            | n > h = t+            | testBit m (n - l) = f n : toList' (n+1) t+            | otherwise         = toList' (n+1) t {-# INLINE toList #-}  -- | /O(1)/ The empty set. Permits /O(1)/ null and size.-empty :: BitSet a-empty = BS 0 0 0 0 0 0 undefined+empty :: Enum a => BitSet a+empty = BS 0 0 0 0 0 0 undefined toEnum {-# INLINE empty #-}  -- | /O(1)/ Construct a @BitSet@ with a single element. Permits /O(1)/ null and size singleton :: Enum a => a -> BitSet a -singleton x = BS 1 1 1 e e 1 undefined where e = fromEnum x+singleton x = BS 1 1 1 e e 1 undefined toEnum where e = fromEnum x {-# INLINE singleton #-} --- | /O(1|d)/ Is the 'BitSet' empty? May be faster than checking if @'size' == 0@ after union.---   Operations that require a recount are noted.+-- | /O(1)/ amortized cost. Is the 'BitSet' empty? May be faster than checking if @'size' == 0@. null :: BitSet a -> Bool-null (BS a b c _ _ _ _) +null (BS a b c _ _ _ _ _)      | a > 0     = False     | b == 0    = True     | otherwise = c == 0  {-# INLINE null #-} --- | /O(1|d)/ The number of elements in the bit set.+-- | /O(1)/ amortized cost. The number of elements in the bit set. size :: BitSet a -> Int-size (BS a b c _ _ m (ul,uh)) +size (BS a b c _ _ m (ul,uh) _)      | a == b, m >= 0 = a     | a == b         = uh - ul - a      | m >= 0         = c@@ -120,18 +133,18 @@  -- | /O(d)/ Complements a 'BitSet' with respect to the bounds of @a@. Preserves order of 'null' and 'size' 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) u where+complement r@(BS a b c l h m _ f) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u f where     u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r)) {-# INLINE complement #-}  -- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once. 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+recomplement (BS a b c l h m u f) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u f {-# INLINE recomplement #-}  -- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once. pseudoComplement :: BitSet a -> (Int,Int) -> BitSet a -pseudoComplement (BS a b c l h m _) u = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u+pseudoComplement (BS a b c l h m _ f) u = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u f {-# INLINE pseudoComplement #-}  -- | /O(d * n)/ Make a 'BitSet' from a list of items.@@ -146,21 +159,23 @@     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'+        fromDistinctAscList' [] !n !h !m  = BS n n n l h m undefined toEnum+        fromDistinctAscList' (c':cs') !n _ !m = +            let h' = fromEnum c' in +            fromDistinctAscList' cs' (n+1) h' (setBit m (h' - l)) {-# INLINE fromDistinctAscList #-}  -- | /O(d)/ Insert a single element of type @a@ into the 'BitSet'. Preserves order of 'null' and 'size' insert :: Enum a => a -> BitSet a -> BitSet a-insert x r@(BS a b c l h m u) +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 (shiftL m (l - e) .|. 1) u-    | e > h = bs (a+1) (b+1) (c+1) l p (setBit m p) u-    | testBit m p = r -    | otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) u+    | b == 0       = singleton x+    | a == -1      = r+    | e < l        = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .|. 1) u+    | e > h        = bs (a+1) (b+1) (c+1) l p (setBit m p) u+    | testBit m p  = r +    | otherwise    = bs (a+1) (b+1) (c+1) l h (setBit m p) u     where          e = fromEnum x         p = e - l @@ -168,13 +183,15 @@  -- | /O(d)/ Delete a single item from the 'BitSet'. Preserves order of 'null' and 'size' delete :: Enum a => a -> BitSet a -> BitSet a-delete x r@(BS a b c l h m u) +delete x r@(BS a b c l h m u _)      | m < 0, e < l = bs (a+1) (b+1) (c+1) e h (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+    | b == 0       = r+    | a == -1      = pseudoComplement (singleton x) 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@@ -182,7 +199,7 @@  -- | /O(1)/ Test for membership in a 'BitSet' member :: Enum a => a -> BitSet a -> Bool-member x (BS _ _ _ l h m _) +member x (BS _ _ _ l h m _ _)      | e < l     = m < 0      | e > h     = m > 0     | otherwise = testBit m (e - l)@@ -193,90 +210,100 @@ -- | /O(d)/ convert to an Integer representation. Discards negative elements toInteger :: BitSet a -> Integer toInteger x = mantissa x `shift` exponent x+{-# INLINE toInteger #-} --- | /O(d)/. May force 'size' to take /O(d)/ if ranges overlap, preserves order of 'null'-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')+-- | /O(d)/.+union :: Enum a => BitSet a -> BitSet a -> BitSet a +union x@(BS a b c l h m u f) 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       = entire u                                                          -- fast full union, recomplement obligation met by negative size     | a' == -1      = entire 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-    | m < 0         = recomplement (pseudoDiff (recomplement x) y u)                    -- union with complement, recomplement obligation met by 2s complement+    | m' < 0        = recomplement (diff (recomplement y) x u')                         -- union with complement, recomplement obligation met by 2s complement+    | m < 0         = recomplement (diff (recomplement x) y u)                          -- union with complement, recomplement obligation met by 2s complement     | 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)-        entire = BS (-1) (-1) (-1) 0 0 (-1)+        entire u'' = BS (-1) (-1) (-1) 0 0 (-1) u'' f --- | /O(1)/ check to see if we are represented as a complemented 'BitSet'. -isComplemented :: BitSet a -> Bool+-- | /O(1)/ Check to see if we are represented as a complemented 'BitSet'. +isComplemented :: Enum a => BitSet a -> Bool isComplemented = (<0) . mantissa +{-# INLINE isComplemented #-} --- | /O(d)/. May force 'size' and 'null' both to take /O(d)/.-intersection :: BitSet a -> BitSet a -> BitSet a -intersection x@(BS a b _ l h m u) y@(BS a' b' _ l' h' m' u')+-- | /O(d)/ +intersection :: Enum a => 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+    | m' < 0 = diff x (recomplement y) u'+    | m < 0 = diff 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') --- | Unsafe internal method for computing differences in a particular universe of discourse--- preconditions:---  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''+-- | Unsafe internal method for computing differences in a known universe of discourse.+--+-- Preconditions:+--+-- (1) @m >= 0@+-- 2   @m' >= 0@+-- 3   @a /= -1@+-- 4   @a' /= -1@+-- 5   @b /= 0@+-- 6   @b' /= 0@+-- 7   @u''@ is a previously obtained copy of @(fromEnum minBound, fromEnum maxBound)@+--+diff :: Enum a => BitSet a -> BitSet a -> (Int,Int) -> BitSet a +diff 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)+{-# INLINE diff #-} --- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'.+-- | /O(d)/ Remove all elements present in the second bitset from the first difference :: Enum a => BitSet a -> BitSet a -> BitSet a -difference x@(BS a b _ _ _ m u)  y@(BS a' b' _ _ _ m' _) +difference x@(BS a b _ _ _ m u _)  y@(BS a' b' _ _ _ m' _ _)     | a == -1       = pseudoComplement y u    | a' == -1      = empty    | b == 0        = empty    | b' == 0       = x-   | m < 0, m' < 0 = pseudoDiff (recomplement y) (recomplement x) u+   | m < 0, m' < 0 = diff (recomplement y) (recomplement x) u    | m < 0         = pseudoComplement (recomplement x `union` y) u    | m' < 0        = x `union` recomplement y -   | otherwise     = pseudoDiff x y u+   | otherwise     = diff x y u     --- | /O(d)/. Preserves order of 'null'. May force /O(d)/ 'size'.+-- | /O(d)/ Infix 'difference' (\\) :: Enum a => BitSet a -> BitSet a -> BitSet a  (\\) = difference+{-# INLINE (\\) #-}  instance Eq (BitSet a) where-    x@(BS _ _ _ l _ m u) == y@(BS _ _ _ l' _ m' _)-        | signum m == signum m' = shift m (l - l'') == shift m' (l - l'') -        | m' < 0 = y == x-        | otherwise = mask .&. shift m (l - ul) == shift m' (l - ul)+    x@(BS _ _ _ l _ m u _) == y@(BS _ _ _ l' _ m' _ _)+        | signum m == signum m' = shift m (l - l'') == shift m' (l' - l'') +        | m' < 0                = y == x+        | otherwise             = mask .&. shift m (l - ul) == shift m' (l - ul)         where              l'' = min l l'             mask = setBit 0 (uh - ul + 1) - 1             ul = fst u             uh = snd u --- 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)+        result = BS n n n l h m (l,h) toEnum         n = h - l + 1         l = fromEnum (minBound `asArgTypeOf` result)         h = fromEnum (maxBound `asArgTypeOf` result)@@ -315,13 +342,14 @@         -- then scan the powers for the highest set bit         scan :: Int -> Int -> Int         scan !l !h-            | l == h = l+            | l == h        = l             | bit (m+1) > n = scan l m-            | otherwise = scan (m+1) h-            where m = l + (h - l) `div` 2+            | otherwise     = scan (m+1) h+            where +                m = l + (h - l) `div` 2  -instance (Enum a, Show a) => Show (BitSet a) where-   showsPrec d x@(BS _ _ _ _ _ m u)+instance Show a => Show (BitSet a) where+   showsPrec d x@(BS _ _ _ _ _ m u _)         | m < 0     = showParen (d > 10) $ showString "pseudoComplement " . showsPrec 11 (recomplement x) . showString " " . showsPrec 11 u         | otherwise = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toList x) @@ -337,17 +365,25 @@  -- 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'))+    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+            result = BS a i (recount m) l h m undefined toEnum -- 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 Foldable BitSet where+    fold = fold . toList+    foldMap f = foldMap f . toList+    foldr f z = foldr f z . toList+    foldl f z = foldl f z . toList+    foldr1 f = foldr1 f . toList+    foldl1 f = foldl1 f . toList          instance Enum a => Monoid (BitSet a) where     mempty = empty@@ -362,6 +398,7 @@     one = full     times = intersection +instance (Bounded a, Enum a) => Ringoid (BitSet a) instance (Bounded a, Enum a) => LeftSemiNearRing (BitSet a) instance (Bounded a, Enum a) => RightSemiNearRing (BitSet a) instance (Bounded a, Enum a) => SemiRing (BitSet a)@@ -379,8 +416,8 @@ 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 (Bounded a, Enum a) => RAlgebra Natural (BitSet a)     -instance Enum a => Generator (BitSet a) where+instance Generator (BitSet a) where     type Elem (BitSet a) = a     mapReduce f = mapReduce f . toList
+ Data/Ring/Semi/Kleene.hs view
@@ -0,0 +1,10 @@+module Data.Ring.Semi.Kleene +    ( module Data.Ring.Semi+    , KleeneAlgebra+    , star+    ) where++import Data.Ring.Semi++class SemiRing r => KleeneAlgebra r where+    star :: r -> r
Data/Ring/Semi/Natural.hs view
@@ -96,6 +96,7 @@     one = 1     times = (*) +instance Ringoid Natural instance LeftSemiNearRing Natural instance RightSemiNearRing Natural instance SemiRing Natural
Data/Ring/Semi/Near.hs view
@@ -19,6 +19,7 @@  module Data.Ring.Semi.Near     ( module Data.Monoid.Multiplicative+    , Ringoid     , LeftSemiNearRing     , RightSemiNearRing     ) where@@ -45,50 +46,48 @@  import Text.Parsec.Prim --- | @a * (b + c) = (a * b) + (a * c)@-class (Multiplicative m, Monoid m) => LeftSemiNearRing m +-- | @0@ annihilates `times`+class (Multiplicative m, Monoid m) => Ringoid m+instance Ringoid m => Ringoid (Self m)+instance Ringoid m => Ringoid (FromString m)+instance Ringoid m => Ringoid (ReducedBy m s)+instance Ringoid m => Ringoid (Dual m)+instance (Measured v m, Monoid m) => Ringoid (FingerTree v m)+instance Monoid m => Ringoid [m]+instance Monoid m => Ringoid (Maybe m)+instance Monoid m => Ringoid (Seq m)+instance (Stream s m t, Monoid a) => Ringoid (ParsecT s u m a)+instance (MonadPlus m, Monoid n) => Ringoid (SState.StateT s m n)+instance (MonadPlus m, Monoid n) => Ringoid (LState.StateT s m n)+instance (MonadPlus m, Monoid n) => Ringoid (ReaderT e m n)+instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (SRWS.RWST r w s m n)+instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (LRWS.RWST r w s m n)+instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (SWriter.WriterT w m n)+instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (LWriter.WriterT w m n) --- 'Monoid' transformers+-- | @a * (b + c) = (a * b) + (a * c)@+class Ringoid m => LeftSemiNearRing m  instance LeftSemiNearRing m => LeftSemiNearRing (Self m) instance LeftSemiNearRing m => LeftSemiNearRing (FromString m) instance LeftSemiNearRing m => LeftSemiNearRing (ReducedBy m s) instance RightSemiNearRing m => LeftSemiNearRing (Dual m)  -- | @(a + b) * c = (a * c) + (b * c)@-class (Multiplicative m, Monoid m) => RightSemiNearRing m ---- 'Monoid' transformers+class Ringoid m => RightSemiNearRing m  instance RightSemiNearRing m => RightSemiNearRing (Self m) instance RightSemiNearRing m => RightSemiNearRing (FromString m) instance RightSemiNearRing m => RightSemiNearRing (ReducedBy m s) instance LeftSemiNearRing m => RightSemiNearRing (Dual m)---- non-'Monad' instances instance (Measured v m, Monoid m) => RightSemiNearRing (FingerTree v m)---- 'Monad' instances--- Every 'MonadPlus' over a 'Monoid' with an appropriate 'Multiplicative' instance--- for 'liftM2 mappend' is a 'RightSemiNearRing' by 'MonadPlus' left-distributivity- instance Monoid m => RightSemiNearRing [m]- instance Monoid m => RightSemiNearRing (Maybe m)- instance Monoid m => RightSemiNearRing (Seq m)- instance (Stream s m t, Monoid a) => RightSemiNearRing (ParsecT s u m a)- instance (MonadPlus m, Monoid n) => RightSemiNearRing (SState.StateT s m n)- instance (MonadPlus m, Monoid n) => RightSemiNearRing (LState.StateT s m n)- instance (MonadPlus m, Monoid n) => RightSemiNearRing (ReaderT e m n)- instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (SRWS.RWST r w s m n)- instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (LRWS.RWST r w s m n)- instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (SWriter.WriterT w m n)- instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (LWriter.WriterT w m n)
Data/Ring/Semi/Ord.hs view
@@ -35,6 +35,7 @@     times = min     one = maxBound     +instance (Bounded a, Ord a) => Ringoid (Order a) instance (Bounded a, Ord a) => RightSemiNearRing (Order a) instance (Bounded a, Ord a) => LeftSemiNearRing (Order a) instance (Bounded a, Ord a) => SemiRing (Order a)@@ -98,6 +99,7 @@     times = min     one = maxBound +instance Ord a => Ringoid (Priority a) instance Ord a => LeftSemiNearRing (Priority a) instance Ord a => RightSemiNearRing (Priority a) instance Ord a => SemiRing (Priority a)
Data/Ring/Semi/Tropical.hs view
@@ -68,6 +68,7 @@     Tropical (Just a) `times` Tropical (Just b) = point (a + b)     _  `times` Tropical Nothing      = infinity +instance (Ord a, Num a) => Ringoid (Tropical a) instance (Ord a, Num a) => LeftSemiNearRing (Tropical a) instance (Ord a, Num a) => RightSemiNearRing (Tropical a) instance (Ord a, Num a) => SemiRing (Tropical a)
+ Data/Set/Unboxed.hs view
@@ -0,0 +1,1258 @@+{-# LANGUAGE TypeFamilies, CPP, ViewPatterns #-}++{------------------------------------------------------------------------------+-- |+-- Module      :  Data.Set.Unboxed+-- Copyright   :  (c) Edward Kmett 2009+--                (c) Daan Leijen 2002+-- License     :  BSD-style+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (type families, view patterns)+--+-- An efficient implementation of sets.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- >  import Data.Set.Unboxed (USet)+-- >  import qualified Data.Set.Unboxed as USet+--+-- The implementation of 'USet' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--  Journal of Functional Programming 3(4):553-562, October 1993,+--  <http://www.swiss.ai.mit.edu/~adams/BB/>.+--+--    * J. Nievergelt and E.M. Reingold,+--  \"/Binary search trees of bounded balance/\",+--  SIAM journal of computing 2(1), March 1973.+--+-- Note that the implementation is /left-biased/ -- the elements of a+-- first argument are always preferred to the second, for example in+-- 'union' or 'insert'.  Of course, left-biasing can only be observed+-- when equality is an equivalence relation instead of structural+-- equality.+--+-- Modified from "Data.Set" to use type families for automatic boxing.+-----------------------------------------------------------------------------+-}++module Data.Set.Unboxed ( +            -- * Set type+              USet          -- instance Eq,Ord,Show,Read,Data,Typeable+            , US++            -- * Operators+            , (\\)++            -- * Query+            , null+            , size+            , member+            , notMember+            , isSubsetOf+            , isProperSubsetOf+            +            -- * Construction+            , empty+            , singleton+            , insert+            , delete+            +            -- * Combine+            , union, unions+            , difference+            , intersection+            +            -- * Filter+            , filter+            , partition+            , split+            , splitMember++            -- * Map+            , map+            , mapMonotonic++            -- * Fold+            , fold++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , fromList+            +            -- ** Ordered list+            , toAscList+            , fromAscList+            , fromDistinctAscList+                        +            -- * Debugging+            , showTree+            , showTreeWith+            , valid+            ) where++import Prelude hiding (filter,foldr,null,map)+import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Data.Generator.Combinators (Generator,Elem,foldMap, mapReduce)+#ifndef __GLASGOW_HASKELL__+import Data.Typeable (Typeable, typeOf, typeOfDefault)+#endif+import Data.Typeable (Typeable1(..), TyCon, mkTyCon, mkTyConApp)+import Data.Word+import Data.Int++{-+-- just for testing+import Test.QuickCheck +import Data.List (nub,sort)+import qualified Data.List as List+-}++#if __GLASGOW_HASKELL__+import Text.Read+import Data.Data (Data(..), mkNorepType, gcast1)+#endif++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | /O(n+m)/. See 'difference'.+(\\) :: (US a, Ord a) => USet a -> USet a -> USet a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Sets are size balanced trees+--------------------------------------------------------------------}+type Size     = Int++-- | A set of values @a@.+data Set a    = Tip +              | Bin {-# UNPACK #-} !Size a !(USet a) !(USet a) ++-- smart unboxed types+class US a where+    data USet a+    view :: USet a -> Set a+    {-# INLINE view #-}+    tip :: USet a+    {-# INLINE tip #-}+    bin :: Size -> a -> USet a -> USet a -> USet a+    {-# INLINE bin #-}+++instance (US a, Ord a) => Monoid (USet a) where+    mempty  = empty+    mappend = union+    mconcat = unions++{-+instance US a => Generator (USet a) where+    type Elem (USet a) = a+    mapReduce _ (view -> Tip) = mempty+    mapReduce f (view -> Bin _s k l r) = mapReduce f l `mappend` f k `mappend` mapReduce f r+-}++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance  +--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We omit reflection services for the sake of data abstraction.++{-+instance (US a, Data a, Ord a) => Data (USet a) where+  gfoldl f z set = z fromList `f` (toList set)+  toConstr _     = error "toConstr"+  gunfold _ _    = error "gunfold"+  dataTypeOf _   = mkNorepType "Data.Set.Set"+  dataCast1 f    = gcast1 f+-}++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | /O(1)/. Is this the empty set?+null :: US a => USet a -> Bool+null (view -> Tip) = True+null (view -> Bin {}) = False++-- | /O(1)/. The number of elements in the set.+size :: US a => USet a -> Int+size (view -> Tip) = 0+size (view -> Bin sz _ _ _) = sz++-- | /O(log n)/. Is the element in the set?+member :: (US a, Ord a) => a -> USet a -> Bool+member x (view -> Tip) = False+member x (view -> Bin _ y l r) = +    case compare x y of+        LT -> member x l+        GT -> member x r+        EQ -> True       ++-- | /O(log n)/. Is the element not in the set?+notMember :: (US a, Ord a) => a -> USet a -> Bool+notMember x t = not $ member x t++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: US a => USet a+empty = tip++-- | /O(1)/. Create a singleton set.+singleton :: US a => a -> USet a+singleton x = bin 1 x tip tip++{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | /O(log n)/. Insert an element in a set.+-- If the set already contains an element equal to the given value,+-- it is replaced with the new value.+insert :: (US a, Ord a) => a -> USet a -> USet a+insert x (view -> Tip)          = singleton x+insert x (view -> Bin sz y l r) = case compare x y of+   LT -> balance y (insert x l) r+   GT -> balance y l (insert x r)+   EQ -> bin sz x l r++-- | /O(log n)/. Delete an element from a set.+delete :: (US a, Ord a) => a -> USet a -> USet a+delete x (view -> Tip)         = tip+delete x (view -> Bin _ y l r) = case compare x y of+    LT -> balance y (delete x l) r+    GT -> balance y l (delete x r)+    EQ -> glue l r++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: (US a, Ord a) => USet a -> USet a -> Bool+isProperSubsetOf s1 s2+    = (size s1 < size s2) && (isSubsetOf s1 s2)++-- | /O(n+m)/. Is this a subset?+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.+isSubsetOf :: (US a, Ord a) => USet a -> USet a -> Bool+isSubsetOf t1 t2 = (size t1 <= size t2) && (isSubsetOfX t1 t2)++isSubsetOfX :: (US a, Ord a) => USet a -> USet a -> Bool+isSubsetOfX (view -> Tip) _         = True+isSubsetOfX _ (view -> Tip)         = False+isSubsetOfX (view -> Bin _ x l r) t = found && isSubsetOfX l lt && isSubsetOfX r gt+  where+    (lt,found,gt) = splitMember x t+++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}+-- | /O(log n)/. The minimal element of a set.+findMin :: US a => USet a -> a+findMin (view -> Bin _ x (view -> Tip) _) = x+findMin (view -> Bin _ _ l _)   = findMin l+findMin (view -> Tip)           = error "Set.findMin: empty set has no minimal element"++-- | /O(log n)/. The maximal element of a set.+findMax :: US a => USet a -> a+findMax (view -> Bin _ x _ (view -> Tip))  = x+findMax (view -> Bin _ _ _ r)    = findMax r+findMax (view -> Tip)            = error "Set.findMax: empty set has no maximal element"++-- | /O(log n)/. Delete the minimal element.+deleteMin :: US a => USet a -> USet a+deleteMin (view -> Bin _ _ (view -> Tip) r) = r+deleteMin (view -> Bin _ x l r)   = balance x (deleteMin l) r+deleteMin (view -> Tip)           = tip++-- | /O(log n)/. Delete the maximal element.+deleteMax :: US a => USet a -> USet a+deleteMax (view -> Bin _ _ l (view -> Tip)) = l+deleteMax (view -> Bin _ x l r)   = balance x l (deleteMax r)+deleteMax (view -> Tip)           = tip++{--------------------------------------------------------------------+  Union. +--------------------------------------------------------------------}+-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).+unions :: (US a, Ord a) => [USet a] -> USet a+unions ts+  = foldlStrict union empty ts+++-- | /O(n+m)/. The union of two sets, preferring the first set when+-- equal elements are encountered.+-- The implementation uses the efficient /hedge-union/ algorithm.+-- Hedge-union is more efficient on (bigset `union` smallset).+union :: (US a, Ord a) => USet a -> USet a -> USet a+union (view -> Tip) t2  = t2+union t1 (view -> Tip)  = t1+union t1 t2 = hedgeUnion (const LT) (const GT) t1 t2++hedgeUnion :: (US a, Ord a) => (a -> Ordering) -> (a -> Ordering) -> USet a -> USet a -> USet a+hedgeUnion _     _     t1 (view -> Tip)                    = t1+hedgeUnion cmplo cmphi (view -> Tip) (view -> Bin _ x l r) = join x (filterGt cmplo l) (filterLt cmphi r)+hedgeUnion cmplo cmphi (view -> Bin _ x l r) t2            = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))+  where+    cmpx = compare x++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference of two sets. +-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.+difference :: (US a, Ord a) => USet a -> USet a -> USet a+difference (view -> Tip) _   = tip+difference t1 (view -> Tip)  = t1+difference t1 t2   = hedgeDiff (const LT) (const GT) t1 t2++hedgeDiff :: (US a, Ord a) => (a -> Ordering) -> (a -> Ordering) -> USet a -> USet a -> USet a+hedgeDiff _ _ (view -> Tip) _ = tip+hedgeDiff cmplo cmphi (view -> Bin _ x l r) (view -> Tip) = join x (filterGt cmplo l) (filterLt cmphi r)+hedgeDiff cmplo cmphi t (view -> Bin _ x l r) = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)+  where+    cmpx = compare x++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The intersection of two sets.+-- Elements of the result come from the first set, so for example+--+-- > import qualified Data.Set as S+-- > data AB = A | B deriving Show+-- > instance Ord AB where compare _ _ = EQ+-- > instance Eq AB where _ == _ = True+-- > main = print (S.singleton A `S.intersection` S.singleton B,+-- >               S.singleton B `S.intersection` S.singleton A)+--+-- prints @(fromList [A],fromList [B])@.+intersection :: (US a, Ord a) => USet a -> USet a -> USet a+intersection (view -> Tip) _ = tip+intersection _ (view -> Tip) = tip+intersection t1@(view -> Bin s1 x1 l1 r1) t2@(view -> Bin s2 x2 l2 r2) =+   if s1 >= s2 then+      let (lt,found,gt) = splitLookup x2 t1+          tl            = intersection lt l2+          tr            = intersection gt r2+      in case found of+      Just x -> join x tl tr+      Nothing -> merge tl tr+   else let (lt,found,gt) = splitMember x1 t2+            tl            = intersection l1 lt+            tr            = intersection r1 gt+        in if found then join x1 tl tr+           else merge tl tr++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: (US a, Ord a) => (a -> Bool) -> USet a -> USet a+filter _ (view -> Tip) = tip+filter p (view -> Bin _ x l r)+  | p x       = join x (filter p l) (filter p r)+  | otherwise = merge (filter p l) (filter p r)++-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+-- See also 'split'.+partition :: (US a, Ord a) => (a -> Bool) -> USet a -> (USet a,USet a)+partition _ (view -> Tip) = (tip,tip)+partition p (view -> Bin _ x l r)+  | p x       = (join x l1 r1,merge l2 r2)+  | otherwise = (merge l1 r1,join x l2 r2)+  where+    (l1,l2) = partition p l+    (r1,r2) = partition p r++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | /O(n*log n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+-- +-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (US a, US b, Ord a, Ord b) => (a->b) -> USet a -> USet b+map f = fromList . List.map f . toList++-- | /O(n)/. The +--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is monotonic.+-- /The precondition is not checked./+-- Semi-formally, we have:+-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s++mapMonotonic :: (US a, US b) => (a->b) -> USet a -> USet b+mapMonotonic _ (view -> Tip) = tip+mapMonotonic f (view -> Bin sz x l r) = bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over the elements of a set in an unspecified order.+fold :: US a => (a -> b -> b) -> b -> USet a -> b+fold f z s = foldr f z s++-- | /O(n)/. Post-order fold.+foldr :: US a => (a -> b -> b) -> b -> USet a -> b+foldr _ z (view -> Tip)         = z+foldr f z (view -> Bin _ x l r) = foldr f (f x (foldr f z r)) l++{--------------------------------------------------------------------+  List variations +--------------------------------------------------------------------}+-- | /O(n)/. The elements of a set.+elems :: US a => USet a -> [a]+elems = toList++{--------------------------------------------------------------------+  Lists +--------------------------------------------------------------------}+-- | /O(n)/. Convert the set to a list of elements.+toList :: US a => USet a -> [a]+toList = toAscList++-- | /O(n)/. Convert the set to an ascending list of elements.+toAscList :: US a => USet a -> [a]+toAscList = foldr (:) []+++-- | /O(n*log n)/. Create a set from a list of elements.+fromList :: (US a, Ord a) => [a] -> USet a +fromList = foldlStrict ins empty+  where+    ins t x = insert x t++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.+  +  Note that if [xs] is ascending that: +    fromAscList xs == fromList xs+--------------------------------------------------------------------}+-- | /O(n)/. Build a set from an ascending list in linear time.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: (US a, Eq a) => [a] -> USet a +fromAscList xs+  = fromDistinctAscList (combineEq xs)+  where+  -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]+  combineEq xs'+    = case xs' of+        []     -> []+        [x]    -> [x]+        (x:xx) -> combineEq' x xx++  combineEq' z [] = [z]+  combineEq' z (x:xs')+    | z==x      =   combineEq' z xs'+    | otherwise = z:combineEq' x xs'+++-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.+-- /The precondition (input list is strictly ascending) is not checked./+fromDistinctAscList :: US a => [a] -> USet a +fromDistinctAscList xs+  = build const (length xs) xs+  where+    -- 1) use continutations so that we use heap space instead of stack space.+    -- 2) special case for n==5 to build bushier trees. +    build c 0 xs'  = c tip xs'+    build c 5 xs'  = case xs' of+                       (x1:x2:x3:x4:x5:xx) +                            -> c (bin_ x4 (bin_ x2 (singleton x1) (singleton x3)) (singleton x5)) xx+                       _ -> error "fromDistinctAscList build 5"+    build c n xs'  = seq nr $ build (buildR nr c) nl xs'+                   where+                     nl = n `div` 2+                     nr = n - nl - 1++    buildR n c l (x:ys) = build (buildB l x c) n ys+    buildR _ _ _ []     = error "fromDistinctAscList buildR []"+    buildB l x c r zs   = c (bin_ x l r) zs++{--------------------------------------------------------------------+  Eq converts the set to a list. In a lazy setting, this +  actually seems one of the faster methods to compare two trees +  and it is certainly the simplest :-)+--------------------------------------------------------------------}+instance (US a, Eq a) => Eq (USet a) where+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)++{--------------------------------------------------------------------+  Ord +--------------------------------------------------------------------}++instance (US a, Ord a) => Ord (USet a) where+    compare s1 s2 = compare (toAscList s1) (toAscList s2) ++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance (US a, Show a) => Show (USet a) where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++{-+XXX unused code++showSet :: (Show a) => [a] -> ShowS+showSet []     +  = showString "{}" +showSet (x:xs) +  = showChar '{' . shows x . showTail xs+  where+    showTail []       = showChar '}'+    showTail (x':xs') = showChar ',' . shows x' . showTail xs'+-}++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (US a, Read a, Ord a) => Read (USet a) where+#ifdef __GLASGOW_HASKELL__+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  Typeable/Data+--------------------------------------------------------------------}++-- #include "Typeable.h"+-- INSTANCE_TYPEABLE1(Set,setTc,"Set")++{--------------------------------------------------------------------+  Utility functions that return sub-ranges of the original+  tree. Some functions take a comparison function as argument to+  allow comparisons against infinite values. A function [cmplo x]+  should be read as [compare lo x].++  [trim cmplo cmphi t]  A tree that is either empty or where [cmplo x == LT]+                        and [cmphi x == GT] for the value [x] of the root.+  [filterGt cmp t]      A tree where for all values [k]. [cmp k == LT]+  [filterLt cmp t]      A tree where for all values [k]. [cmp k == GT]++  [split k t]           Returns two trees [l] and [r] where all values+                        in [l] are <[k] and all keys in [r] are >[k].+  [splitMember k t]     Just like [split] but also returns whether [k]+                        was found in the tree.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  [trim lo hi t] trims away all subtrees that surely contain no+  values between the range [lo] to [hi]. The returned tree is either+  empty or the key of the root is between @lo@ and @hi@.+--------------------------------------------------------------------}+trim :: US a => (a -> Ordering) -> (a -> Ordering) -> USet a -> USet a+trim _     _     (view -> Tip) = tip+trim cmplo cmphi t@(view -> Bin _ x l r)+  = case cmplo x of+      LT -> case cmphi x of+              GT -> t+              _  -> trim cmplo cmphi l+      _  -> trim cmplo cmphi r++{--------------------------------------------------------------------+  [filterGt x t] filter all values >[x] from tree [t]+  [filterLt x t] filter all values <[x] from tree [t]+--------------------------------------------------------------------}+filterGt :: US a => (a -> Ordering) -> USet a -> USet a+filterGt _ (view -> Tip) = tip+filterGt cmp (view -> Bin _ x l r)+  = case cmp x of+      LT -> join x (filterGt cmp l) r+      GT -> filterGt cmp r+      EQ -> r+      +filterLt :: US a => (a -> Ordering) -> USet a -> USet a+filterLt _ (view -> Tip) = tip+filterLt cmp (view -> Bin _ x l r)+  = case cmp x of+      LT -> filterLt cmp l+      GT -> join x l (filterLt cmp r)+      EQ -> l+++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+split :: (US a, Ord a) => a -> USet a -> (USet a,USet a)+split _ (view -> Tip) = (tip,tip)+split x (view -> Bin _ y l r)+  = case compare x y of+      LT -> let (lt,gt) = split x l in (lt,join y gt r)+      GT -> let (lt,gt) = split x r in (join y l lt,gt)+      EQ -> (l,r)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: (US a, Ord a) => a -> USet a -> (USet a,Bool,USet a)+splitMember x t = let (l,m,r) = splitLookup x t in+     (l,maybe False (const True) m,r)++-- | /O(log n)/. Performs a 'split' but also returns the pivot+-- element that was found in the original set.+splitLookup :: (US a, Ord a) => a -> USet a -> (USet a,Maybe a,USet a)+splitLookup _ (view -> Tip) = (tip,Nothing,tip)+splitLookup x (view -> Bin _ y l r)+   = case compare x y of+       LT -> let (lt,found,gt) = splitLookup x l in (lt,found,join y gt r)+       GT -> let (lt,found,gt) = splitLookup x r in (join y l lt,found,gt)+       EQ -> (l,Just y,r)++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [x] and all values+  in [r] > [x], and that [l] and [r] are valid trees.+  +  In order of sophistication:+    [Bin sz x l r]    The type constructor.+    [bin_ x l r]      Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance x l r]   Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [join x l r]      Restores balance and size. ++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [merge l r]       Merges two trees and restores balance.++  Note: in contrast to Adam's paper, we use (<=) comparisons instead+  of (<) comparisons in [join], [merge] and [balance]. +  Quickcheck (on [difference]) showed that this was necessary in order +  to maintain the invariants. It is quite unsatisfactory that I haven't +  been able to find out why this is actually the case! Fortunately, it +  doesn't hurt to be a bit more conservative.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Join +--------------------------------------------------------------------}+join :: US a => a -> USet a -> USet a -> USet a+join x (view -> Tip) r  = insertMin x r+join x l (view -> Tip)  = insertMax x l+join x l@(view -> Bin sizeL y ly ry) r@(view -> Bin sizeR z lz rz)+  | delta*sizeL <= sizeR  = balance z (join x l lz) rz+  | delta*sizeR <= sizeL  = balance y ly (join x ry r)+  | otherwise             = bin_ x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: US a => a -> USet a -> USet a +insertMax x t+  = case view t of+      Tip -> singleton x+      Bin _ y l r+          -> balance y l (insertMax x r)+             +insertMin x t+  = case view t of+      Tip -> singleton x+      Bin _ y l r+          -> balance y (insertMin x l) r+             +{--------------------------------------------------------------------+  [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: US a => USet a -> USet a -> USet a+merge (view -> Tip) r   = r+merge l (view -> Tip)   = l+merge l@(view -> Bin sizeL x lx rx) r@(view -> Bin sizeR y ly ry)+  | delta*sizeL <= sizeR = balance y (merge l ly) ry+  | delta*sizeR <= sizeL = balance x lx (merge rx r)+  | otherwise            = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: US a => USet a -> USet a -> USet a+glue (view -> Tip) r = r+glue l (view -> Tip) = l+glue l r   +  | size l > size r = let (m,l') = deleteFindMax l in balance m l' r+  | otherwise       = let (m,r') = deleteFindMin r in balance m l r'+++-- | /O(log n)/. Delete and find the minimal element.+-- +-- > deleteFindMin set = (findMin set, deleteMin set)++deleteFindMin :: US a => USet a -> (a,USet a)+deleteFindMin t +  = case view t of+      Bin _ x (view -> Tip) r -> (x,r)+      Bin _ x l r   -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)+      Tip           -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", tip)++-- | /O(log n)/. Delete and find the maximal element.+-- +-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: US a => USet a -> (a,USet a)+deleteFindMax t+  = case view t of+      Bin _ x l (view -> Tip) -> (x,l)+      Bin _ x l r   -> let (xm,r') = deleteFindMax r in (xm,balance x l r')+      Tip           -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", tip)++-- | /O(log n)/. Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: US a => USet a -> Maybe (a, USet a)+minView (view -> Tip) = Nothing+minView x = Just (deleteFindMin x)++-- | /O(log n)/. Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: US a => USet a -> Maybe (a, USet a)+maxView (view -> Tip) = Nothing+maxView x = Just (deleteFindMax x)++{--------------------------------------------------------------------+  [balance x l r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper,+          or equivalently, [1/delta] corresponds with the $\alpha$+          in Nievergelt's paper. Adams shows that [delta] should+          be larger than 3.745 in order to garantee that the+          rotations can always restore balance.         ++  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is correspondes with the inverse+          of $\alpha$ in Adam's article.++  Note that:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.+  +  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  - Balancing is automatic for random data and a balancing+    scheme is only necessary to avoid pathological worst cases.+    Almost any choice will do in practice+    +  - Allthough it seems that a rather large [delta] may perform better +    than smaller one, measurements have shown that the smallest [delta]+    of 4 is actually the fastest on a wide range of operations. It+    especially improves performance on worst-case scenarios like+    a sequence of ordered insertions.++  Note: in contrast to Adams' paper, we use a ratio of (at least) 2+  to decide whether a single or double rotation is needed. Allthough+  he actually proves that this ratio is needed to maintain the+  invariants, his implementation uses a (invalid) ratio of 1. +  He is aware of the problem though since he has put a comment in his +  original source code that he doesn't care about generating a +  slightly inbalanced tree since it doesn't seem to matter in practice. +  However (since we use quickcheck :-) we will stick to strictly balanced +  trees.+--------------------------------------------------------------------}+delta,ratio :: Int+delta = 4+ratio = 2++balance :: US a => a -> USet a -> USet a -> USet a+balance x l r+  | sizeL + sizeR <= 1    = bin sizeX x l r+  | sizeR >= delta*sizeL  = rotateL x l r+  | sizeL >= delta*sizeR  = rotateR x l r+  | otherwise             = bin sizeX x l r+  where+    sizeL = size l+    sizeR = size r+    sizeX = sizeL + sizeR + 1++-- rotate+rotateL :: US a => a -> USet a -> USet a -> USet a+rotateL x l r@(view -> Bin _ _ ly ry)+  | size ly < ratio*size ry = singleL x l r+  | otherwise               = doubleL x l r+rotateL _ _ (view -> Tip) = error "rotateL Tip"++rotateR :: US a => a -> USet a -> USet a -> USet a+rotateR x l@(view -> Bin _ _ ly ry) r+  | size ry < ratio*size ly = singleR x l r+  | otherwise               = doubleR x l r+rotateR _ (view -> Tip) _ = error "rotateL Tip"++-- basic rotations+singleL, singleR :: US a => a -> USet a -> USet a -> USet a+singleL x1 t1 (view -> Bin _ x2 t2 t3)  = bin_ x2 (bin_ x1 t1 t2) t3+singleL _  _  (view -> Tip)             = error "singleL"+singleR x1 (view -> Bin _ x2 t1 t2) t3  = bin_ x2 t1 (bin_ x1 t2 t3)+singleR _ (view -> Tip)             _   = error "singleR"++doubleL, doubleR :: US a => a -> USet a -> USet a -> USet a+doubleL x1 t1 (view -> Bin _ x2 (view -> Bin _ x3 t2 t3) t4) = bin_ x3 (bin_ x1 t1 t2) (bin_ x2 t3 t4)+doubleL _ _ _ = error "doubleL"+doubleR x1 (view -> Bin _ x2 t1 (view -> Bin _ x3 t2 t3)) t4 = bin_ x3 (bin_ x2 t1 t2) (bin_ x1 t3 t4)+doubleR _ _ _ = error "doubleR"+++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin_ :: US a => a -> USet a -> USet a -> USet a+bin_ x l r+  = bin (size l + size r + 1) x l r+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f z xs+  = case xs of+      []     -> z+      (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: (US a, Show a) => USet a -> String+showTree s+  = showTreeWith True False s+++{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+ the tree that implements the set. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]+> 4+> +--2+> |  +--1+> |  +--3+> +--5+> +> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]+> 4+> |+> +--2+> |  |+> |  +--1+> |  |+> |  +--3+> |+> +--5+> +> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]+> +--5+> |+> 4+> |+> |  +--3+> |  |+> +--2+>    |+>    +--1++-}+showTreeWith :: (US a, Show a) => Bool -> Bool -> USet a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: (US a, Show a) => Bool -> [String] -> [String] -> USet a -> ShowS+showsTree wide lbars rbars t+  = case view t of+      Tip -> showsBars lbars . showString "|\n"+      Bin _ x (view -> Tip) (view -> Tip)+          -> showsBars lbars . shows x . showString "\n" +      Bin _ x l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . shows x . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (US a, Show a) => Bool -> [String] -> USet a -> ShowS+showsTreeHang wide bars t+  = case view t of+      Tip -> showsBars bars . showString "|\n" +      Bin _ x (view -> Tip) (view -> Tip) +          -> showsBars bars . shows x . showString "\n" +      Bin _ x l r+          -> showsBars bars . shows x . showString "\n" . +             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars +  | wide      = showString (concat (reverse bars)) . showString "|\n" +  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _  -> showString (concat (reverse (tail bars))) . showString node++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | /O(n)/. Test if the internal set structure is valid.+valid :: (US a, Ord a) => USet a -> Bool+valid t+  = balanced t && ordered t && validsize t++ordered :: (US a, Ord a) => USet a -> Bool+ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t'+      = case view t' of+          Tip         -> True+          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r++balanced :: US a => USet a -> Bool+balanced t+  = case view t of+      Tip         -> True+      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                     balanced l && balanced r++validsize :: US a => USet a -> Bool+validsize t+  = (realsize t == Just (size t))+  where+    realsize t'+      = case view t' of+          Tip          -> Just 0+          Bin sz _ l r -> case (realsize l,realsize r) of+                            (Just n,Just m)  | n+m+1 == sz  -> Just sz+                            _                -> Nothing++{-+{--------------------------------------------------------------------+  Testing+--------------------------------------------------------------------}+testTree :: [Int] -> USet Int+testTree xs   = fromList xs+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+  QuickCheck+--------------------------------------------------------------------}++{-+qcheck prop+  = check config prop+  where+    config = Config+      { configMaxTest = 500+      , configMaxFail = 5000+      , configSize    = \n -> (div n 2 + 3)+      , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+      }+-}+++{--------------------------------------------------------------------+  Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance (US a, Enum a) => Arbitrary (USet a) where+  arbitrary = sized (arbtree 0 maxkey)+            where maxkey  = 10000++arbtree :: (US a, Enum a) => Int -> Int -> Int -> Gen (USet a)+arbtree lo hi n+  | n <= 0        = return tip+  | lo >= hi      = return tip+  | otherwise     = do{ i  <- choose (lo,hi)+                      ; m  <- choose (1,30)+                      ; let (ml,mr)  | m==(1::Int)= (1,2)+                                     | m==2       = (2,1)+                                     | m==3       = (1,1)+                                     | otherwise  = (2,2)+                      ; l  <- arbtree lo (i-1) (n `div` ml)+                      ; r  <- arbtree (i+1) hi (n `div` mr)+                      ; return (bin_ (toEnum i) l r)+                      }  +++{--------------------------------------------------------------------+  Valid tree's+--------------------------------------------------------------------}+forValid :: (US a, Enum a,Show a,Testable b) => (USet a -> b) -> Property+forValid f+  = forAll arbitrary $ \t -> +--    classify (balanced t) "balanced" $+    classify (size t == 0) "empty" $+    classify (size t > 0  && size t <= 10) "small" $+    classify (size t > 10 && size t <= 64) "medium" $+    classify (size t > 64) "large" $+    balanced t ==> f t++forValidIntTree :: Testable a => (USet Int -> a) -> Property+forValidIntTree f+  = forValid f++forValidUnitTree :: Testable a => (USet Int -> a) -> Property+forValidUnitTree f+  = forValid f+++prop_Valid +  = forValidUnitTree $ \t -> valid t++{--------------------------------------------------------------------+  Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Int -> Bool+prop_Single x+  = (insert x empty == singleton x)++prop_InsertValid :: Int -> Property+prop_InsertValid k+  = forValidUnitTree $ \t -> valid (insert k t)++prop_InsertDelete :: Int -> USet Int -> Property+prop_InsertDelete k t+  = not (member k t) ==> delete k (insert k t) == t++prop_DeleteValid :: Int -> Property+prop_DeleteValid k+  = forValidUnitTree $ \t -> +    valid (delete k (insert k t))++{--------------------------------------------------------------------+  Balance+--------------------------------------------------------------------}+prop_Join :: Int -> Property +prop_Join x+  = forValidUnitTree $ \t ->+    let (l,r) = split x t+    in valid (join x l r)++prop_Merge :: Int -> Property +prop_Merge x+  = forValidUnitTree $ \t ->+    let (l,r) = split x t+    in valid (merge l r)+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+prop_UnionValid :: Property+prop_UnionValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (union t1 t2)++prop_UnionInsert :: Int -> USet Int -> Bool+prop_UnionInsert x t+  = union t (singleton x) == insert x t++prop_UnionAssoc :: USet Int -> USet Int -> USet Int -> Bool+prop_UnionAssoc t1 t2 t3+  = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: USet Int -> USet Int -> Bool+prop_UnionComm t1 t2+  = (union t1 t2 == union t2 t1)+++prop_DiffValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (difference t1 t2)++prop_Diff :: [Int] -> [Int] -> Bool+prop_Diff xs ys+  =  toAscList (difference (fromList xs) (fromList ys))+    == List.sort ((List.\\) (nub xs)  (nub ys))++prop_IntValid+  = forValidUnitTree $ \t1 ->+    forValidUnitTree $ \t2 ->+    valid (intersection t1 t2)++prop_Int :: [Int] -> [Int] -> Bool+prop_Int xs ys+  =  toAscList (intersection (fromList xs) (fromList ys))+    == List.sort (nub ((List.intersect) (xs)  (ys)))++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+prop_Ordered+  = forAll (choose (5,100)) $ \n ->+    let xs = [0..n::Int]+    in fromAscList xs == fromList xs++prop_List :: [Int] -> Bool+prop_List xs+  = (sort (nub xs) == toList (fromList xs))+-}+++newtype Boxed a = Boxed a+instance US (Boxed a) where+    data USet (Boxed a) = BoxedTip | BoxedBin {-# UNPACK #-} !Size (Boxed a) !(USet (Boxed a)) !(USet (Boxed a))+    view BoxedTip = Tip+    view (BoxedBin s i l r) = Bin s i l r+    tip = BoxedTip+    bin = BoxedBin++instance US Char where+    data USet Char = CharTip | CharBin {-# UNPACK #-} !Size {-# UNPACK #-} !Char !(USet Char) !(USet Char)+    view CharTip = Tip+    view (CharBin s i l r) = Bin s i l r+    tip = CharTip+    bin = CharBin+instance US Int where+    data USet Int = IntTip | IntBin {-# UNPACK #-} !Size {-# UNPACK #-} !Int !(USet Int) !(USet Int)+    view IntTip = Tip+    view (IntBin s i l r) = Bin s i l r+    tip = IntTip+    bin = IntBin++instance US Integer where+    data USet Integer = IntegerTip | IntegerBin {-# UNPACK #-} !Size {-# UNPACK #-} !Integer !(USet Integer) !(USet Integer)+    view IntegerTip = Tip+    view (IntegerBin s i l r) = Bin s i l r+    tip = IntegerTip+    bin = IntegerBin++instance US Int8 where+    data USet Int8 = Int8Tip | Int8Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Int8 !(USet Int8) !(USet Int8)+    view Int8Tip = Tip+    view (Int8Bin s i l r) = Bin s i l r+    tip = Int8Tip+    bin = Int8Bin++instance US Int16 where+    data USet Int16 = Int16Tip | Int16Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Int16 !(USet Int16) !(USet Int16)+    view Int16Tip = Tip+    view (Int16Bin s i l r) = Bin s i l r+    tip = Int16Tip+    bin = Int16Bin++instance US Int32 where+    data USet Int32 = Int32Tip | Int32Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Int32 !(USet Int32) !(USet Int32)+    view Int32Tip = Tip+    view (Int32Bin s i l r) = Bin s i l r+    tip = Int32Tip+    bin = Int32Bin++instance US Int64 where+    data USet Int64 = Int64Tip | Int64Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Int64 !(USet Int64) !(USet Int64)+    view Int64Tip = Tip+    view (Int64Bin s i l r) = Bin s i l r+    tip = Int64Tip+    bin = Int64Bin++instance US Word8 where+    data USet Word8 = Word8Tip | Word8Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Word8 !(USet Word8) !(USet Word8)+    view Word8Tip = Tip+    view (Word8Bin s i l r) = Bin s i l r+    tip = Word8Tip+    bin = Word8Bin++instance US Word16 where+    data USet Word16 = Word16Tip | Word16Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Word16 !(USet Word16) !(USet Word16)+    view Word16Tip = Tip+    view (Word16Bin s i l r) = Bin s i l r+    tip = Word16Tip+    bin = Word16Bin++instance US Word32 where+    data USet Word32 = Word32Tip | Word32Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Word32 !(USet Word32) !(USet Word32)+    view Word32Tip = Tip+    view (Word32Bin s i l r) = Bin s i l r+    tip = Word32Tip+    bin = Word32Bin++instance US Word64 where+    data USet Word64 = Word64Tip | Word64Bin {-# UNPACK #-} !Size {-# UNPACK #-} !Word64 !(USet Word64) !(USet Word64)+    view Word64Tip = Tip+    view (Word64Bin s i l r) = Bin s i l r+    tip = Word64Tip+    bin = Word64Bin++instance US Double where+    data USet Double = DoubleTip | DoubleBin {-# UNPACK #-} !Size {-# UNPACK #-} !Double !(USet Double) !(USet Double)+    view DoubleTip = Tip+    view (DoubleBin s i l r) = Bin s i l r+    tip = DoubleTip+    bin = DoubleBin++instance US Float where+    data USet Float = FloatTip | FloatBin {-# UNPACK #-} !Size {-# UNPACK #-} !Float !(USet Float) !(USet Float)+    view FloatTip = Tip+    view (FloatBin s i l r) = Bin s i l r+    tip = FloatTip+    bin = FloatBin+
monoids.cabal view
@@ -1,5 +1,5 @@ name:		    monoids-version:	    0.1.32+version:	    0.1.33 license:	    BSD3 license-file:   LICENSE author:		    Edward A. Kmett@@ -70,11 +70,13 @@     Data.Ring.Module.AutomaticDifferentiation     Data.Ring.Semi     Data.Ring.Semi.BitSet+    Data.Ring.Semi.Kleene     Data.Ring.Semi.Near     Data.Ring.Semi.Near.Trie     Data.Ring.Semi.Natural     Data.Ring.Semi.Ord     Data.Ring.Semi.Tropical     Data.Ring.Sugar+    Data.Set.Unboxed    ghc-options: -Wall -fno-warn-duplicate-exports