monoids 0.1.33 → 0.1.36

raw patch · 34 files changed

+818/−1881 lines, 34 filesdep −bitsetPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: bitset

API changes (from Hackage documentation)

Files

• Data/Field.hs +0/−29
• Data/Field/VectorSpace.hs +0/−11
• Data/Generator.hs +51/−4
• Data/Group.hs +58/−6
• Data/Group/Multiplicative.hs +0/−56
• Data/Group/Multiplicative/Sugar.hs +0/−41
• Data/Group/Sugar.hs +23/−4
• Data/Monoid/Additive/Sugar.hs +0/−28
• Data/Monoid/Applicative.hs +1/−3
• Data/Monoid/Combinators.hs +9/−3
• Data/Monoid/FromString.hs +2/−2
• Data/Monoid/Instances.hs +53/−9
• Data/Monoid/Monad.hs +1/−2
• Data/Monoid/Multiplicative.hs +69/−77
• Data/Monoid/Multiplicative/Sugar.hs +0/−30
• Data/Monoid/Ord.hs +1/−1
• Data/Monoid/Reducer.hs +21/−17
• Data/Monoid/Sugar.hs +41/−0
• Data/Ring.hs +131/−5
• Data/Ring/Algebra.hs +0/−14
• Data/Ring/Boolean.hs +60/−22
• Data/Ring/Module.hs +46/−12
• Data/Ring/Module/AutomaticDifferentiation.hs +12/−12
• Data/Ring/Semi.hs +0/−30
• Data/Ring/Semi/BitSet.hs +58/−21
• Data/Ring/Semi/Kleene.hs +2/−2
• Data/Ring/Semi/Natural.hs +30/−16
• Data/Ring/Semi/Near.hs +0/−93
• Data/Ring/Semi/Near/Trie.hs +2/−6
• Data/Ring/Semi/Ord.hs +19/−4
• Data/Ring/Semi/Tropical.hs +30/−7
• Data/Ring/Sugar.hs +0/−23
• Data/Set/Unboxed.hs +0/−1258
• monoids.cabal +98/−33

@@ -1,29 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Field--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable-----------------------------------------------------------------------------------module Data.Field-    ( module Data.Group.Multiplicative-    , module Data.Ring-    , Field-    ) where--import Data.Group.Multiplicative-import Data.Ring-import Data.Monoid.Self-import Data.Monoid.FromString-import Data.Monoid.Reducer--class (Ring a, MultiplicativeGroup a) => Field a--instance Field f => Field (Dual f)-instance Field f => Field (Self f)-instance Field f => Field (FromString f)-instance Field f => Field (ReducedBy f s)

@@ -1,11 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}-module Data.Field.VectorSpace -    ( module Data.Field-    , module Data.Ring.Module-    , VectorSpace-    ) where--import Data.Field-import Data.Ring.Module-    -class (Field f, Module f g) => VectorSpace f g

@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, CPP #-}  ----------------------------------------------------------------------------- -- |@@ -36,17 +36,31 @@     , reduceWith     ) where +#ifdef M_ARRAY import Data.Array -import Data.Word (Word8)+#endif+++#ifdef M_TEXT import Data.Text (Text)-import Data.Foldable (fold,foldMap) import qualified Data.Text as Text+#endif+++#ifdef M_BYTESTRING import qualified Data.ByteString as Strict (ByteString, foldl') import qualified Data.ByteString.Char8 as Strict8 (foldl') import qualified Data.ByteString.Lazy as Lazy (ByteString, toChunks) import qualified Data.ByteString.Lazy.Char8 as Lazy8 (toChunks)-import qualified Data.Sequence as Seq+import Data.Word (Word8)+#endif++#ifdef M_FINGERTREE import Data.FingerTree (Measured, FingerTree)+#endif++#ifdef M_CONTAINERS+import qualified Data.Sequence as Seq import Data.Sequence (Seq) import qualified Data.Set as Set import Data.Set (Set)@@ -56,8 +70,13 @@ import Data.IntMap (IntMap) import qualified Data.Map as Map import Data.Map (Map)+#endif +#ifdef M_PARALLEL import Control.Parallel.Strategies+#endif++import Data.Foldable (fold,foldMap) import Data.Monoid.Reducer  -- | minimal definition 'mapReduce' or 'mapTo'@@ -71,6 +90,7 @@     mapTo f m = mappend m . mapReduce f     mapFrom f = mappend . mapReduce f +#ifdef M_BYTESTRING instance Generator Strict.ByteString where     type Elem Strict.ByteString = Word8     mapTo f = Strict.foldl' (\a -> snoc a . f)@@ -78,19 +98,25 @@ instance Generator Lazy.ByteString where     type Elem Lazy.ByteString = Word8     mapReduce f = fold . parMap rwhnf (mapReduce f) . Lazy.toChunks+#endif +#ifdef M_TEXT instance Generator Text where     type Elem Text = Char     mapTo f = Text.foldl' (\a -> snoc a . f)+#endif  instance Generator [c] where     type Elem [c] = c     mapReduce f = foldr (cons . f) mempty +#ifdef M_FINGERTREE instance Measured v e => Generator (FingerTree v e) where     type Elem (FingerTree v e) = e     mapReduce f = foldMap (unit . f)+#endif +#ifdef M_CONTAINERS instance Generator (Seq c) where     type Elem (Seq c) = c     mapReduce f = foldMap (unit . f)@@ -110,14 +136,18 @@ instance Generator (Map k v) where     type Elem (Map k v) = (k,v)      mapReduce f = mapReduce f . Map.toList+#endif +#ifdef M_ARRAY instance Ix i => Generator (Array i e) where     type Elem (Array i e) = (i,e)     mapReduce f = mapReduce f . assocs+#endif  -- | a 'Generator' transformer that asks only for the keys of an indexed container newtype Keys c = Keys { getKeys :: c }  +#ifdef M_CONTAINERS instance Generator (Keys (IntMap v)) where     type Elem (Keys (IntMap v)) = Int     mapReduce f = mapReduce f . IntMap.keys . getKeys@@ -125,14 +155,18 @@ instance Generator (Keys (Map k v)) where     type Elem (Keys (Map k v)) = k     mapReduce f = mapReduce f . Map.keys . getKeys+#endif +#ifdef M_ARRAY instance Ix i => Generator (Keys (Array i e)) where     type Elem (Keys (Array i e)) = i     mapReduce f = mapReduce f . range . bounds . getKeys+#endif  -- | a 'Generator' transformer that asks only for the values contained in an indexed container newtype Values c = Values { getValues :: c }  +#ifdef M_CONTAINERS instance Generator (Values (IntMap v)) where     type Elem (Values (IntMap v)) = v     mapReduce f = mapReduce f . IntMap.elems . getValues@@ -140,15 +174,19 @@ instance Generator (Values (Map k v)) where     type Elem (Values (Map k v)) = v     mapReduce f = mapReduce f . Map.elems . getValues+#endif +#ifdef M_ARRAY instance Ix i => Generator (Values (Array i e)) where     type Elem (Values (Array i e)) = e     mapReduce f = mapReduce f . elems . getValues+#endif  -- | a 'Generator' transformer that treats 'Word8' as 'Char' -- This lets you use a 'ByteString' as a 'Char' source without going through a 'Monoid' transformer like 'UTF8' newtype Char8 c = Char8 { getChar8 :: c }  +#ifdef M_BYTESTRING instance Generator (Char8 Strict.ByteString) where     type Elem (Char8 Strict.ByteString) = Char     mapTo f m = Strict8.foldl' (\a -> snoc a . f) m . getChar8@@ -156,17 +194,25 @@ instance Generator (Char8 Lazy.ByteString) where     type Elem (Char8 Lazy.ByteString) = Char     mapReduce f = fold . parMap rwhnf (mapReduce f . Char8) . Lazy8.toChunks . getChar8+#endif  -- | Apply a 'Reducer' directly to the elements of a 'Generator' reduce :: (Generator c, Elem c `Reducer` m) => c -> m reduce = mapReduce id+#ifdef M_BYTESTRING {-# SPECIALIZE reduce :: (Word8 `Reducer` m) => Strict.ByteString -> m #-} {-# SPECIALIZE reduce :: (Word8 `Reducer` m) => Lazy.ByteString -> m #-} {-# SPECIALIZE reduce :: (Char `Reducer` m) => Char8 Strict.ByteString -> m #-} {-# SPECIALIZE reduce :: (Char `Reducer` m) => Char8 Lazy.ByteString -> m #-}+#endif {-# SPECIALIZE reduce :: (c `Reducer` m) => [c] -> m #-}+#ifdef M_FINGERTREE {-# SPECIALIZE reduce :: (Generator (FingerTree v e), e `Reducer` m) => FingerTree v e -> m #-}+#endif+#ifdef M_TEXT {-# SPECIALIZE reduce :: (Char `Reducer` m) => Text -> m #-}+#endif+#ifdef M_CONTAINERS {-# SPECIALIZE reduce :: (e `Reducer` m) => Seq e -> m #-} {-# SPECIALIZE reduce :: (Int `Reducer` m) => IntSet -> m #-} {-# SPECIALIZE reduce :: (a `Reducer` m) => Set a -> m #-}@@ -176,6 +222,7 @@ {-# SPECIALIZE reduce :: (k `Reducer` m) => Keys (Map k v) -> m #-} {-# SPECIALIZE reduce :: (v `Reducer` m) => Values (IntMap v) -> m #-} {-# SPECIALIZE reduce :: (v `Reducer` m) => Values (Map k v) -> m #-}+#endif  mapReduceWith :: (Generator c, e `Reducer` m) => (m -> n) -> (Elem c -> e) -> c -> n mapReduceWith f g = f . mapReduce g

@@ -12,17 +12,23 @@ -----------------------------------------------------------------------------  module Data.Group -    ( module Data.Monoid.Additive+    ( module Data.Monoid.Multiplicative     , Group     , gnegate     , gsubtract     , minus+    , MultiplicativeGroup+    , over+    , under+    , grecip     ) where -import Data.Monoid.Additive+import Data.Monoid.Multiplicative import Data.Monoid.Self++#ifdef X_OverloadedStrings import Data.Monoid.FromString-import Data.Monoid.Reducer+#endif  infixl 6 `minus` @@ -52,11 +58,57 @@     gnegate = Self . gnegate . getSelf     Self a `minus` Self b = Self (a `minus` b) -instance Group a => Group (FromString a) where-    gnegate = FromString . gnegate . getFromString-    FromString a `minus` FromString b = FromString (a `minus` b)+-- | Minimal definition over or grecip+class Multiplicative g => MultiplicativeGroup g where+    -- | @x / y@+    over :: g -> g -> g+    -- | @x \ y@+    under :: g -> g -> g+    grecip :: g -> g +    x `under` y = grecip x `times` y+    x `over` y = x `times` grecip y+    grecip x = one `over` x++instance MultiplicativeGroup g => Group (Log g) where+    Log x `minus` Log y = Log (x `over` y)+    Log x `gsubtract` Log y = Log (x `under` y)+    gnegate (Log x) = Log (grecip x)++instance Group g => MultiplicativeGroup (Exp g) where+    Exp x `over` Exp y = Exp (x `minus` y)+    Exp x `under` Exp y = Exp (x `gsubtract` y)+    grecip (Exp x) = Exp (gnegate x)++instance MultiplicativeGroup g => MultiplicativeGroup (Self g) where+    Self x `over` Self y = Self (x `over` y)+    Self x `under` Self y = Self (x `under` y)+    grecip (Self x) = Self (grecip x)++#ifdef M_REFLECTION+instance MultiplicativeGroup g => MultiplicativeGroup (ReducedBy g s) where+    Reduction x `over` Reduction y = Reduction (x `over` y)+    Reduction x `under` Reduction y = Reduction (x `under` y)+    grecip (Reduction x) = Reduction (grecip x)+ instance Group a => Group (ReducedBy a s) where     gnegate = Reduction . gnegate . getReduction     Reduction a `minus` Reduction b = Reduction (a `minus` b)+    Reduction a `gsubtract` Reduction b = Reduction (a `gsubtract` b)+#endif++instance MultiplicativeGroup a => MultiplicativeGroup (Dual a) where+    grecip = Dual . grecip . getDual++#ifdef X_OverloadedStrings+instance MultiplicativeGroup g => MultiplicativeGroup (FromString g) where+    FromString x `over` FromString y = FromString (x `over` y)+    FromString x `under` FromString y = FromString (x `under` y)+    grecip (FromString x) = FromString (grecip x)++instance Group a => Group (FromString a) where+    gnegate = FromString . gnegate . getFromString+    FromString a `minus` FromString b = FromString (a `minus` b)+    FromString a `gsubtract` FromString b = FromString (a `gsubtract` b)+#endif 

@@ -1,56 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Group.Multiplicative--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable-----------------------------------------------------------------------------------module Data.Group.Multiplicative -    ( module Data.Monoid.Multiplicative-    , module Data.Group-    , MultiplicativeGroup-    , over-    , under-    , grecip-    ) where--import Data.Monoid.Multiplicative-import Data.Group-import Data.Monoid.Self-import Data.Monoid.FromString-import Data.Monoid.Reducer--    --- | Minimal definition over or grecip-class Multiplicative g => MultiplicativeGroup g where-    -- | @x / y@-    over :: g -> g -> g-    -- | @x \ y@-    under :: g -> g -> g-    grecip :: g -> g--    x `under` y = grecip x `times` y-    x `over` y = x `times` grecip y-    grecip x = one `over` x--instance MultiplicativeGroup g => MultiplicativeGroup (Self g) where-    Self x `over` Self y = Self (x `over` y)-    Self x `under` Self y = Self (x `under` y)-    grecip (Self x) = Self (grecip x)--instance MultiplicativeGroup g => MultiplicativeGroup (FromString g) where-    FromString x `over` FromString y = FromString (x `over` y)-    FromString x `under` FromString y = FromString (x `under` y)-    grecip (FromString x) = FromString (grecip x)--instance MultiplicativeGroup g => MultiplicativeGroup (ReducedBy g s) where-    Reduction x `over` Reduction y = Reduction (x `over` y)-    Reduction x `under` Reduction y = Reduction (x `under` y)-    grecip (Reduction x) = Reduction (grecip x)--instance MultiplicativeGroup a => MultiplicativeGroup (Dual a) where-    grecip = Dual . grecip . getDual

@@ -1,41 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Group.Multiplicative.Sugar--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Syntactic sugar for working with groups that conflicts with names from the "Prelude".------ > import Prelude hiding ((-), (+), (*), (/), negate, subtract, recip)--- > import Data.Group.Multiplicative.Sugar-----------------------------------------------------------------------------------module Data.Group.Multiplicative.Sugar -    ( module Data.Monoid.Multiplicative.Sugar-    , module Data.Group.Multiplicative-    , module Data.Group.Sugar-    , (/)-    , (\\)-    , recip-    ) where--import Data.Group.Multiplicative-import Data.Monoid.Multiplicative.Sugar-import Data.Group.Sugar-import Prelude hiding ((-), (+), (*), (/), negate, subtract, recip)--infixl 7 /-infixr 7 \\--(/) :: MultiplicativeGroup g => g -> g -> g-(/) = over--(\\) :: MultiplicativeGroup g => g -> g -> g-(\\) = under--recip :: MultiplicativeGroup g => g -> g-recip = grecip

@@ -9,23 +9,30 @@ -- -- Syntactic sugar for working with groups that conflicts with names from the "Prelude". ----- > import Prelude hiding ((-), (+), negate, subtract)+-- > import Prelude hiding ((-), (+), (*), (/), (^), (^^), negate, subtract, recip) -- > import Data.Group.Sugar -- -----------------------------------------------------------------------------  module Data.Group.Sugar -    ( module Data.Monoid.Additive.Sugar+    ( module Data.Monoid.Sugar     , module Data.Group     , (-)     , negate     , subtract+    , (/)+    , (.\.)+    , (^^)+    , recip     ) where -import Data.Monoid.Additive.Sugar+import Data.Monoid.Sugar+import Data.Group.Combinators as Group import Data.Group-import Prelude hiding ((-), negate, subtract)+import Prelude hiding ((-), (+), (*), (/), (^^), negate, subtract, recip) +infixl 8 /+infixr 8 .\. infixl 7 -  (-) :: Group g => g -> g -> g@@ -36,3 +43,15 @@  subtract :: Group g => g -> g -> g subtract = gsubtract++(/) :: MultiplicativeGroup g => g -> g -> g+(/) = over++(.\.) :: MultiplicativeGroup g => g -> g -> g+(.\.) = under++recip :: MultiplicativeGroup g => g -> g+recip = grecip++(^^) :: MultiplicativeGroup g => g -> Integer -> g+g ^^ n = getLog (Group.replicate (Log g) n)

@@ -1,28 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Monoid.Additive.Sugar--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Syntactic sugar for working with a 'Monoid' that conflicts with names from the "Prelude".------ > import Prelude hiding ((+))--- > import Data.Monoid.Additive.Sugar-----------------------------------------------------------------------------------module Data.Monoid.Additive.Sugar -    ( module Data.Monoid.Additive-    , (+)-    ) where--import Data.Monoid.Additive-import Prelude hiding ((+))--infixl 6 + --(+) :: Monoid m => m -> m -> m -(+) = mappend

@@ -15,7 +15,6 @@  module Data.Monoid.Applicative      ( module Data.Monoid.Reducer-    , module Data.Ring.Semi.Near     , module Data.Ring.Module     , Traversal(Traversal,getTraversal)     , Alt(Alt,getAlt)@@ -25,7 +24,6 @@  import Control.Applicative import Data.Monoid.Reducer-import Data.Ring.Semi.Near import Data.Ring.Module import Control.Functor.Pointed @@ -80,7 +78,7 @@ -- | if @m@ is a 'Module' over @r@ and @f@ is a 'Applicative' then @f `App` m@ is a 'Module' over @r@ as well  newtype App f m = App { getApp :: f m } -    deriving (Eq,Ord,Show,Read,Functor,Pointed,Applicative,Alternative,Copointed)+    deriving (Eq,Ord,Show,Read,Functor,Applicative,Alternative,Pointed,Copointed)  instance (Monoid m, Applicative f) => Monoid (f `App` m) where     mempty = pure mempty

@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, CPP #-}  ----------------------------------------------------------------------------- -- |@@ -22,14 +22,18 @@       repeat     , replicate     , cycle+#ifdef M_QUICKCHECK     -- * QuickCheck Properties     , prop_replicate_right_distributive+#endif     ) where  import Prelude hiding (replicate, cycle, repeat) import Data.Monoid.Reducer-import Test.QuickCheck +#ifdef M_QUICKCHECK +import Test.QuickCheck+#endif  -- | A generalization of 'Data.List.cycle' to an arbitrary 'Monoid'. May fail to terminate for some values in some monoids. cycle :: Monoid m => m -> m@@ -43,7 +47,7 @@ -- <http://augustss.blogspot.com/2008/07/lost-and-found-if-i-write-108-in.html> replicate :: (Monoid m, Integral n) => m -> n -> m replicate x0 y0 -    | y0 < 0 = mempty -- error "negative length"+    | y0 < 0 = error "Data.Monoid.Combinators.replicate: negative length"     | y0 == 0 = mempty     | otherwise = f x0 y0     where@@ -57,6 +61,8 @@             | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) (x `mappend` z) {-# INLINE replicate #-} +#ifdef M_QUICKCHECK prop_replicate_right_distributive :: (Eq m, Monoid m, Arbitrary m, Integral n) => m -> n -> n -> Bool prop_replicate_right_distributive m x y     = replicate m (x + y) == replicate m x `mappend` replicate m y+#endif

@@ -2,7 +2,7 @@  ----------------------------------------------------------------------------- -- |--- Module      :  Data.Monoid.Additive+-- Module      :  Data.Monoid.FromString -- Copyright   :  (c) Edward Kmett 2009 -- License     :  BSD-style -- Maintainer  :  ekmett@gmail.com@@ -23,7 +23,7 @@ import Data.Generator import Data.Monoid.Reducer import Data.Monoid.Instances ()-import GHC.Exts+import Data.String  data FromString m = FromString { getFromString :: m }  

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  -----------------------------------------------------------------------------@@ -27,33 +27,41 @@ -- -- * 'Monoid' instances for 'Int', 'Integer', and 'Ratio' using @(+,0)@ --+-- * 'Num' and 'Bits' instances for 'Bool' as a 'Boolean' `&&`/`||` 'SemiRing'+-- -- This module is automatically included everywhere this functionality is required -- within this package. You should only have to import this module yourself if you  -- want these instances for your own purposes. ----------------------------------------------------------------------------- -module Data.Monoid.Instances where+module Data.Monoid.Instances () where +#ifdef M_MTL import Control.Monad.Reader- import qualified Control.Monad.RWS.Lazy as LRWS import qualified Control.Monad.RWS.Strict as SRWS- import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState- import Control.Monad.Writer import qualified Control.Monad.Writer.Strict as SWriter+#endif +#ifdef X_OverloadedStrings import Data.String+#endif +import Data.Bits import Data.Ratio +#ifdef M_FINGERTREE import Data.FingerTree+#endif +#ifdef M_PARSEC import Text.Parsec.Prim+#endif --- orphan Monoid instances for Monad Transformers+#ifdef M_MTL instance (MonadPlus m, Monoid w) => Monoid (SWriter.WriterT w m n) where     mempty = mzero     mappend = mplus@@ -81,18 +89,21 @@ instance MonadPlus m => Monoid (LState.StateT s m n) where     mempty = mzero     mappend = mplus+#endif --- orphan, which should be in Data.FingerTree+#ifdef M_FINGERTREE instance Measured v a => Monoid (FingerTree v a) where     mempty = empty     mappend = (><)+#endif --- orphan, which should be in Parsec+#ifdef M_PARSEC instance Stream s m t => Monoid (ParsecT s u m a) where     mempty = mzero     a `mappend` b = try a <|> b+#endif --- orphan, perhaps should be in Data.String+#ifdef X_OverloadedStrings instance (IsString a, IsString b) => IsString (a,b) where     fromString a = (fromString a, fromString a) @@ -104,6 +115,7 @@  instance (IsString a, IsString b, IsString c, IsString d, IsString e) => IsString (a,b,c,d,e) where     fromString a = (fromString a, fromString a, fromString a, fromString a, fromString a)+#endif  instance Monoid Int where     mempty = 0@@ -116,3 +128,35 @@ instance Integral m => Monoid (Ratio m) where     mempty = 0     mappend = (+)++instance Monoid Bool where+    mempty = 0+    mappend = (||)++-- boolean semiring+instance Num Bool where+    (+) = (||)+    (*) = (&&)+    x - y = x && not y+    negate = not+    abs = id+    signum = id+    fromInteger 0 = False+    fromInteger _ = True++instance Bits Bool where+    (.&.)           = (&&)+    (.|.)           = (||)+    xor True True   = False+    xor False False = False+    xor _ _         = True+    complement      = not+    shiftL a b      = a && (b == 0)+    shiftR a b      = a && (b == 0)+    shift  a b      = a && (b == 0)+    rotate a _      = a+    bit             = (==0)+    setBit a b      = a || (b == 0)+    testBit a b     = a && (b == 0)+    bitSize _       = 1+    isSigned _      = False

@@ -15,7 +15,7 @@  module Data.Monoid.Monad      ( module Data.Monoid.Reducer-    , module Data.Ring.Semi.Near+    , module Data.Ring.Module     -- * Actions     , Action(Action,getAction)     , snocAction@@ -28,7 +28,6 @@ import Control.Applicative import Control.Functor.Pointed import Data.Monoid.Reducer-import Data.Ring.Semi.Near import Data.Ring.Module import Control.Monad 

@@ -41,41 +41,47 @@     ) where  import Control.Applicative+import Data.Monoid.Additive+import Data.Generator+import Data.Monoid.Instances ()+import Data.Monoid.Self+import Data.Ratio +#ifdef M_STM import Control.Concurrent.STM+#endif +#ifdef M_MTL import Control.Monad.Cont import Control.Monad.Identity- import Control.Monad.Reader- import qualified Control.Monad.RWS.Lazy as LRWS import qualified Control.Monad.RWS.Strict as SRWS- import qualified Control.Monad.State.Lazy as LState import qualified Control.Monad.State.Strict as SState- import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter- import qualified Control.Monad.ST.Lazy as LST import qualified Control.Monad.ST.Strict as SST+#endif +#ifdef M_FINGERTREE import Data.FingerTree--import Data.Monoid.Additive-import Data.Monoid.FromString-import Data.Generator-import Data.Monoid.Instances ()-import Data.Monoid.Self--import Data.Ratio+#endif +#ifdef M_CONTAINERS import qualified Data.Sequence as Seq import Data.Sequence (Seq)+#endif +#ifdef M_PARSEC import Text.Parsec.Prim+#endif +#ifdef X_OverloadedStrings+import Data.Monoid.FromString+#endif+ class Multiplicative m where     one :: m     times :: m -> m -> m@@ -102,144 +108,130 @@     one = Exp mempty     Exp a `times` Exp b = Exp (a `mappend` b) --- simple monoid transformer instances instance Multiplicative m => Multiplicative (Self m) where     one = Self one       Self a `times` Self b = Self (a `times` b) -instance Multiplicative m => Multiplicative (FromString m) where-    one = FromString one-    FromString a `times` FromString b = FromString (a `times` b)---- the goal of this is that I can make left seminearrings out of any 'Alternative' wrapped around a monoid--- in particular its useful for containers-+-- Monad instances instance Monoid m => Multiplicative [m] where     one = return mempty     times = liftM2 mappend+instance Monoid m => Multiplicative (Maybe m) where+    one = return mempty+    times = liftM2 mappend+instance Monoid n => Multiplicative (IO n) where+    one = return mempty+    times = liftM2 mappend+instance Monoid n => Multiplicative (SST.ST s n) where+    one = return mempty+    times = liftM2 mappend+instance Monoid n => Multiplicative (LST.ST s n) where+    one = return mempty+    times = liftM2 mappend +-- Applicative instances+instance Monoid n => Multiplicative (ZipList n) where+    one = pure mempty+    times = liftA2 mappend++instance Monoid m => Multiplicative (Const m a) where+    one = pure undefined+    times = liftA2 undefined++-- Numeric instances+instance Multiplicative Int where+    one = 1+    times = (*)++instance Multiplicative Integer where+    one = 1+    times = (*)++instance Integral m => Multiplicative (Ratio m) where+    one = 1+    times = (*)++#ifdef M_CONTAINERS instance Monoid m => Multiplicative (Seq m) where     one = return mempty     times = liftM2 mappend+#endif +#ifdef M_FINGERTREE -- and things that can't quite be a Monad in Haskell instance (Measured v m, Monoid m) => Multiplicative (FingerTree v m) where     one = singleton mempty     xss `times` yss = getSelf $ mapReduce (flip fmap' yss . mappend) xss---- but it can at least serve as a canonical multiplication for any monad. -instance Monoid m => Multiplicative (Maybe m) where-    one = return mempty-    times = liftM2 mappend+#endif +#ifdef M_MTL instance Monoid m => Multiplicative (Identity m) where     one = return mempty     times = liftM2 mappend- instance (Monoid m) => Multiplicative (Cont r m) where     one = return mempty     times = liftM2 mappend- instance (Monoid w, Monoid m) => Multiplicative (SRWS.RWS r w s m) where     one = return mempty     times = liftM2 mappend- instance (Monoid w, Monoid m) => Multiplicative (LRWS.RWS r w s m) where     one = return mempty     times = liftM2 mappend- instance Monoid m => Multiplicative (SState.State s m) where     one = return mempty     times = liftM2 mappend- instance Monoid m => Multiplicative (LState.State s m) where     one = return mempty     times = liftM2 mappend- instance Monoid m => Multiplicative (Reader e m) where     one = return mempty     times = liftM2 mappend- instance (Monoid w, Monoid m) => Multiplicative (SWriter.Writer w m) where     one = return mempty     times = liftM2 mappend- instance (Monoid w, Monoid m) => Multiplicative (LWriter.Writer w m) where     one = return mempty     times = liftM2 mappend- instance (Monad m, Monoid n) => Multiplicative (ContT r m n) where     one = return mempty      times = liftM2 mappend- instance (Monad m, Monoid w, Monoid n) => Multiplicative (SRWS.RWST r w s m n) where      one = return mempty      times = liftM2 mappend- instance (Monad m, Monoid w, Monoid n) => Multiplicative (LRWS.RWST r w s m n) where      one = return mempty      times = liftM2 mappend- instance (Monad m, Monoid n) => Multiplicative (SState.StateT s m n) where     one = return mempty     times = liftM2 mappend- instance (Monad m, Monoid n) => Multiplicative (LState.StateT s m n) where     one = return mempty     times = liftM2 mappend- instance (Monad m, Monoid n) => Multiplicative (ReaderT e m n) where     one = return mempty     times = liftM2 mappend- instance (Monad m, Monoid w, Monoid n) => Multiplicative (SWriter.WriterT w m n) where     one = return mempty      times = liftM2 mappend- instance (Monad m, Monoid w, Monoid n) => Multiplicative (LWriter.WriterT w m n) where     one = return mempty      times = liftM2 mappend--instance Monoid n => Multiplicative (IO n) where-    one = return mempty-    times = liftM2 mappend--instance Monoid n => Multiplicative (SST.ST s n) where-    one = return mempty-    times = liftM2 mappend--instance Monoid n => Multiplicative (LST.ST s n) where-    one = return mempty-    times = liftM2 mappend+#endif +#ifdef M_STM instance Monoid n => Multiplicative (STM n) where     one = return mempty     times = liftM2 mappend+#endif +#ifdef M_PARSEC instance (Stream s m t, Monoid n) => Multiplicative (ParsecT s u m n) where     one = return mempty     times = liftM2 mappend---- Applicative instances--instance Monoid n => Multiplicative (ZipList n) where-    one = pure mempty-    times = liftA2 mappend--instance Monoid m => Multiplicative (Const m a) where-    one = pure undefined-    times = liftA2 undefined---- Numeric instances-instance Multiplicative Int where-    one = 1-    times = (*)--instance Multiplicative Integer where-    one = 1-    times = (*)--instance Integral m => Multiplicative (Ratio m) where-    one = 1-    times = (*)+#endif +#ifdef X_OverloadedStrings +instance Multiplicative m => Multiplicative (FromString m) where+    one = FromString one+    FromString a `times` FromString b = FromString (a `times` b)+#endif

@@ -1,30 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Monoid.Multiplicative.Sugar--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Syntactic sugar for working with a 'Multiplicative' monoids that conflicts with names from the "Prelude".------ > import Prelude hiding ((+),(*))--- > import Data.Monoid.Multiplicative.Sugar-----------------------------------------------------------------------------------module Data.Monoid.Multiplicative.Sugar-    ( module Data.Monoid.Additive.Sugar-    , module Data.Monoid.Multiplicative-    , (*)-    ) where--import Data.Monoid.Additive.Sugar-import Data.Monoid.Multiplicative-import Prelude hiding ((*))--infixl 7 *--(*) :: Multiplicative r => r -> r -> r-(*) = times

@@ -28,7 +28,7 @@  import Control.Functor.Pointed import Data.Monoid.Reducer (Reducer, unit, Monoid, mappend, mempty)-import Data.Ring.Semi+import Data.Ring  -- | The 'Monoid' @('max','minBound')@ newtype Max a = Max { getMax :: a } deriving (Eq,Ord,Show,Read,Bounded)

@@ -1,10 +1,10 @@-{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving, TypeOperators, ScopedTypeVariables, CPP #-}  ----------------------------------------------------------------------------- -- | -- Module      :  Data.Monoid.Reducer -- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style+-- License     :  BSD3 -- Maintainer  :  ekmett@gmail.com -- Stability   :  experimental -- Portability :  non-portable (MPTCs)@@ -33,30 +33,31 @@ import Data.Monoid.Instances ()  import Data.Foldable++#ifdef M_FINGERTREE import Data.FingerTree+#endif +#ifdef M_CONTAINERS import qualified Data.Sequence as Seq import Data.Sequence (Seq)- import qualified Data.Set as Set import Data.Set (Set)- import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)- import qualified Data.IntMap as IntMap import Data.IntMap (IntMap)--import Data.Reflection- import qualified Data.Map as Map- import Data.Map (Map)+#endif -import Text.Parsec.Prim+#ifdef M_REFLECTION+import Data.Reflection+#endif ---import qualified Data.BitSet as BitSet---import Data.BitSet (BitSet)+#ifdef M_PARSEC+import Text.Parsec.Prim+#endif  -- | This type may be best read infix. A @c `Reducer` m@ is a 'Monoid' @m@ that maps -- values of type @c@ through @unit@ to values of type @m@. A @c@-'Reducer' may also@@ -155,14 +156,19 @@ instance Reducer a (Last a) where     unit = Last . Just +#ifdef M_FINGERTREE instance Measured v a => Reducer a (FingerTree v a) where     unit = singleton     cons = (<|)     snoc = (|>) +#endif +#ifdef M_PARSEC instance (Stream s m t, c `Reducer` a) => Reducer c (ParsecT s u m a) where     unit = return . unit+#endif +#ifdef M_CONTAINERS instance Reducer a (Seq a) where     unit = Seq.singleton     cons = (Seq.<|)@@ -189,12 +195,9 @@     unit = uncurry Map.singleton     cons = uncurry Map.insert     snoc = flip . uncurry . Map.insertWith $ const id--{--instance Enum a => Reducer a (BitSet a) where-    unit m = BitSet.insert m BitSet.empty--}+#endif +#ifdef M_REFLECTION data (m `ReducedBy` s) = Reduction { getReduction :: m }   instance Monoid m => Monoid (m `ReducedBy` s) where@@ -203,3 +206,4 @@  instance (s `Reflects` (a -> m), Monoid m) => Reducer a (m `ReducedBy` s) where     unit = Reduction . reflect (undefined :: s)+#endif

@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Monoid.Additive.Sugar+-- Copyright   :  (c) Edward Kmett 2009+-- License     :  BSD-style+-- Maintainer  :  ekmett@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Syntactic sugar for working with a 'Monoid' and 'Multiplicative' instances +-- that conflicts with names from the "Prelude".+--+-- > import Prelude hiding ((+),(*),(^))+-- > import Data.Monoid.Sugar+--+-----------------------------------------------------------------------------+--+module Data.Monoid.Sugar+    ( module Data.Monoid.Multiplicative+    , module Data.Ring.Semi.Natural+    , (+)+    , (*)+    , (^)+    ) where++import Prelude hiding ((*),(^),(+))+import Data.Monoid.Multiplicative+import Data.Ring.Semi.Natural+import qualified Data.Monoid.Combinators as Monoid++infixl 6 + +infixl 7 *++(+) :: Monoid m => m -> m -> m +(+) = mappend++(*) :: Multiplicative r => r -> r -> r+(*) = times++(^) :: Multiplicative r => r -> Natural -> r+r ^ n = getLog (Monoid.replicate (Log r) n)

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Ring@@ -7,22 +9,146 @@ -- Stability   :  experimental -- Portability :  portable (instances use MPTCs) --+--+-- Defines left- and right- seminearrings. Every 'MonadPlus' wrapped around+-- a 'Monoid' qualifies due to the distributivity of (>>=) over 'mplus'.+--+-- See <http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WordNumbers1/>+-- -----------------------------------------------------------------------------  module Data.Ring     ( module Data.Group-    , module Data.Ring.Semi+    , Ringoid+    , LeftSemiNearRing+    , RightSemiNearRing+    , SemiRing     , Ring+    , DivisionRing+    , Field     ) where  import Data.Group-import Data.Ring.Semi import Data.Monoid.Self++#ifdef X_OverloadedStrings import Data.Monoid.FromString+#endif -class (Group a, SemiRing a) => Ring a+#ifdef M_MTL+import Control.Monad.Reader+import qualified Control.Monad.RWS.Lazy as LRWS+import qualified Control.Monad.RWS.Strict as SRWS+import qualified Control.Monad.State.Lazy as LState+import qualified Control.Monad.State.Strict as SState+import qualified Control.Monad.Writer.Lazy as LWriter+import qualified Control.Monad.Writer.Strict as SWriter+#endif +#ifdef M_FINGERTREE+import Data.FingerTree+#endif++#ifdef M_CONTAINERS+import qualified Data.Sequence as Seq+import Data.Sequence (Seq)+#endif++#ifdef M_PARSEC+import Text.Parsec.Prim+#endif++#ifdef X_OverloadedStrings+import Data.Monoid.FromString+#endif++-- | @0@ annihilates `times`+class (Multiplicative m, Monoid m) => Ringoid m+instance Ringoid Integer+instance Ringoid Int+instance Ringoid m => Ringoid (Self m)+instance Ringoid m => Ringoid (Dual m)+instance Monoid m => Ringoid [m]+instance Monoid m => Ringoid (Maybe m)++-- | @a * (b + c) = (a * b) + (a * c)@+class Ringoid m => LeftSemiNearRing m +instance LeftSemiNearRing m => LeftSemiNearRing (Self m)+instance RightSemiNearRing m => LeftSemiNearRing (Dual m)++-- | @(a + b) * c = (a * c) + (b * c)@+class Ringoid m => RightSemiNearRing m +instance RightSemiNearRing m => RightSemiNearRing (Self m)+instance LeftSemiNearRing m => RightSemiNearRing (Dual m)+instance Monoid m => RightSemiNearRing [m]+instance Monoid m => RightSemiNearRing (Maybe m)++-- | A 'SemiRing' is an instance of both 'Multiplicative' and 'Monoid' where +--   'times' distributes over 'plus'.+class (RightSemiNearRing a, LeftSemiNearRing a) => SemiRing a+instance SemiRing r => SemiRing (Self r)+instance SemiRing r => SemiRing (Dual r)++class (Group a, SemiRing a) => Ring a instance Ring r => Ring (Self r)-instance Ring r => Ring (FromString r)-instance Ring r => Ring (ReducedBy r s) instance Ring r => Ring (Dual r)++class (Ring a, MultiplicativeGroup a) => DivisionRing a+instance DivisionRing r => DivisionRing (Self r)+instance DivisionRing r => DivisionRing (Dual r)++class (Ring a, MultiplicativeGroup a) => Field a+instance Field f => Field (Dual f)+instance Field f => Field (Self f)++#ifdef M_REFLECTION+instance Ringoid m => Ringoid (ReducedBy m s)+instance LeftSemiNearRing m => LeftSemiNearRing (ReducedBy m s)+instance RightSemiNearRing m => RightSemiNearRing (ReducedBy m s)+instance SemiRing r => SemiRing (ReducedBy r s)+instance Ring r => Ring (ReducedBy r s)+instance DivisionRing r => DivisionRing (ReducedBy r s)+instance Field f => Field (ReducedBy f s)+#endif++#ifdef M_PARSEC+instance (Stream s m t, Monoid a) => Ringoid (ParsecT s u m a)+instance (Stream s m t, Monoid a) => RightSemiNearRing (ParsecT s u m a)+#endif++#ifdef M_MTL+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)+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)+#endif++#ifdef M_FINGERTREE+instance (Measured v m, Monoid m) => Ringoid (FingerTree v m)+instance (Measured v m, Monoid m) => RightSemiNearRing (FingerTree v m)+#endif++#ifdef M_CONTAINERS+instance Monoid m => Ringoid (Seq m)+instance Monoid m => RightSemiNearRing (Seq m)+#endif++#ifdef X_OverloadedStrings+instance Ringoid m => Ringoid (FromString m)+instance RightSemiNearRing m => RightSemiNearRing (FromString m)+instance LeftSemiNearRing m => LeftSemiNearRing (FromString m)+instance SemiRing r => SemiRing (FromString r)+instance Ring r => Ring (FromString r)+instance DivisionRing r => DivisionRing (FromString r)+instance Field f => Field (FromString f)+#endif

@@ -1,14 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}-module Data.Ring.Algebra-    ( module Data.Ring.Module-    , 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) => RAlgebra r m 

@@ -9,39 +9,77 @@ -- Stability   :  experimental -- Portability :  non-portable (MPTCs) ----- A Boolean 'Ring' over 'Bool'. Note well that the 'mappend' of this ring is--- symmetric difference and not disjunction like you might expect. To get that --- you should use use 'Ord' from "Data.Ring.Semi.Ord.Order" on 'Bool' to get the '&&'/'||'-based --- distributive-lattice 'SemiRing'+-- A Boolean 'Ring' over any Bits instance. Note well that the 'mappend' of this ring is xor.+-- You should use use 'Ord' from "Data.Ring.Semi.Ord.Order" on 'Bool' to get the '&&'/'||'-based +-- distributive-lattice 'SemiRing'.+--+-- Also note that @gnegate = id@ in a Boolean Ring! -----------------------------------------------------------------------------  module Data.Ring.Boolean     ( module Data.Ring-    , BoolRing(BoolRing, getBoolRing)+    , Boolean(Boolean, getBoolean)     ) where +import Data.Bits import Data.Ring+import Data.Ring.Module+import Data.Ring.Semi.Natural import Data.Monoid.Reducer-import Test.QuickCheck+import Test.QuickCheck hiding ((.&.)) -newtype BoolRing = BoolRing { getBoolRing :: Bool } deriving (Eq,Ord,Show,Read,Arbitrary,CoArbitrary)+newtype Boolean a = Boolean { getBoolean :: a } deriving (Eq,Ord,Show,Read,Arbitrary,CoArbitrary) -instance Monoid BoolRing where-    mempty = BoolRing False-    BoolRing a `mappend` BoolRing b = BoolRing ((a || b) && not (a && b))+-- | @xor@+instance Bits a => Monoid (Boolean a) where+    mempty = Boolean 0  +    Boolean a `mappend` Boolean b = Boolean ((a .|. b) .&. complement (a .&. b)) -instance Group BoolRing where-    gnegate = BoolRing . not . getBoolRing+-- | @id@, since @x `xor` x = zero@+instance Bits a => Group (Boolean a) where+    gnegate = Boolean . id . getBoolean -instance Multiplicative BoolRing where-    one = BoolRing True-    BoolRing a `times` BoolRing b = BoolRing (a && b)+-- | @and@+instance Bits a => Multiplicative (Boolean a) where+    one = Boolean (complement 0)+    Boolean a `times` Boolean b = Boolean (a .&. b) -instance Ringoid BoolRing-instance LeftSemiNearRing BoolRing-instance RightSemiNearRing BoolRing-instance SemiRing BoolRing-instance Ring BoolRing+-- | the boolean ring (using symmetric difference as addition) is a ring+instance Bits a => Ringoid (Boolean a)+instance Bits a => LeftSemiNearRing (Boolean a)+instance Bits a => RightSemiNearRing (Boolean a)+instance Bits a => SemiRing (Boolean a)+instance Bits a => Ring (Boolean a) -instance Reducer Bool BoolRing where-    unit = BoolRing+-- | it reduces boolean values+instance Bits a => Reducer a (Boolean a) where+    unit = Boolean++-- | every monoid is a module over the naturals, boolring is idempotent+instance Bits a => Module Natural (Boolean a)+instance Bits a => LeftModule Natural (Boolean a) where+    0 *. _ = mempty+    _ *. m = m+instance Bits a => RightModule Natural (Boolean a) where+    _ .* 0 = mempty+    m .* _ = m+instance Bits a => Bimodule Natural (Boolean a)++-- | every group is a module over the integers, boolring is idempotent+instance Bits a => Module Integer (Boolean a)+instance Bits a => LeftModule Integer (Boolean a) where+    0 *. _ = mempty+    _ *. m = m+instance Bits a => RightModule Integer (Boolean a) where+    _ .* 0 = mempty+    m .* _ = m+instance Bits a => Bimodule Integer (Boolean a)++-- | every ring is a module over itself+instance Bits a => Module (Boolean a) (Boolean a)+instance Bits a => LeftModule (Boolean a) (Boolean a) where +    (*.) = times+instance Bits a => RightModule (Boolean a) (Boolean a) where +    (.*) = times+instance Bits a => Bimodule (Boolean a) (Boolean a)+instance Bits a => Normed (Boolean a) (Boolean a) where mabs = id

@@ -16,11 +16,17 @@  module Data.Ring.Module      ( module Data.Ring-    , LeftModule-    , (*.)-    , RightModule-    , (.*)+    -- * R-Modules     , Module+    , LeftModule, (*.)+    , RightModule, (.*)+    , Bimodule+    -- * R-Normed Modules+    , Normed, mabs+    -- * Vector Spaces+    , VectorSpace+    -- * R-Algebras+    , Algebra     ) where  import Data.Ring@@ -28,17 +34,46 @@  -- import qualified Data.Monoid.Combinators as Monoid ++class (Ringoid r, Monoid m) => Module r m where+ -- | @ (x * y) *. m = x * (y *. m) @-class (Monoid r, Multiplicative r, Monoid m) => LeftModule r m where+class (Module r m) => LeftModule r m where     (*.) :: r -> m -> m      -- | @ (m .* x) * y = m .* (x * y) @-class (Monoid r, Multiplicative r, Monoid m) => RightModule r m where+class (Module r m) => RightModule r m where     (.*) :: m -> r -> m  -- | @ (x *. m) .* y = x *. (m .* y) @-class (LeftModule r m, RightModule r m) => Module r m +class (LeftModule r m, RightModule r m) => Bimodule r m  +class (Field f, Module f g) => VectorSpace f g++-- | An r-normed module m satisfies:+--+-- (1) @mabs m >= 0@+--+-- 2 @mabs m == zero{-_r-} => m == zero{-_m-}@+--+-- 3 @mabs (m + n) <= mabs m + mabs n@+--+-- 4 @r * mabs m = mabs (r *. m) -- if m is an r-LeftModule@+--+-- 5 @mabs m * r = mabs (m .* r) -- if m is an r-RightModule@+class Module r m => Normed r m where+    mabs :: m -> r++-- | 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 `Bimodule` m, Multiplicative m) => Algebra r m ++instance (Module r m, Module r n) => Module r (m,n)+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)+ instance (LeftModule r m, LeftModule r n) => LeftModule r (m,n) where     r *. (m,n) = (r *. m, r *. n) instance (LeftModule r m, LeftModule r n, LeftModule r o) => LeftModule r (m,n,o) where@@ -57,11 +92,10 @@ instance (RightModule r m, RightModule r n, RightModule r o, RightModule r p, RightModule r q ) => RightModule r (m,n,o,p,q) where     (m,n,o,p,q) .* r = (m .* r, n .* r, o .* r, p .* r, q .* r) -instance (Module r m, Module r n) => Module r (m,n)-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)-+instance (Bimodule r m, Bimodule r n) => Bimodule r (m,n)+instance (Bimodule r m, Bimodule r n, Bimodule r o) => Bimodule r (m,n,o)+instance (Bimodule r m, Bimodule r n, Bimodule r o, Bimodule r p) => Bimodule r (m,n,o,p)+instance (Bimodule r m, Bimodule r n, Bimodule r o, Bimodule r p, Bimodule r q) => Bimodule 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

@@ -26,10 +26,10 @@  data D s r m = D r m deriving (Show,Read) -lift :: (r `Module` m) => r -> D s r m+lift :: (r `Bimodule` m) => r -> D s r m lift x = D x zero -infinitesimal :: (r `Module` m, Ringoid m) => D s r m+infinitesimal :: (r `Bimodule` m, Ringoid m) => D s r m infinitesimal = D zero one  instance Eq r => Eq (D s r m) where@@ -38,15 +38,15 @@ instance Ord r => Ord (D s r m) where     D x _ `compare` D y _ = compare x y -instance (r `Module` m) => Monoid (D s r m) where+instance (r `Bimodule` 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) -instance (r `Module` m) => Multiplicative (D s r m) where+instance (r `Bimodule` m) => Multiplicative (D s r m) where     one = D one zero     D x m `times` D y n = D (x `times` y) (x *. n `plus` m .* y) -instance (Group r, r `Module` m, Group m) => Group (D s r m) where+instance (Group r, r `Bimodule` m, Group m) => Group (D s r m) where     gnegate (D x m) = D (gnegate x) (gnegate m)     D x m `minus` D y n = D (x `minus` y) (m `minus` n)     D x m `gsubtract` D y n = D (x `gsubtract` y) (m `gsubtract` n)@@ -64,13 +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, r `Module` m) => SemiRing (D s r m)-instance (Ring r, r `Module` m, Group m) => Ring (D s r m)+instance (Ringoid r, r `Bimodule` m) => Ringoid (D s r m)+instance (LeftSemiNearRing r, Bimodule r m) => LeftSemiNearRing (D s r m)+instance (RightSemiNearRing r, Bimodule r m) => RightSemiNearRing (D s r m)+instance (SemiRing r, r `Bimodule` m) => SemiRing (D s r m)+instance (Ring r, r `Bimodule` m, Group m) => Ring (D s r m) -instance (r `Module` m, c `Reducer` r, c `Reducer` m) => Reducer c (D s r m) where+instance (r `Bimodule` 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)@@ -82,6 +82,6 @@ instance (CoArbitrary r, CoArbitrary m) => CoArbitrary (D s r m) where     coarbitrary (D r m) = coarbitrary r >< coarbitrary m -d :: (r `Module` m, Ringoid m) => (forall s. D s r m -> D s r m) -> (r,m)+d :: (r `Bimodule` 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 

@@ -1,30 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Ring.Semi--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  non-portable (MPTCs)--------------------------------------------------------------------------------------module Data.Ring.Semi-    ( module Data.Ring.Semi.Near-    , SemiRing-    ) where--import Data.Ring.Semi.Near-import Data.Monoid.Self-import Data.Monoid.FromString---- | A 'SemiRing' is an instance of both 'Multiplicative' and 'Monoid' where ---   'times' distributes over 'plus'.-class (RightSemiNearRing a, LeftSemiNearRing a) => SemiRing a--instance SemiRing r => SemiRing (Self r)-instance SemiRing r => SemiRing (FromString r)-instance SemiRing r => SemiRing (ReducedBy r s)-instance SemiRing r => SemiRing (Dual r)

@@ -13,13 +13,14 @@ -- Replacement for "Data.BitSet" extended to handle enumerations where fromEnum -- can return negative values, support efficient intersection and union -- and allow complementing of the set with respect to the bounds of the--- enumeration+-- enumeration. Treated as a Boolean semiring over `.&.`/`.|.`. To get a+-- 'Boolean' 'Ring', use @'Boolean' ('BitSet' a)@. -- -------------------------------------------------------------------------------  module Data.Ring.Semi.BitSet     ( module Data.Monoid.Reducer-    , module Data.Ring.Semi+    , module Data.Ring     -- * BitSet     , BitSet     -- * Manipulation@@ -43,15 +44,14 @@     ) where  import Prelude hiding ( null, exponent, toInteger, foldl, foldr, foldl1, foldr1 )-import Data.Bits hiding ( complement )-import qualified Data.Bits as Bits+import Data.Bits import Data.Foldable hiding ( toList ) import Data.Data import Data.Ring.Semi.Natural-import Data.Ring.Semi+import Data.Ring import Data.Monoid.Reducer import Data.Generator-import Data.Ring.Algebra+import Data.Ring.Module import Text.Read import Text.Show @@ -128,23 +128,18 @@  -- | /O(d)/ A 'BitSet' containing every member of the enumeration of @a@. full :: (Enum a, Bounded a) => BitSet a-full = complement empty +full = complement' empty  {-# INLINE full #-} --- | /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 _ 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 f) = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u f+recomplement (BS a b c l h m u f) = BS (complement b) (complement a) (complement c) l h (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 _ f) u = BS (Bits.complement b) (Bits.complement a) (Bits.complement c) l h (Bits.complement m) u f+pseudoComplement (BS a b c l h m _ f) u = BS (complement b) (complement a) (complement c) l h (complement m) u f {-# INLINE pseudoComplement #-}  -- | /O(d * n)/ Make a 'BitSet' from a list of items.@@ -184,7 +179,7 @@ -- | /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 _) -    | m < 0, e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .&. Bits.complement 1) u+    | m < 0, e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .&. complement 1) u     | m < 0, e > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u     | b == 0       = r     | a == -1      = pseudoComplement (singleton x) u@@ -269,7 +264,7 @@     | 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)+        m'' = m .&. shift (complement m') (l' - l) {-# INLINE diff #-}  -- | /O(d)/ Remove all elements present in the second bitset from the first@@ -317,7 +312,7 @@ -- | /O(d)/ recount :: Integer -> Int recount !n -    | n < 0     = Bits.complement (recount (Bits.complement n))+    | n < 0     = complement (recount (complement n))     | otherwise = recount' 0 0      where         h = hwm n@@ -404,20 +399,62 @@ instance (Bounded a, Enum a) => SemiRing (BitSet a)  -- idempotent monoid+instance Enum a => Module Natural (BitSet a) 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 Enum a => Bimodule Natural (BitSet a)+instance (Bounded a, Enum a) => Algebra Natural (BitSet a) +instance (Bounded a, Enum a) => Module (BitSet a) (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) => RAlgebra Natural (BitSet a)+instance (Bounded a, Enum a) => Bimodule (BitSet a) (BitSet a)+instance (Bounded a, Enum a) => Algebra (BitSet a) (BitSet a)      instance Generator (BitSet a) where     type Elem (BitSet a) = a     mapReduce f = mapReduce f . toList++instance (Show a, Bounded a, Enum a) => Num (BitSet a) where+    (+) = union+    (-) = difference+    (*) = intersection+    fromInteger m = r where+        r = BS c c c 0 (hwm m) m u toEnum where+        c = recount m+        u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))+    abs b | mantissa b < 0 = recomplement b+          | otherwise = b+    signum = error "BitSet.signum undefined"++instance (Show a, Bounded a, Enum a) => Bits (BitSet a) where+    (.&.) = intersection+    (.|.) = union+    a `xor` b = (a .|. b) .&. complement (a .&. b)++    -- | /O(d)/ Complements a 'BitSet' with respect to the bounds of @a@. Preserves order of 'null' and 'size'+    complement r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where+        u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))+    {-# INLINE complement #-}+    {-+    shift (BS a b c l h m _ f) n = BS a b c ((l + r) `max` uh) ((h + r) `max` uh) m (ul,uh) toEnum) where+        ul = fromEnum (minBound `asArgTypeOf` r)+        uh = fromEnum (maxBound `asArgTypeOf` r)+    -}+    shift = error "BitSet.shift undefined"+    rotate = error "BitSet.rotate undefined"+    bit = singleton . toEnum+    setBit s b = s `union` singleton (toEnum b)+    clearBit s b = s `difference` singleton (toEnum b)+    complementBit s b = s `xor` singleton (toEnum b)+    testBit s b = member (toEnum b) s +    bitSize r = fromEnum (maxBound `asArgTypeOf` r) - fromEnum (minBound `asArgTypeOf` r)+    isSigned _ = True++complement' :: (Bounded a, Enum a) => BitSet a -> BitSet a+complement' r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where+    u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))

@@ -1,10 +1,10 @@ module Data.Ring.Semi.Kleene -    ( module Data.Ring.Semi+    ( module Data.Ring     , KleeneAlgebra     , star     ) where -import Data.Ring.Semi+import Data.Ring  class SemiRing r => KleeneAlgebra r where     star :: r -> r

@@ -15,16 +15,17 @@ -----------------------------------------------------------------------------  module Data.Ring.Semi.Natural-    ( module Data.Ring.Semi+    ( module Data.Ring     , Natural-    , natural+    , toNatural+    , fromNatural     ) where  import Prelude hiding (id,(.)) import Numeric (readDec, showInt) import Control.Applicative import Control.Monad-import Data.Ring.Semi+import Data.Ring import qualified Data.Monoid.Combinators as Monoid -- import Data.Word import Data.Monoid.Monad@@ -32,16 +33,26 @@ import Data.Monoid.Multiplicative import Data.Monoid.Categorical import Data.Monoid.Self-import Data.Monoid.FromString import Data.Monoid.Lexical.SourcePosition import Data.Monoid.Lexical.UTF8.Decoder import Data.Generator.Free++#ifdef M_CONTAINERS+-- used with Seq import Data.Generator.Compressive.RLE import Data.Sequence (Seq)+#endif -natural :: Integer -> Natural-natural = fromInteger+#ifdef X_OverloadedStrings+import Data.Monoid.FromString+#endif +toNatural :: Integer -> Natural+toNatural = fromInteger++fromNatural :: Ringoid r => Natural -> r+fromNatural = Monoid.replicate one . getNatural+ newtype Natural = Natural { getNatural :: Integer }      deriving (Eq,Ord) @@ -172,11 +183,6 @@ instance Monoid m => RightModule Natural (Dual m) where (.*) = Monoid.replicate instance Monoid m => Module Natural (Dual m) --- FromString-instance Monoid m => LeftModule  Natural (FromString m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (FromString m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (FromString m)- -- Self instance Monoid m => LeftModule  Natural (Self m) where (*.) = flip Monoid.replicate instance Monoid m => RightModule Natural (Self m) where (.*) = Monoid.replicate@@ -187,11 +193,6 @@ instance RightModule Natural (Free a) where (.*) = Monoid.replicate instance Module Natural (Free a) --- RLE Seq-instance Eq a => LeftModule  Natural (RLE Seq a) where (*.) = flip Monoid.replicate-instance Eq a => RightModule Natural (RLE Seq a) where (.*) = Monoid.replicate-instance Eq a => Module Natural (RLE Seq a)- -- Categorical instance Category k => LeftModule Natural  (GEndo k a) where (*.) = flip Monoid.replicate instance Category k => RightModule Natural (GEndo k a) where (.*) = Monoid.replicate@@ -246,6 +247,19 @@ instance Multiplicative m => RightModule Natural (Log m) where (.*) = Monoid.replicate instance Multiplicative m => Module Natural (Log m)  +#ifdef M_CONTAINERS+-- RLE Seq+instance Eq a => LeftModule  Natural (RLE Seq a) where (*.) = flip Monoid.replicate+instance Eq a => RightModule Natural (RLE Seq a) where (.*) = Monoid.replicate+instance Eq a => Module Natural (RLE Seq a)+#endif++#ifdef X_OverloadedStrings+-- FromString+instance Monoid m => LeftModule  Natural (FromString m) where (*.) = flip Monoid.replicate+instance Monoid m => RightModule Natural (FromString m) where (.*) = Monoid.replicate+instance Monoid m => Module Natural (FromString m)+#endif  -- TODO --

@@ -1,93 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Ring.Semi.Near--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable (instances use MPTCs)------ Defines left- and right- seminearrings. Every 'MonadPlus' wrapped around--- a 'Monoid' qualifies due to the distributivity of (>>=) over 'mplus'.------ See <http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WordNumbers1/>-----------------------------------------------------------------------------------module Data.Ring.Semi.Near-    ( module Data.Monoid.Multiplicative-    , Ringoid-    , LeftSemiNearRing-    , RightSemiNearRing-    ) where--import Control.Monad.Reader--import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS--import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState--import qualified Control.Monad.Writer.Lazy as LWriter-import qualified Control.Monad.Writer.Strict as SWriter--import Data.Monoid.Multiplicative-import Data.FingerTree-import Data.Monoid.FromString-import Data.Monoid.Self-import Data.Generator--import qualified Data.Sequence as Seq-import Data.Sequence (Seq)--import Text.Parsec.Prim---- | @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)---- | @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 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)-instance (Measured v m, Monoid m) => RightSemiNearRing (FingerTree v m)-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)-

@@ -1,20 +1,16 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} module Data.Ring.Semi.Near.Trie -    ( module Data.Ring.Semi.Near+    ( module Data.Ring     , 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 Data.Ring import Prelude hiding (null)  singleton :: (Ord c, c `Reducer` m) => c -> Trie c m 

@@ -12,20 +12,33 @@ ------------------------------------------------------------------------  module Data.Ring.Semi.Ord-    ( module Data.Ring.Semi+    ( module Data.Ring     , Order(Order,getOrder)     , Priority(MinBound,Priority,MaxBound)     ) where -import Test.QuickCheck -- import Control.Applicative import Control.Functor.Pointed-import Data.Ring.Semi+import Data.Ring import Data.Monoid.Ord import Data.Monoid.Reducer +#ifdef M_QUICKCHECK+import Test.QuickCheck+#endif+ -- | A 'SemiRing' using a type's built-in Bounded instance.-newtype Order a = Order { getOrder :: a } deriving (Eq,Ord,Read,Show,Bounded,Arbitrary,CoArbitrary)+newtype Order a = Order { getOrder :: a } deriving +    ( Eq+    , Ord+    , Read+    , Show+    , Bounded+#ifdef M_QUICKCHECK+    , Arbitrary+    , CoArbitrary+#endif+    )  instance (Bounded a, Ord a) => Monoid (Order a) where     mappend = max@@ -78,6 +91,7 @@   _          `max` MaxBound   = MaxBound   MaxBound   `max` _          = MaxBound +#ifdef M_QUICKCHECK instance Arbitrary a => Arbitrary (Priority a) where   arbitrary = frequency [ (1 ,return MinBound)                         , (10, fmap Priority arbitrary)@@ -90,6 +104,7 @@   coarbitrary MinBound     = variant (0 :: Int)   coarbitrary (Priority a) = variant (1 :: Int) . coarbitrary a   coarbitrary MaxBound     = variant (2 :: Int)+#endif  instance Ord a => Monoid (Priority a) where     mappend = max

@@ -12,18 +12,24 @@  module Data.Ring.Semi.Tropical     ( module Data.Monoid.Reducer-    , module Data.Ring.Semi+    , module Data.Ring     -- * Tropical Semirings     , infinity     , Tropical(Tropical,getTropical)     ) where -import Test.QuickCheck import Control.Functor.Pointed-import Data.Monoid.Reducer (Reducer, unit, Monoid, mappend, mempty)-import Data.Ring.Semi+import Data.Monoid.Reducer+import Data.Monoid.Combinators as Monoid+import Data.Ring.Semi.Natural+import Data.Ring+import Data.Ring.Module import Data.Monoid.Ord hiding (infinity) +#ifdef M_QUICKCHECK+import Test.QuickCheck+#endif+ infinity :: Tropical a infinity = Tropical Nothing @@ -34,12 +40,19 @@ -- --   <http://hal.archives-ouvertes.fr/docs/00/11/37/79/PDF/Tropical.pdf> -newtype Tropical a = Tropical { getTropical :: Maybe a } -    deriving (Eq,Show,Read,Arbitrary,CoArbitrary)+newtype Tropical a = Tropical { getTropical :: Maybe a } deriving +    ( Eq+    , Show+    , Read+#ifdef M_QUICKCHECK+    , Arbitrary+    , CoArbitrary+#endif+    )  instance Ord a => Ord (Tropical a) where     Tropical Nothing  `compare` Tropical Nothing  = EQ-    Tropical Nothing  `compare` _                    = GT+    Tropical Nothing  `compare` _                 = GT     _                 `compare` Tropical Nothing  = LT     Tropical (Just a) `compare` Tropical (Just b) = a `compare` b @@ -72,3 +85,13 @@ instance (Ord a, Num a) => LeftSemiNearRing (Tropical a) instance (Ord a, Num a) => RightSemiNearRing (Tropical a) instance (Ord a, Num a) => SemiRing (Tropical a)++instance (Ord a, Num a) => Module (Tropical a) (Tropical a)+instance (Ord a, Num a) => LeftModule (Tropical a) (Tropical a) where (*.) = times+instance (Ord a, Num a) => RightModule (Tropical a) (Tropical a) where (.*) = times+instance (Ord a, Num a) => Bimodule (Tropical a) (Tropical a)++instance (Ord a, Num a) => Module Natural (Tropical a)+instance (Ord a, Num a) => LeftModule Natural (Tropical a) where (*.) = flip Monoid.replicate+instance (Ord a, Num a) => RightModule Natural (Tropical a) where (.*) = Monoid.replicate+instance (Ord a, Num a) => Bimodule Natural (Tropical a)

@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Ring.Sugar--- Copyright   :  (c) Edward Kmett 2009--- License     :  BSD-style--- Maintainer  :  ekmett@gmail.com--- Stability   :  experimental--- Portability :  portable------ Syntactic sugar for working with rings that conflicts with names from the "Prelude".------ > import Prelude hiding ((-), (+), (*), negate, subtract)--- > import Data.Ring.Sugar-----------------------------------------------------------------------------------module Data.Ring.Sugar -    ( module Data.Monoid.Multiplicative.Sugar-    , module Data.Ring.Semi.Near-    ) where--import Data.Monoid.Multiplicative.Sugar-import Data.Ring.Semi.Near

@@ -1,1258 +0,0 @@-{-# 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-

@@ -1,5 +1,5 @@ name:		    monoids-version:	    0.1.33+version:	    0.1.36 license:	    BSD3 license-file:   LICENSE author:		    Edward A. Kmett@@ -11,72 +11,137 @@ description:    Monoids, specialized containers and a general map/reduce framework copyright:      (c) 2009 Edward A. Kmett build-type:     Simple-cabal-version:  >=1.2+cabal-version:  >=1.2.3 +-- packages we can extend with new instances+flag bytestring+  description: Data.ByteString is available (bytestring)++flag fingertree+  description: Data.Fingertree is available (fingertree)++flag parallel+  description: Control.Parallel.Strategies is available (parallel)+  +flag stm+  description: Control.Concurrent.STM is available (stm)++flag QuickCheck+  description: Test.QuickCheck is available (QuickCheck)+ +flag text+  description: Data.Text is available (text)++flag reflection+  description: Data.Reflection is available (reflection)++flag parsec+  description: Text.Parsec is available (parsec >= 3)++flag mtl+  description: Control.Monad.* is available (mtl)++-- optional extensions+flag overloaded-strings+  description: OverloadedStrings extension is available (extension)++-- compilation options+flag optimize+  description: Enable optimizations +  default: False+ library   build-depends: -    base >= 4 && < 4.2,-    containers >= 0.2 && < 0.3, -    text >= 0.1 && < 0.2, -    parsec >= 3.0 && < 3.1,-    fingertree >= 0.0 && < 0.1, -    bytestring >= 0.9 && < 1.0, -    category-extras >= 0.53 && < 0.60, -    parallel >= 1.1 && < 1.2, -    mtl >= 1.0 && < 1.2, -    stm >= 2.1 && < 2.2, -    bitset >= 1.0 && < 1.1, -    QuickCheck >= 2.1 && < 2.2, +    base >= 4 && < 4.2, +    category-extras >= 0.53 && < 0.60,     array >= 0.2 && < 0.3,-    reflection >= 0.1 && < 0.2+    containers >= 0.2 && < 0.3++  extensions:+    CPP+   exposed-modules:-    Data.Field-    Data.Field.VectorSpace+    Data.Generator+    Data.Generator.Combinators+    Data.Generator.Compressive.LZ78+    Data.Generator.Compressive.RLE+    Data.Generator.Free     Data.Group     Data.Group.Combinators-    Data.Group.Multiplicative-    Data.Group.Multiplicative.Sugar     Data.Group.Sugar     Data.Monoid.Additive-    Data.Monoid.Additive.Sugar     Data.Monoid.Applicative     Data.Monoid.Categorical     Data.Monoid.Combinators-    Data.Monoid.FromString-    Data.Generator-    Data.Generator.Combinators-    Data.Generator.Compressive.LZ78-    Data.Generator.Compressive.RLE-    Data.Generator.Free     Data.Monoid.Instances     Data.Monoid.Lexical.SourcePosition     Data.Monoid.Lexical.UTF8.Decoder     Data.Monoid.Lexical.Words     Data.Monoid.Monad     Data.Monoid.Multiplicative-    Data.Monoid.Multiplicative.Sugar     Data.Monoid.Ord     Data.Monoid.Reducer     Data.Monoid.Reducer.Char     Data.Monoid.Reducer.With     Data.Monoid.Self+    Data.Monoid.Sugar     Data.Monoid.Union     Data.Ring-    Data.Ring.Algebra     Data.Ring.Boolean     Data.Ring.FromNum-    Data.Ring.ModularArithmetic     Data.Ring.Module     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 +  if flag (bytestring)+    build-depends: bytestring >= 0.9 && < 1.0 +    cpp-options: -DM_BYTESTRING=1++  if flag (fingertree)+    build-depends: fingertree >= 0.0 && < 0.1+    cpp-options: -DM_FINGERTREE=1++  if flag (parallel)+    build-depends: parallel >= 1.1 && < 1.2+    cpp-options: -DM_PARALLEL=1++  if flag (text)+    build-depends: text >= 0.1 && < 0.2+    cpp-options: -DM_TEXT=1++  if flag (stm)+    build-depends: stm >= 2.1 && < 2.2+    cpp-options: -DM_STM=1++  if flag (QuickCheck)+    build-depends: QuickCheck >= 2.1 && < 2.2+    cpp-options: -DM_QUICKCHECK=1++  if flag (reflection)+    build-depends: reflection >= 0.1 && < 0.2+    cpp-options: -DM_REFLECTION=1+    exposed-modules: Data.Ring.ModularArithmetic++  if flag (parsec)+    build-depends: parsec >= 3.0 && < 3.1+    cpp-options: -DM_PARSEC=3++  if flag (overloaded-strings)+    extensions: OverloadedStrings+    cpp-options: -DX_OverloadedStrings=1+    exposed-modules: Data.Monoid.FromString++  if flag (mtl) +    build-depends: mtl >= 1.0 && < 1.2 +    cpp-options: -DM_MTL=1+       ghc-options: -Wall -fno-warn-duplicate-exports+  cpp-options -DM_ARRAY=1 -DM_CONTAINERS=1++  if flag (optimize)+    ghc-options: -funbox-strict-fields -O2 -fdicts-cheap