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