diff --git a/TrieMap.cabal b/TrieMap.cabal
--- a/TrieMap.cabal
+++ b/TrieMap.cabal
@@ -1,5 +1,5 @@
 name:		TrieMap
-version:	0.0.1.1
+version:	0.0.1.2
 license:	BSD3
 license-file:	LICENSE
 maintainer:	wasserman.louis@gmail.com
@@ -21,7 +21,7 @@
  
 build-type:	Simple
 build-depends:
-	base >= 4 && <= 5, containers == 0.2.0.1
+	base >= 4 && <= 5, containers == 0.2.0.1, bytestring
 exposed-modules:
 	TrieMap
 	TrieMap.Algebraic
diff --git a/TrieMap.hs b/TrieMap.hs
--- a/TrieMap.hs
+++ b/TrieMap.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+{-# LANGUAGE TypeOperators, UndecidableInstances, FlexibleContexts, TypeFamilies #-}
 
 -- | We will use the following terminology:
 -- 
 -- An /algebraic/ type is a type isomorphic to an algebraic type, as defined in the package description.  This isomorphism is
--- declared via the type class 'Algebraic', where @'Alg' k@ is algebraic.  It is assumed for purposes of ordering that
--- this isomorphism is order- and equality-preserving.  We also require that if @k@ is algebraic, @'Alg' k ~ k@.
+-- declared via the type class 'Algebraic', where @'AlgRep' k@ is algebraic.  It is assumed for purposes of ordering that
+-- this isomorphism is order- and equality-preserving.  We also require that if @k@ is algebraic, @'AlgRep' k ~ k@.
 --
 -- These methods will automatically infer the correct type of a 'TrieMap' on any given argument.  For example,
 -- 
@@ -12,23 +12,23 @@
 -- 
 --  returns a variable of type
 -- 
--- @'TrieMap' ('String', 'Double', 'Bool') ('RadixTrie' 'Int' 'Data.IntMap.IntMap' \``ProdMap`\` 'UnionMap' 'Maybe' ('Data.Map.Map' 'Double') \``ProdMap`\` 'UnionMap' 'Maybe' 'Maybe') 'String'@
+-- @'TrieMap' ('String', 'Double', 'Bool') ('ProdMap' ('ConstMap' ('RadixTrie' 'Int' 'IntMap')) ('ProdMap' ('ConstMap' ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' ('Ordered' 'Double') ('Map' 'Double'))) 'IdMap') (('Const' () :+: 'Id') '()') ('UnionMap' ('ConstMap' 'Maybe') 'IdMap' () 'Maybe')) 'String'@
 -- 
 -- The inference was done entirely automatically.  Note also:
 -- 
--- 	* @'Alg' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.
+-- 	* @'AlgRep' 'Char' ~ 'Int'@: the 'Algebraic' instance for 'Char' maps characters to their ASCII representations, so an 'IntMap' can be used.
 -- 
--- 	* @'Alg' ('Maybe' a) ~ 'Either' () ('Alg' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.
+-- 	* @'AlgRep' ('Maybe' a) ~ 'Either' () ('AlgRep' a)@; a 'TrieMap' on a 'Maybe' key type simply gets a space for one extra (possible) value.
 -- 
--- 	* @'Alg' 'Double' ~ 'Ordered' 'Double'@; the 'Algebraic' instance for 'Double' tells "TrieMap" to just use a regular 'Data.Map.Map'
+-- 	* @'AlgRep' 'Double' ~ 'Ordered' 'Double'@; the 'Algebraic' instance for 'Double' tells "TrieMap" to just use a regular 'Data.Map.Map'
 -- 		and the default ordering for 'Double's.
 -- 
--- 	* @'Alg' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.
+-- 	* @'AlgRep' 'Bool' ~ 'Either' () ()@, so a 'TrieMap' on a 'Bool' takes the form of -- essentially -- a pair of 'Maybe's.
 -- 	
--- 	* @'Alg' (a, b, c) ~ ('Alg' a, ('Alg' b, 'Alg' c))@, so tuple types get handled by a sequence of map products.
+-- 	* @'AlgRep' (a, b, c) ~ ('AlgRep' a, ('AlgRep' b, 'AlgRep' c))@, so tuple types get handled by a sequence of map products.
 -- 
 -- (If you plan to use these maps in type arguments, it is strongly suggested that you either reproduce the context 
--- @('Algebraic' k, 'TrieKey' ('Alg' k) m) => TrieMap k m a@, or you create a type alias!)
+-- @('Algebraic' k, 'TrieKey' ('AlgRep' k) m) => TrieMap k m a@, or you create a type alias!)
 --
 
 -- The following is a general attempt to describe the runtime of operations supported by 'TrieMap's.
@@ -46,10 +46,13 @@
 module TrieMap (
 	-- * Map type
 	TrieMap,
-	TrieKey,
 	Algebraic (..), 
+	AlgebraicT (..),
+	TrieKey,
+	TrieKeyT,
+	EqT,
 	-- * Map instances
-	ProdMap, UnionMap, RadixTrie,
+	ProdMap,  (:*:)(..), CProdMap, UnionMap, (:+:)(..), CUnionMap, RadixTrie, ConstMap, Const(..), IdMap, Id(..), CompMap, O, o, unO, FixMap, Fix(..), 
 	-- * Operators
 	(!), 
 	(\\),
@@ -101,8 +104,7 @@
 	-- ** Map
 	map,
 	mapWithKey,
-	mapApp,
-	mapAppWithKey,
+	traverseWithKey,
 	mapMaybe,
 	mapMaybeWithKey,
 	mapEither,
@@ -153,6 +155,7 @@
 	maxView,
 	minViewWithKey,
 	maxViewWithKey) where
+-- module TrieMap where
 
 import Control.Monad
 import Data.Monoid
@@ -163,7 +166,7 @@
 import TrieMap.TrieAlgebraic
 import TrieMap.RadixTrie
 import TrieMap.Reflection
-import Control.Applicative hiding (Alternative(..))
+import Control.Applicative hiding (Alternative(..), Const)
 import Data.Maybe hiding (mapMaybe)
 import Data.Map (Map)
 import Data.IntMap (IntMap)
@@ -178,63 +181,83 @@
 -- | A 'TrieMap' is a size-tracking wrapper around a generalized trie map.
 data TrieMap k m a = TrieMap {sizeMap :: Int, trieMap :: m (Elem a)}
 
-instance (Eq k, Eq a, Algebraic k, TrieKey (Alg k) m) => Eq (TrieMap k m a) where
+instance (Eq k, Eq a, Algebraic k, TrieKey (AlgRep k) m) => Eq (TrieMap k m a) where
 	(==) = (==) `on` assocs
 
-instance (Ord k, Ord a, Algebraic k, TrieKey (Alg k) m) => Ord (TrieMap k m a) where
+instance (Ord k, Ord a, Algebraic k, TrieKey (AlgRep k) m) => Ord (TrieMap k m a) where
 	compare = compare `on` assocs
 
-instance (Show k, Show a, Algebraic k, TrieKey (Alg k) m) => Show (TrieMap k m a) where
+instance (Show k, Show a, Algebraic k, TrieKey (AlgRep k) m) => Show (TrieMap k m a) where
 	show m = "fromList " ++ show (assocs m)
 
-instance (Algebraic k, Algebraic a, TrieKey (Alg k) m) => Algebraic (TrieMap k m a) where
-	type Alg (TrieMap k m a) = ([(Alg k, Alg a)], Int)
-	toAlg (TrieMap n m) = (build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m), n)
-	fromAlg (xs, n) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]
+-- instance (Algebraic k, Algebraic a, TrieKey (AlgRep k) m) => Algebraic (TrieMap k m a) where
+-- 	type AlgRep (TrieMap k m a) =  ([(AlgRep k, AlgRep a)], Int)
+-- 	toAlg (TrieMap n m) = (build (\ c n -> foldWithKeyAlg (\ k a -> c (k, toAlg a)) n m), n)
+-- 	fromAlg (xs, n) = TrieMap n $ fromDistAscListAlg [(k, fromAlg a) | (k, a) <- xs]
 
-instance Functor m => Functor (TrieMap k m) where
-	fmap f (TrieMap n m) = TrieMap n (fmap (fmap f) m)
+instance SAlgebraicT m => AlgebraicT (TrieMap k m) where
+	type AlgRepT (TrieMap k m) = SAlgRepT m :*: Const Int
+	toAlgT (TrieMap n m) = fmap getElem (toSAlgT m) :*: Const n
+	fromAlgT (m :*: Const n) = TrieMap n (fromSAlgT (fmap Elem m))
 
-instance Foldable m => Foldable (TrieMap k m) where
-	foldr f z = foldr (\ (Elem x) z -> f x z) z . trieMap
-	foldl f z = foldl (\ z (Elem x) -> f z x) z . trieMap
-	foldMap f = foldMap (f . getElem) . trieMap
+instance Algebraic (m (Elem a)) => Algebraic (TrieMap k m a) where
+	type AlgRep (TrieMap k m a) = AlgRep (m (Elem a), Int)
+	toAlg (TrieMap n m) = toAlg (m, n)
+	fromAlg = uncurry (flip TrieMap) . fromAlg
+{-
+instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m) => AlgebraicT (TrieMap k m) where
+	type AlgRepT (TrieMap k m) = AlgRepT ([] `O` ((,) (AlgRep k)))
+	toAlgT (TrieMap _ m) = toAlgT (o (fmap (fmap getElem) (assocsAlg m)))
+	fromAlgT = mkTrieMap . fromDistAscListAlg . fmap (fmap Elem) . unO . fromAlgT
 
-instance Traversable m => Traversable (TrieMap k m) where
-	traverse f (TrieMap n m) = TrieMap n <$> traverse (traverse f) m
+instance (Algebraic (AlgRep k), Algebraic k, TrieKey (AlgRep k) m, Algebraic a) => Algebraic (TrieMap k m a) where
+	type AlgRep (TrieMap k m a) = AlgRep (AlgWrap (TrieMap k m) a)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg-}
 
-instance (Algebraic k, TrieKey (Alg k) m) => Monoid (TrieMap k m a) where
+
+instance TrieKey k' m => Functor (TrieMap k m) where
+	fmap = fmapDefault
+
+instance TrieKey k' m => Foldable (TrieMap k m) where
+	foldr f z = foldWithKeyAlg (\ _ (Elem x) z -> f x z) z . trieMap
+
+instance TrieKey k' m => Traversable (TrieMap k m) where
+	traverse f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ _ (Elem v) -> Elem <$> f v) m
+
+instance (Algebraic k, TrieKey (AlgRep k) m) => Monoid (TrieMap k m a) where
 	mempty = empty
 	mappend = union
+	mconcat = unions
 
-mkTrieMap :: (Algebraic k, TrieKey (Alg k) m) => m (Elem a) -> TrieMap k m a
+mkTrieMap :: (Algebraic k, TrieKey (AlgRep k) m) => m (Elem a) -> TrieMap k m a
 mkTrieMap m = TrieMap (sizeAlg m) m
 
 -- | Lookup the value of a key in the map.
 --
 -- The function will return the corresponding value as @('Just' value)@,
 -- or 'Nothing' if the key isn't in the map.
-lookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Maybe a
+lookup :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Maybe a
 lookup k = fmap getElem . lookupAlg (toAlg k) . trieMap
 
 -- | Is the key a member of the map? See also 'notMember'.
 --
 -- > member 5 (fromList [(5,'a'), (3,'b')]) == True
 -- > member 1 (fromList [(5,'a'), (3,'b')]) == False
-member :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Bool
+member :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
 member = isJust .: lookup
 
 -- | Is the key not a member of the map? See also 'member'.
 --
 -- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False
 -- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True
-notMember :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> Bool
+notMember :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> Bool
 notMember = not .: member
 
 -- | Find the value at a key.
 -- Calls 'error' when the element can not be found.
 
-find :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> a
+find :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> a
 find = findWithDefault $ error "TrieMap.find: element not in the map"
 
 -- | The expression @('findWithDefault' def k map)@ returns
@@ -243,13 +266,13 @@
 --
 -- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'
 -- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'
-findWithDefault :: (Algebraic k, TrieKey (Alg k) m) => a -> k -> TrieMap k m a -> a
+findWithDefault :: (Algebraic k, TrieKey (AlgRep k) m) => a -> k -> TrieMap k m a -> a
 findWithDefault v = fromMaybe v .: lookup
 
 -- | /O(1)/. A map with a single element.
 --
 -- > singleton 1 'a'        == fromList [(1, 'a')]
-singleton :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a
+singleton :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a
 singleton k v = TrieMap 1 (insertAlg (toAlg k) (Elem v) emptyAlg)
 
 -- | Find the value at a key.
@@ -257,18 +280,18 @@
 --
 -- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map
 -- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'
-(!) :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> k -> a
+(!) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> k -> a
 m ! k = fromMaybe (error "element not in the map") (lookup k m)
 
-empty :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a
+empty :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a
 empty = TrieMap 0 emptyAlg
 
 -- | Check if the specified map is empty.
-null :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Bool
+null :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Bool
 null = nullAlg . trieMap
 
 -- | Returns the size of the specified map.
-size :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Int
+size :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Int
 size = sizeMap
 
 -- | Build a map from a list of key\/value pairs. See also 'fromAscList'.
@@ -278,14 +301,14 @@
 -- > fromList [] == empty
 -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]
 -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]
-fromList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
+fromList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
 fromList = fromListWith const
 
 -- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
 --
 -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]
 -- > fromListWith (++) [] == empty
-fromListWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
 fromListWith = fromListWithKey . const
 
 -- | Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
@@ -293,7 +316,7 @@
 -- > let f k a1 a2 = (show k) ++ a1 ++ a2
 -- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]
 -- > fromListWithKey f [] == empty
-fromListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromListWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
 fromListWithKey f xs = mkTrieMap $ fromListAlg (\ k (Elem v1) (Elem v2) -> Elem (f (fromAlg k) v1 v2)) [(toAlg k, Elem v) | (k, v) <- xs]
 
 -- | /O(n)/. Build a map from an ascending list in linear time.
@@ -301,14 +324,14 @@
 --
 -- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]
 -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]
-fromAscList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
+fromAscList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
 fromAscList = fromAscListWith const
 
 -- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
 -- /The precondition (input list is ascending) is not checked./
 --
 -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]
-fromAscListWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromAscListWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [(k, a)] -> TrieMap k m a
 fromAscListWith = fromAscListWithKey . const
 
 -- | /O(n)/. Build a map from an ascending list in linear time with a
@@ -317,7 +340,7 @@
 --
 -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2
 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]
-fromAscListWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
+fromAscListWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [(k, a)] -> TrieMap k m a
 fromAscListWithKey f xs = mkTrieMap $ fromAscListAlg g [(toAlg k, Elem v) | (k, v) <- xs] where
 	g k (Elem v1) (Elem v2) = Elem (f (fromAlg k) v1 v2)
 
@@ -325,7 +348,7 @@
 -- /The precondition is not checked./
 --
 -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]
-fromDistinctAscList :: (Algebraic k, TrieKey (Alg k) m) => [(k, a)] -> TrieMap k m a
+fromDistinctAscList :: (Algebraic k, TrieKey (AlgRep k) m) => [(k, a)] -> TrieMap k m a
 fromDistinctAscList xs = TrieMap (length xs) $ fromDistAscListAlg [(toAlg k, Elem v) | (k, v) <- xs]
 
 -- | Insert a new key and value in the map.
@@ -336,7 +359,7 @@
 -- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]
 -- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]
 -- > insert 5 'x' empty                         == singleton 5 'x'
-insert :: (Algebraic k, TrieKey (Alg k) m) => k -> a -> TrieMap k m a -> TrieMap k m a
+insert :: (Algebraic k, TrieKey (AlgRep k) m) => k -> a -> TrieMap k m a -> TrieMap k m a
 insert = insertWith const
 
 -- | Insert with a function, combining new value and old value.
@@ -348,7 +371,7 @@
 -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]
 -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
 -- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"
-insertWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
+insertWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
 insertWith = insertWithKey . const
 
 -- | Insert with a function, combining key, new value and old value.
@@ -362,14 +385,14 @@
 -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]
 -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]
 -- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"
-insertWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
+insertWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> TrieMap k m a
 insertWithKey f k = snd .: insertLookupWithKey f k
 
 -- | Combines insert operation with old value retrieval.
 -- The expression (@'insertLookupWithKey' f k x map@)
 -- is a pair where the first element is equal to (@'lookup' k map@)
 -- and the second element equal to (@'insertWithKey' f k x map@).
-insertLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> (Maybe a, TrieMap k m a)
+insertLookupWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> k -> a -> TrieMap k m a -> (Maybe a, TrieMap k m a)
 insertLookupWithKey f k v (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
 	(old, m')	-> (old, TrieMap (if isJust old then n else n + 1) m')
 	where	g v' = (fmap getElem v', Just $ Elem $ maybe v (f k v . getElem) v')
@@ -382,7 +405,7 @@
 -- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]
 -- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
 -- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-update :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+update :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
 update = updateWithKey . const
 
 -- | The expression (@'updateWithKey' f k map@) updates the
@@ -394,7 +417,7 @@
 -- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]
 -- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]
 -- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+updateWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
 updateWithKey f = snd .: updateLookupWithKey f
 
 -- | Lookup and update. See also 'updateWithKey'.
@@ -405,7 +428,7 @@
 -- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])
 -- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])
 -- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")
-updateLookupWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
+updateLookupWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
 updateLookupWithKey f k (TrieMap n m) = 
 	case alterLookupAlg g (toAlg k) m of
 		((del, res), m')	-> (res, TrieMap (if del then n - 1 else n) m')
@@ -419,7 +442,7 @@
 -- > delete 5 empty                         == empty
 -- 
 -- 'delete' is equivalent to @'alter' ('const' 'Nothing')@.
-delete :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> TrieMap k m a
+delete :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> TrieMap k m a
 delete = alter (const Nothing)
 
 -- | The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
@@ -433,14 +456,14 @@
 -- > let f _ = Just "c"
 -- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]
 -- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]
-alter :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
+alter :: (Algebraic k, TrieKey (AlgRep k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> TrieMap k m a
 alter f k = snd . alterLookup f k
 
 -- | The expression (@'alterLookup' f k map@) alters the value @x@ at @k@, or absence thereof, and returns the old value.
 -- 'alterLookup' can be used to insert, delete, or update a value in a 'Map'.
 -- 
 -- In short : @alterLookup f k m = (lookup k m, alter f k m)@.
-alterLookup :: (Algebraic k, TrieKey (Alg k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
+alterLookup :: (Algebraic k, TrieKey (AlgRep k) m) => (Maybe a -> Maybe a) -> k -> TrieMap k m a -> (Maybe a, TrieMap k m a)
 alterLookup f k (TrieMap n m) = case alterLookupAlg g (toAlg k) m of
 	((old, delta), m')	-> (old, TrieMap (n + delta) m')
 	where	g Nothing = let fv = f Nothing in ((Nothing, just1 fv), fmap Elem fv)
@@ -451,36 +474,32 @@
 --
 -- > let f key x = (show key) ++ ":" ++ x
 -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]
-mapWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b) -> TrieMap k m a -> TrieMap k m b
-mapWithKey f = unId . mapAppWithKey (Id .: f)
+mapWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b) -> TrieMap k m a -> TrieMap k m b
+mapWithKey f = unId . traverseWithKey (Id .: f)
 
 -- | /O(n)/. Map a function over all values in the map.
 --
 -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]
-map :: (Algebraic k, TrieKey (Alg k) m) => (a -> b) -> TrieMap k m a -> TrieMap k m b
-map = fmap
+map :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b) -> TrieMap k m a -> TrieMap k m b
+map = mapWithKey . const
 
 -- | Essentially equivalent to 'traverse' with a function that takes both the key and the value as arguments.
-mapAppWithKey :: (Algebraic k, TrieKey (Alg k) m, Applicative f) =>
+traverseWithKey :: (Algebraic k, TrieKey (AlgRep k) m, Applicative f) =>
 	(k -> a -> f b) -> TrieMap k m a -> f (TrieMap k m b)
-mapAppWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m
-
--- | Equivalent to 'traverse'.
-mapApp :: (Algebraic k, TrieKey (Alg k) m, Applicative f) => (a -> f b) -> TrieMap k m a -> f (TrieMap k m b)
-mapApp = traverse
+traverseWithKey f (TrieMap n m) = TrieMap n <$> mapAppAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) m
 
 -- | /O(n)/. Map keys\/values and collect the 'Just' results.
 --
 -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing
 -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"
-mapMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
+mapMaybeWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
 mapMaybeWithKey f = mkTrieMap . mapMaybeAlg (\ k (Elem v) -> Elem <$> f (fromAlg k) v) . trieMap
 
 -- | /O(n)/. Map values and collect the 'Just' results.
 --
 -- > let f x = if x == "a" then Just "new a" else Nothing
 -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"
-mapMaybe :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
+mapMaybe :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe b) -> TrieMap k m a -> TrieMap k m b
 mapMaybe = mapMaybeWithKey . const
 
 -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
@@ -491,7 +510,7 @@
 -- >
 -- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
 -- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
-mapEither :: (Algebraic k, TrieKey (Alg k) m) => (a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
+mapEither :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
 mapEither = mapEitherWithKey . const
 
 -- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
@@ -502,9 +521,11 @@
 -- >
 -- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])
 -- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])
-mapEitherWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
+mapEitherWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Either b c) -> TrieMap k m a -> (TrieMap k m b, TrieMap k m c)
 mapEitherWithKey f (TrieMap _ m) = (mkTrieMap mL, mkTrieMap mR)
-	where	(mL, mR) = mapEitherAlg (\ k (Elem v) -> either (Left . Elem) (Right . Elem) (f (fromAlg k) v)) m
+	where	(mL, mR) = mapEitherAlg (\ k (Elem v) -> 
+				either (\ k -> (Just (Elem k), Nothing)) (\ k -> (Nothing, Just (Elem k))) (f (fromAlg k) v))
+				m
 
 -- |
 -- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.
@@ -516,7 +537,7 @@
 -- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]
 -- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"
 -- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"
-mapKeys :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeys :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
 	(k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
 mapKeys = mapKeysWith const
 
@@ -529,7 +550,7 @@
 --
 -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"
 -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"
-mapKeysWith :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeysWith :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
 	(a -> a -> a) -> (k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
 mapKeysWith f g m = fromListWith f [(g k, v) | (k, v) <- assocs m]
 
@@ -550,14 +571,14 @@
 -- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]
 -- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True
 -- > valid (mapKeysMonotonic (\ _ -> 1)     (fromList [(5,"a"), (3,"b")])) == False
-mapKeysMonotonic :: (Algebraic k1, Algebraic k2, TrieKey (Alg k1) m1, TrieKey (Alg k2) m2) =>
+mapKeysMonotonic :: (Algebraic k1, Algebraic k2, TrieKey (AlgRep k1) m1, TrieKey (AlgRep k2) m2) =>
 	(k1 -> k2) -> TrieMap k1 m1 a -> TrieMap k2 m2 a
 mapKeysMonotonic f (TrieMap n m) = TrieMap n $ fromDistAscListAlg [(toAlg (f (fromAlg k)), v) | (k, v) <- assocsAlg m]
 
 -- | /O(n)/. Filter all keys\/values that satisfy the predicate.
 --
 -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-filterWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Bool) -> TrieMap k m a -> TrieMap k m a
+filterWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> TrieMap k m a
 filterWithKey p = mapMaybeWithKey (\ k v -> if p k v then Just v else Nothing)
 
 -- | /O(n)/. Filter all values that satisfy the predicate.
@@ -565,7 +586,7 @@
 -- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
 -- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty
 -- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty
-filter :: (Algebraic k, TrieKey (Alg k) m) => (a -> Bool) -> TrieMap k m a -> TrieMap k m a
+filter :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> TrieMap k m a
 filter = filterWithKey . const
 
 -- | /O(n)/. Partition the map according to a predicate. The first
@@ -575,7 +596,7 @@
 -- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
 -- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
 -- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partition :: (Algebraic k, TrieKey (Alg k) m) => (a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+partition :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
 partition = partitionWithKey . const
 
 -- | /O(n)/. Partition the map according to a predicate. The first
@@ -585,7 +606,7 @@
 -- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")
 -- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)
 -- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])
-partitionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+partitionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Bool) -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
 partitionWithKey p = mapEitherWithKey (\ k v -> (if p k v then Left else Right) v)
 
 {-# INLINE assocs #-}
@@ -593,14 +614,14 @@
 --
 -- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]
 -- > assocs empty == []
-assocs :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [(k, a)]
+assocs :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [(k, a)]
 assocs m = build (\ c n -> foldWithKey (curry c) n m)
 
 -- | /O(n)/. Return all keys of the map in ascending order.
 --
 -- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]
 -- > keys empty == []
-keys :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [k]
+keys :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [k]
 keys m = Prelude.map fst (assocs m)
 
 -- | /O(n)/.
@@ -608,7 +629,7 @@
 --
 -- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]
 -- > elems empty == []
-elems :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> [a]
+elems :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> [a]
 elems = toList
 
 -- | /O(n)/. Fold the values in the map, such that
@@ -630,11 +651,11 @@
 --
 -- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"
 -- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"
-foldWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b
+foldWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> b) -> b -> TrieMap k m a -> b
 foldWithKey f z = foldWithKeyAlg (\ k (Elem v) -> f (fromAlg k) v) z . trieMap
 
 -- | /O(n+m)/.  Union with a combining function that may discard some elements.
-unionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionMaybeWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 unionMaybeWithKey f = mkTrieMap .: unionMaybeAlg (\ k (Elem v1) (Elem v2) -> Elem <$> f (fromAlg k) v1 v2) `on` trieMap
 
 -- | /O(n+m)/.
@@ -642,17 +663,17 @@
 --
 -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value
 -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]
-unionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 unionWithKey f = unionMaybeWithKey (\ k x y -> Just (f k x y))
 
 -- | /O(n+m)/. Union with a combining function.
 --
 -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]
-unionWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 unionWith = unionWithKey . const
 
 -- | /O(n+m)/.  Union with a combining function that may discard some elements.
-unionMaybeWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+unionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 unionMaybeWith = unionMaybeWithKey . const
 
 -- | /O(n+m)/.
@@ -661,25 +682,25 @@
 -- i.e. (@'union' == 'unionWith' 'const'@).
 --
 -- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]
-union :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+union :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 union = unionWith const
 
-unions :: (Algebraic k, TrieKey (Alg k) m) => [TrieMap k m a] -> TrieMap k m a
+unions :: (Algebraic k, TrieKey (AlgRep k) m) => [TrieMap k m a] -> TrieMap k m a
 unions = unionsWith const
 
-unionsWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
+unionsWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
 unionsWith = unionsWithKey . const
 
-unionsWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
+unionsWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> a -> a) -> [TrieMap k m a] -> TrieMap k m a
 unionsWithKey f = mkTrieMap . foldl' (unionMaybeAlg (\ k (Elem x) (Elem y) -> Just $ Elem $ f (fromAlg k) x y)) emptyAlg 
 			. Prelude.map trieMap
 
 -- | O(n+m).  Symmetric difference.  Equivalent to @'unionMaybeWith' (\ _ _ -> Nothing)@.
-symDifference :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
+symDifference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a -> TrieMap k m a
 symDifference = unionMaybeWith (\ _ _ -> Nothing)
 
 -- | /O(n+m)/.  Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWithKey :: (Algebraic k, TrieKey (Alg k) m) => 
+intersectionMaybeWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => 
 	(k -> a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
 intersectionMaybeWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ 
 	intersectAlg (\ k (Elem a) (Elem b) -> Elem <$> f (fromAlg k) a b) m1 m2
@@ -688,17 +709,17 @@
 --
 -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar
 -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"
-intersectionWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
 intersectionWithKey f = intersectionMaybeWithKey (\ k x y -> Just (f k x y))
 
 -- | /O(n+m)/. Intersection with a combining function.
 --
 -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"
-intersectionWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
 intersectionWith f = intersectionMaybeWith (Just .: f)
 
 -- | /O(n+m)/.  Intersection of two maps with a combining function that may discard some elements.
-intersectionMaybeWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
+intersectionMaybeWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe c) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m c
 intersectionMaybeWith = intersectionMaybeWithKey . const
 
 -- | /O(n+m)/. Intersection of two maps.
@@ -706,7 +727,7 @@
 -- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).
 --
 -- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"
-intersection :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+intersection :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
 intersection = intersectionWith const
 
 -- | /O(n+m)/. Difference with a combining function. When two equal keys are
@@ -717,7 +738,7 @@
 -- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing
 -- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])
 -- >     == singleton 3 "3:b|B"
-differenceWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+differenceWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
 differenceWithKey f (TrieMap _ m1) (TrieMap _ m2) = mkTrieMap $ 
 	differenceAlg (\ k (Elem x) (Elem y) -> Elem <$> f (fromAlg k) x y) m1 m2
 
@@ -730,67 +751,67 @@
 -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing
 -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])
 -- >     == singleton 3 "b:B"
-differenceWith :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+differenceWith :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Maybe a) -> TrieMap k m a -> TrieMap k m b -> TrieMap k m a
 differenceWith = differenceWithKey . const
 
 -- | /O(n+m)/. Difference of two maps. 
 -- Return elements of the first map not existing in the second map.
 --
 -- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"
-difference :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+difference :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
 difference = differenceWith (\ _ _ -> Nothing)
 
 -- | Same as 'difference'.
-(\\) :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
+(\\) :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m b -> TrieMap k m a
 (\\) = difference
 
 -- | The minimal key of the map. Calls 'error' if the map is empty.
 --
 -- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")
 -- > findMin empty                            Error: empty map has no minimal element
-findMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> (k, a)
+findMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
 findMin = fromMaybe (error "empty map has no minimal element") . getMin
 
 -- | The minimal key of the map, if any. Returns 'Nothing' if the map is empty.
 --
 -- > getMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")
 -- > getMin empty                         == Nothing
-getMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (k, a)
+getMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
 getMin = fst <.> minViewWithKey
 
 -- | The maximal key of the map. Calls 'error' is the map is empty.
 --
 -- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")
 -- > findMax empty                            Error: empty map has no maximal element
-findMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> (k, a)
+findMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> (k, a)
 findMax = fromMaybe (error "empty map has no maximal element") . getMax
 
 -- | The maximal key of the map, if any. Returns 'Nothing' if the map is empty.
 --
 -- > getMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")
 -- > getMax empty                         == Nothing
-getMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (k, a)
+getMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (k, a)
 getMax = fst <.> maxViewWithKey
 
 -- | Delete the minimal key. Returns an empty map if the map is empty.
 --
 -- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]
 -- > deleteMin empty == empty
-deleteMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a
+deleteMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
 deleteMin m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMinAlg m
 
 -- | Delete the maximal key. Returns an empty map if the map is empty.
 --
 -- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]
 -- > deleteMax empty == empty
-deleteMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> TrieMap k m a
+deleteMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> TrieMap k m a
 deleteMax m0@(TrieMap n m) = maybe m0 (TrieMap (n-1) . snd) $ getMaxAlg m
 
 -- | Delete and find the minimal element.
 --
 -- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")]) 
 -- > deleteFindMin                                            Error: can not return the minimal element of an empty map
-deleteFindMin :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
+deleteFindMin :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
 deleteFindMin = fromMaybe (error "cannot return the minimal element of an empty map") . minViewWithKey
 
 checkNothing :: Maybe a -> (Bool, Maybe a)
@@ -800,14 +821,14 @@
 --
 -- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])
 -- > deleteFindMax empty                                      Error: can not return the maximal element of an empty map
-deleteFindMax :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
+deleteFindMax :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> ((k, a), TrieMap k m a)
 deleteFindMax = fromMaybe (error "cannot return the maximal element of an empty map") . maxViewWithKey
 
 -- | Update the value at the minimal key.
 --
 -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]
 -- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateMin :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
+updateMin :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
 updateMin f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
 	where	(del, m') = updateMinAlg (const (checkNothing . g)) m
 		g (Elem x) = Elem <$> f x
@@ -816,7 +837,7 @@
 --
 -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]
 -- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-updateMax :: (Algebraic k, TrieKey (Alg k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
+updateMax :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
 updateMax f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
 	where	(del, m') = updateMaxAlg (const (checkNothing . g)) m
 		g (Elem x) = Elem <$> f x
@@ -825,7 +846,7 @@
 --
 -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]
 -- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"
-updateMinWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
+updateMinWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
 updateMinWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
 	where	(del, m') = updateMinAlg (checkNothing .: g) m
 		g k (Elem v) = Elem <$> f (fromAlg k) v
@@ -834,7 +855,7 @@
 --
 -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]
 -- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"
-updateMaxWithKey :: (Algebraic k, TrieKey (Alg k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
+updateMaxWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => (k -> a -> Maybe a) -> TrieMap k m a -> TrieMap k m a
 updateMaxWithKey f (TrieMap n m) = TrieMap (if del then n-1 else n) m'
 	where	(del, m') = updateMaxAlg (checkNothing .: g) m
 		g k (Elem v) = Elem <$>  f (fromAlg k) v
@@ -845,7 +866,7 @@
 --
 -- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")
 -- > minView empty == Nothing
-minView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
+minView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
 minView (TrieMap n m) = do
 	(~(_, Elem v), m') <- getMinAlg m
 	return (v, TrieMap (n-1) m')
@@ -855,7 +876,7 @@
 --
 -- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")
 -- > maxView empty == Nothing
-maxView :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
+maxView :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe (a, TrieMap k m a)
 maxView (TrieMap n m) = do
 	(~(_, Elem v), m') <- getMaxAlg m
 	return (v, TrieMap (n-1) m')
@@ -865,7 +886,7 @@
 --
 -- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")
 -- > minViewWithKey empty == Nothing
-minViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
+minViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
 minViewWithKey (TrieMap n m) = do
 	(~(k, Elem v), m') <- getMinAlg m
 	return ((fromAlg k, v), TrieMap (n-1) m')
@@ -875,7 +896,7 @@
 --
 -- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")
 -- > maxViewWithKey empty == Nothing
-maxViewWithKey :: (Algebraic k, TrieKey (Alg k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
+maxViewWithKey :: (Algebraic k, TrieKey (AlgRep k) m) => TrieMap k m a -> Maybe ((k, a), TrieMap k m a)
 maxViewWithKey (TrieMap n m) = do
 	~(~(k, Elem v), m') <- getMaxAlg m
 	return ((fromAlg k, v), TrieMap (n-1) m')
@@ -883,7 +904,7 @@
 -- | /O(n+m)/.
 -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
 --
-isSubmapOf :: (Algebraic k, TrieKey (Alg k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool
+isSubmapOf :: (Algebraic k, TrieKey (AlgRep k) m, Eq a) => TrieMap k m a -> TrieMap k m a -> Bool
 isSubmapOf = isSubmapOfBy (==)
 
 {- | /O(n+m)/.
@@ -903,7 +924,7 @@
  > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
  
 -}
-isSubmapOfBy :: (Algebraic k, TrieKey (Alg k) m) => (a -> b -> Bool) -> TrieMap k m a -> TrieMap k m b -> Bool
+isSubmapOfBy :: (Algebraic k, TrieKey (AlgRep k) m) => (a -> b -> Bool) -> TrieMap k m a -> TrieMap k m b -> Bool
 isSubmapOfBy (<=) (TrieMap n1 m1) (TrieMap n2 m2) = (Prelude.<=) n1 n2 && isSubmapAlg (<<=) m1 m2
 	where	Elem x <<= Elem y = x <= y
 
@@ -916,7 +937,7 @@
 -- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")
 -- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)
 -- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)
-split :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
+split :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, TrieMap k m a)
 split k m = case splitLookup k m of
 	(mL, _, mR)	-> (mL, mR)
 
@@ -928,8 +949,6 @@
 -- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")
 -- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)
 -- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)
-splitLookup :: (Algebraic k, TrieKey (Alg k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)
+splitLookup :: (Algebraic k, TrieKey (AlgRep k) m) => k -> TrieMap k m a -> (TrieMap k m a, Maybe a, TrieMap k m a)
 splitLookup k (TrieMap n m) = case splitLookupAlg (\ (Elem v) -> (Nothing, Just v, Nothing)) (toAlg k) m of
 	(mL, v, mR) -> (mkTrieMap mL, v, mkTrieMap mR)
--- TODO: Somehow, avoid the mkTrieMap call.  Is this possible?  I don't think so, without a sophisticated range-mconcat operation
--- with monoids or some crazy shit like that.
diff --git a/TrieMap/Algebraic.hs b/TrieMap/Algebraic.hs
--- a/TrieMap/Algebraic.hs
+++ b/TrieMap/Algebraic.hs
@@ -1,9 +1,14 @@
-{-# LANGUAGE UndecidableInstances, TypeFamilies, TypeSynonymInstances  #-}
+{-# LANGUAGE TypeOperators, FlexibleContexts, UndecidableInstances, TypeFamilies, TypeSynonymInstances  #-}
 
-module TrieMap.Algebraic (Algebraic(..), Ordered(..)) where
+module TrieMap.Algebraic (Algebraic(..), AlgebraicT(..), SAlgebraicT(..), Ordered(..), AlgWrap (..)) where
 
+import Control.Arrow
+import Data.Bits
+import Data.ByteString (ByteString, pack, unpack)
 import Data.Char
 import Data.Maybe
+import Data.List (unfoldr)
+import Data.Word
 import Data.IntSet (IntSet)
 import Data.Set(Set)
 import qualified Data.IntSet as ISet
@@ -16,107 +21,397 @@
 import GHC.Exts (build)
 
 import TrieMap.TrieAlgebraic
+import TrieMap.MapTypes
 
+newtype AlgWrap t a = AlgWrap {unAlgWrap :: t a}
+
 -- | 'Algebraic' refers to a type with an algebraic representation, armed with methods to convert in each direction.
 -- 'toAlg' and 'fromAlg' should preserve equality and ordering.
 class Algebraic k where
-	-- | @'Alg' k@ is a fully decomposed representation of k into algebraic pieces.
-	type Alg k
-	toAlg :: k -> Alg k
-	fromAlg :: Alg k -> k
+	-- | @'AlgRep' k@ is a fully decomposed representation of k into algebraic pieces.
+	type AlgRep k
+	toAlg :: k -> AlgRep k
+	fromAlg :: AlgRep k -> k
 
-instance (Algebraic k1, Algebraic k2) => Algebraic (k1, k2) where
-	type Alg (k1, k2) = (Alg k1, Alg k2)
-	toAlg (k1, k2) = (toAlg k1, toAlg k2)
-	fromAlg (k1, k2) = (fromAlg k1, fromAlg k2)
+class Functor (AlgRepT t) => AlgebraicT t where
+	type AlgRepT t :: * -> *
+	toAlgT :: t a -> AlgRepT t a
+	fromAlgT :: AlgRepT t a -> t a
 
+class Functor (SAlgRepT t) => SAlgebraicT t where
+	type SAlgRepT t :: * -> *
+	toSAlgT :: Sized a => t a -> SAlgRepT t a
+	fromSAlgT :: Sized a => SAlgRepT t a -> t a
+
+instance AlgebraicT Id where
+	type AlgRepT Id = Id
+	toAlgT = id
+	fromAlgT = id
+
+instance (AlgebraicT t, Algebraic a) => Algebraic (AlgWrap t a) where
+	type AlgRep (AlgWrap t a) = AlgRepT t (AlgRep a)
+	toAlg = fmap toAlg . toAlgT . unAlgWrap
+	fromAlg = AlgWrap . fromAlgT . fmap fromAlg
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f `O` g) where
+	type AlgRepT (f `O` g) = AlgRepT f `O` AlgRepT g
+	toAlgT (O x) = O (fmap (\ (App y) -> App (toAlgT y)) (toAlgT x))
+	fromAlgT (O x) = O (fromAlgT (fmap (\ (App y) -> App (fromAlgT y)) x))
+
+instance (Algebraic (f (g a)), Functor f) => Algebraic ((f `O` g) a) where
+	type AlgRep ((f `O` g) a) = AlgRep (f (g a))
+	toAlg = toAlg . unO
+	fromAlg = o . fromAlg
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :*: g) where
+	type AlgRepT (f :*: g) = AlgRepT f :*: AlgRepT g
+	toAlgT (a :*: b) = toAlgT a :*: toAlgT b
+	fromAlgT (a :*: b) = fromAlgT a :*: fromAlgT b
+
+instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :*: g) a) where
+	type AlgRep ((f :*: g) a) = (AlgRepT f :*: AlgRepT g) (AlgRep a)
+	toAlg (a :*: b) = fmap toAlg (toAlgT a :*: toAlgT b)
+	fromAlg (a :*: b) = fromAlgT (fmap fromAlg a) :*: fromAlgT (fmap fromAlg b)
+
+instance (AlgebraicT f, AlgebraicT g) => AlgebraicT (f :+: g) where
+	type AlgRepT (f :+: g) = AlgRepT f :+: AlgRepT g
+	toAlgT (A a) = A (toAlgT a)
+	toAlgT (B b) = B (toAlgT b)
+	fromAlgT (A a) = A (fromAlgT a)
+	fromAlgT (B b) = B (fromAlgT b)
+
+instance (AlgebraicT f, AlgebraicT g, Algebraic a) => Algebraic ((f :+: g) a) where
+	type AlgRep ((f :+: g) a) = AlgRep (AlgWrap (f :+: g) a)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
+
+instance AlgebraicT f => Algebraic (Fix f) where
+	type AlgRep (Fix f) = Fix (AlgRepT f)
+	toAlg (Fix x) = Fix (fmap toAlg (toAlgT x))
+	fromAlg (Fix x) = Fix (fromAlgT (fmap fromAlg x))
+
+instance Algebraic a => AlgebraicT (Const a) where
+	type AlgRepT (Const a) = Const (AlgRep a)
+	toAlgT (Const a) = Const (toAlg a)
+	fromAlgT (Const a) = Const (fromAlg a)
+
+instance Algebraic a => Algebraic (Const a b) where
+	type AlgRep (Const a b) = Const (AlgRep a) b
+	toAlg (Const a) = Const (toAlg a)
+	fromAlg (Const a) = fromAlg (Const a)
+
+instance Algebraic a => AlgebraicT ((,) a) where
+	type AlgRepT ((,) a) = (,) (AlgRep a)
+	toAlgT = first toAlg
+	fromAlgT = first fromAlg
+
+instance (Algebraic a, Algebraic b) => Algebraic (a, b) where
+	type AlgRep (a, b) = AlgRep (AlgWrap ((,) a) b)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
+
+instance (Algebraic a, Algebraic b) => AlgebraicT ((,,) a b) where
+	type AlgRepT ((,,) a b) = (,) (AlgRep (a, b))
+	toAlgT (a, b, c) = (toAlg (a, b), c)
+	fromAlgT (ab, c) = case fromAlg ab of
+		(a, b)	-> (a, b, c)
+
 instance (Algebraic a, Algebraic b, Algebraic c) => Algebraic (a, b, c) where
-	type Alg (a, b, c) = (Alg a, (Alg b, Alg c))
-	toAlg (a, b, c) = toAlg (a, (b, c))
-	fromAlg x = case fromAlg x of
-		(a, (b, c)) -> (a, b, c) 
+	type AlgRep (a, b, c) = AlgRep (AlgWrap ((,,) a b) c)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
+instance (Algebraic a, Algebraic b, Algebraic c) => AlgebraicT ((,,,) a b c) where
+	type AlgRepT ((,,,) a b c) = (,) (AlgRep (a, b, c))
+	toAlgT (a, b, c, d) = (toAlg (a, b, c), d)
+	fromAlgT (abc, d) = case fromAlg abc of
+		(a, b, c) -> (a, b, c, d)
+
 instance (Algebraic a, Algebraic b, Algebraic c, Algebraic d) => Algebraic (a, b, c, d) where
-	type Alg (a, b, c, d) = (Alg a, (Alg b, (Alg c, Alg d)))
-	toAlg (a, b, c, d) = toAlg (a, (b, (c, d)))
-	fromAlg x = case fromAlg x of
-		(a, (b, (c, d))) -> (a, b, c, d)
+	type AlgRep (a, b, c, d) = AlgRep (AlgWrap ((,,,) a b c) d)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
-instance (Algebraic a, Algebraic b, Algebraic c, Algebraic d, Algebraic e) => Algebraic (a, b, c, d, e) where
-	type Alg (a, b, c, d, e) = (Alg a, (Alg b, (Alg c, (Alg d, Alg e))))
-	toAlg (a, b, c, d, e) = toAlg (a, (b, (c, (d, e))))
-	fromAlg x = case fromAlg x of
-		(a, (b, (c, (d, e)))) -> (a, b, c, d, e)
+instance Algebraic a => AlgebraicT (Either a) where
+	type AlgRepT (Either a) = Either (AlgRep a)
+	toAlgT = either (Left . toAlg) Right
+	fromAlgT = either (Left . fromAlg) Right
 
-instance (Algebraic k1, Algebraic k2) => Algebraic (Either k1 k2) where
-	type Alg (Either k1 k2) = Either (Alg k1) (Alg k2)
-	toAlg = either (Left . toAlg) (Right . toAlg)
-	fromAlg = either (Left . fromAlg) (Right . fromAlg)
+instance (Algebraic a, Algebraic b) => Algebraic (Either a b) where
+	type AlgRep (Either a b) = AlgRep (AlgWrap (Either a) b)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
+instance AlgebraicT [] where
+	type AlgRepT [] = []
+	toAlgT = id
+	fromAlgT = id
+
 instance Algebraic k => Algebraic [k] where
-	type Alg [k] = [Alg k]
+	type AlgRep [k] = [AlgRep k]
 	toAlg = map toAlg
 	fromAlg = map fromAlg
 
 instance Algebraic () where
-	type Alg () = ()
+	type AlgRep () = ()
 	toAlg = id
 	fromAlg = id
 
+instance AlgebraicT Maybe where
+	type AlgRepT Maybe = Either ()
+	toAlgT = maybe (Left ()) Right
+	fromAlgT = either (const Nothing) Just
+
+instance SAlgebraicT Maybe where
+	type SAlgRepT Maybe = AlgRepT Maybe
+	toSAlgT = toAlgT 
+	fromSAlgT = fromAlgT
+
 instance Algebraic a => Algebraic (Maybe a) where
-	type Alg (Maybe a) = Either () (Alg a)
-	toAlg Nothing = Left ()
-	toAlg (Just a) = Right (toAlg a)
-	fromAlg (Left _) = Nothing
-	fromAlg (Right a) = Just (fromAlg a)
+	type AlgRep (Maybe a) = AlgRep (AlgWrap Maybe a)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
 instance Algebraic Bool where
-	type Alg Bool = Alg (Maybe ())
+	type AlgRep Bool = AlgRep (Maybe ())
 	toAlg b = toAlg $ if b then Just () else Nothing
 	fromAlg = maybe False (const True) . fromAlg'
-		where	fromAlg' = fromAlg :: Alg (Maybe ()) -> Maybe ()
+		where	fromAlg' = fromAlg :: AlgRep (Maybe ()) -> Maybe ()
 
 instance Algebraic Int where
-	type Alg Int = Int
+	type AlgRep Int = Int
 	toAlg = id
 	fromAlg = id
 
 instance Algebraic Char where
-	type Alg Char = Int
+	type AlgRep Char = Int
 	toAlg = ord
 	fromAlg = chr
 
 instance Algebraic Float where
-	type Alg Float = Ordered Float
+	type AlgRep Float = Ordered Float
 	toAlg = Ord
 	fromAlg = unOrd
 
 instance Algebraic Double where
-	type Alg Double = Ordered Double
+	type AlgRep Double = Ordered Double
 	toAlg = Ord
 	fromAlg = unOrd
 
 instance Algebraic Rational where
-	type Alg Rational = Ordered Rational
+	type AlgRep Rational = Ordered Rational
 	toAlg = Ord
 	fromAlg = unOrd
 
+instance Algebraic a => Algebraic (Ordered a) where
+	type AlgRep (Ordered a) = AlgRep a
+	toAlg = toAlg . unOrd
+	fromAlg = Ord . fromAlg
+
 instance (Algebraic k, Algebraic v) => Algebraic (Map k v) where
-	type Alg (Map k v) = [(Alg k, Alg v)]
-	toAlg m = build (\ c n -> Map.foldWithKey (\ k v -> c (toAlg k, toAlg v)) n m)
-	fromAlg xs = Map.fromDistinctAscList [(fromAlg k, fromAlg v) | (k, v) <- xs]
+	type AlgRep (Map k v) = AlgRep (AlgWrap (Map k) v) 
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
+instance Algebraic k => AlgebraicT (Map k) where
+	type AlgRepT (Map k) = [] `O` ((,) k)
+	toAlgT = o . Map.assocs
+	fromAlgT = Map.fromDistinctAscList . unO
+
+instance Algebraic k => SAlgebraicT (Map k) where
+	type SAlgRepT (Map k) = [] `O` ((,) k)
+	toSAlgT = o . Map.assocs
+	fromSAlgT = Map.fromDistinctAscList . unO
+
 instance Algebraic v => Algebraic (IntMap v) where
-	type Alg (IntMap v) = [(Int, Alg v)]
-	toAlg m = build (\ c n -> IMap.foldWithKey (\ k v -> c (k, toAlg v)) n m)
-	fromAlg xs = IMap.fromDistinctAscList [(k, fromAlg v) | (k, v) <- xs]
+	type AlgRep (IntMap v) = AlgRep (AlgWrap IntMap v)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg
 
+instance AlgebraicT IntMap where
+	type AlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
+	toAlgT = toAlgT . o . IMap.assocs
+	fromAlgT = IMap.fromDistinctAscList . unO . fromAlgT
+
+instance SAlgebraicT IntMap where
+	type SAlgRepT IntMap = AlgRepT ([] `O` ((,) Int))
+	toSAlgT = toAlgT . o . IMap.assocs
+	fromSAlgT = IMap.fromDistinctAscList . unO . fromAlgT
+
 instance Algebraic a => Algebraic (Set a) where
-	type Alg (Set a) = [Alg a]
-	toAlg s = build (\ c n -> Fold.foldr (c . toAlg) n s)
-	fromAlg = Set.fromDistinctAscList . map fromAlg
+	type AlgRep (Set a) = AlgRep (AlgWrap Set a)
+	toAlg = toAlg . AlgWrap
+	fromAlg = unAlgWrap . fromAlg 
 
+instance AlgebraicT Set where
+	type AlgRepT Set = AlgRepT []
+	toAlgT = toAlgT . Fold.toList
+	fromAlgT = Set.fromDistinctAscList . fromAlgT
+
 instance Algebraic IntSet where
-	type Alg IntSet = [Int]
-	toAlg = ISet.toList
-	fromAlg = ISet.fromDistinctAscList
+	type AlgRep IntSet = AlgRep [Int]
+	toAlg = toAlg . ISet.toList
+	fromAlg = ISet.fromDistinctAscList . fromAlg
+
+{-# RULES
+	"map/id" forall xs . map id xs = xs;
+	#-}
+
+instance SAlgebraicT m => SAlgebraicT (ConstMap m k m') where
+	type SAlgRepT (ConstMap m k m') = SAlgRepT m
+	toSAlgT (ConstMap m) = toSAlgT m
+	fromSAlgT = ConstMap . fromSAlgT
+
+instance Algebraic (m a) => Algebraic (ConstMap m k m' a) where
+	type AlgRep (ConstMap m k m' a) = AlgRep (m a)
+	toAlg (ConstMap m) = toAlg m
+	fromAlg = ConstMap . fromAlg
+
+instance SAlgebraicT m => SAlgebraicT (IdMap k m) where
+	type SAlgRepT (IdMap k m) = SAlgRepT m
+	toSAlgT (IdMap m) = toSAlgT m
+	fromSAlgT = IdMap . fromSAlgT
+
+instance Algebraic (m a) => Algebraic (IdMap k m a) where
+	type AlgRep (IdMap k m a) = AlgRep (m a)
+	toAlg (IdMap m) = toAlg m
+	fromAlg = IdMap . fromAlg
+
+instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m), TrieKey k m, TrieKeyT f2 t2) => SAlgebraicT (ProdMap t1 t2 k m) where
+	type SAlgRepT (ProdMap t1 t2 k m) = (SAlgRepT (t1 k m) `O` SAlgRepT (t2 k m))
+	toSAlgT (PMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
+	fromSAlgT (O m) = PMap (fromSAlgT (fmap (\ (App x) -> fromSAlgT x) m))
+
+instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
+	type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
+	toAlg (PMap m) = toAlg m
+	fromAlg = PMap . fromAlg
+
+instance (SAlgebraicT m1, SAlgebraicT m2, TrieKey k2 m2) => SAlgebraicT (CProdMap m1 k2 m2) where
+	type SAlgRepT (CProdMap m1 k2 m2) = SAlgRepT m1 `O` SAlgRepT m2
+	toSAlgT (CPMap m) = O (fmap (App . toSAlgT) (toSAlgT m))
+	fromSAlgT (O m) = CPMap (fromSAlgT (fmap (fromSAlgT . unApp) m))
+
+instance (Algebraic (m1 (m2 a))) => Algebraic (CProdMap m1 k2 m2 a) where
+	type AlgRep (CProdMap m1 k2 m2 a) = AlgRep (m1 (m2 a))
+	toAlg (CPMap m) = toAlg m
+	fromAlg = CPMap . fromAlg
+
+{-
+instance Algebraic (t1 k m (t2 k m a)) => Algebraic (ProdMap t1 t2 k m a) where
+	type AlgRep (ProdMap t1 t2 k m a) = AlgRep (t1 k m (t2 k m a))
+	toAlg = toAlg . unPMap
+	fromAlg = PMap . fromAlg-}
+
+instance (SAlgebraicT (t1 k m), SAlgebraicT (t2 k m)) => SAlgebraicT (UnionMap t1 t2 k m) where
+	type SAlgRepT (UnionMap t1 t2 k m) = SAlgRepT (t1 k m) :*: SAlgRepT (t2 k m)
+	toSAlgT (UMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
+	fromSAlgT (m1 :*: m2) = UMap (fromSAlgT m1) (fromSAlgT m2)
+
+instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where	
+	type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
+	toAlg (UMap m1 m2) = toAlg (m1, m2)
+	fromAlg = uncurry UMap . fromAlg
+
+instance (SAlgebraicT m1, SAlgebraicT m2) => SAlgebraicT (CUnionMap m1 k2 m2) where
+	type SAlgRepT (CUnionMap m1 k2 m2) = SAlgRepT m1 :*: SAlgRepT m2
+	toSAlgT (CUMap m1 m2) = toSAlgT m1 :*: toSAlgT m2
+	fromSAlgT (m1 :*: m2) = CUMap (fromSAlgT m1) (fromSAlgT m2)
+
+instance (Algebraic (m1 a), Algebraic (m2 a)) => Algebraic (CUnionMap m1 k2 m2 a) where
+	type AlgRep (CUnionMap m1 k2 m2 a) = AlgRep (m1 a, m2 a)
+	toAlg (CUMap m1 m2) = toAlg (m1, m2)
+	fromAlg = uncurry CUMap . fromAlg
+
+-- instance (Algebraic (t1 k m a), Algebraic (t2 k m a)) => Algebraic (UnionMap t1 t2 k m a) where
+-- 	type AlgRep (UnionMap t1 t2 k m a) = AlgRep (t1 k m a, t2 k m a)
+-- 	toAlg (UMap m1 m2) = toAlg (m1, m2)
+-- 	fromAlg = uncurry UMap . fromAlg
+
+instance SAlgebraicT f => SAlgebraicT (App f) where
+	type SAlgRepT (App f) = SAlgRepT f
+	toSAlgT = toSAlgT . unApp
+	fromSAlgT = App . fromSAlgT
+
+instance AlgebraicT f => AlgebraicT (App f) where
+	type AlgRepT (App f) = AlgRepT f
+	toAlgT = toAlgT . unApp
+	fromAlgT = App . fromAlgT
+
+instance Algebraic (f a) => Algebraic (App f a) where
+	type AlgRep (App f a) = AlgRep (f a)
+	toAlg = toAlg . unApp
+	fromAlg = App . fromAlg
+
+instance SAlgebraicT (t1 (App f2 k) (App (t2 k m))) => SAlgebraicT (CompMap t1 f2 t2 k m) where
+	type SAlgRepT (CompMap t1 f2 t2 k m) = SAlgRepT (t1 (App f2 k) (App (t2 k m)))
+	toSAlgT (CompMap m) = toSAlgT m
+	fromSAlgT = CompMap . fromSAlgT
+
+instance Algebraic (t1 (App f2 k) (App (t2 k m)) a) => Algebraic (CompMap t1 f2 t2 k m a) where
+	type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (t1 (App f2 k) (App (t2 k m)) a)
+	toAlg (CompMap m) = toAlg m
+	fromAlg = CompMap . fromAlg
+
+-- instance (AlgebraicT (t1 (App f2 k) (App (t2 k m))), Algebraic a) => Algebraic (CompMap t1 f2 t2 k m a) where
+-- 	type AlgRep (CompMap t1 f2 t2 k m a) = AlgRep (AlgWrap (CompMap t1 f2 t2 k m) a) 
+-- 	toAlg = toAlg . AlgWrap
+-- 	fromAlg = unAlgWrap . fromAlg
+
+-- newtype   f t a = FixMap (t (Fix f) (FixMap f t) a)
+
+instance (TrieKeyT f t) => SAlgebraicT (FixMap f t) where
+	type SAlgRepT (FixMap f t) = [] `O` ((,) (Fix f))
+	toSAlgT m = o (assocsAlg m)
+	fromSAlgT = fromDistAscListAlg . unO
+
+instance (TrieKeyT f t, AlgebraicT f, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
+	type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
+	toAlg = toAlg . assocsAlg
+	fromAlg = fromDistAscListAlg . fromAlg
+
+-- instance (AlgebraicT f, TrieKeyT f t, Sized a, Algebraic a) => Algebraic (FixMap f t a) where
+-- 	type AlgRep (FixMap f t a) = AlgRep [(Fix f, a)]
+-- 	toAlg = toAlg . assocsAlg
+-- 	fromAlg = fromDistAscListAlg . fromAlg
+
+instance Algebraic Word8 where
+	type AlgRep Word8 = Int
+	toAlg = fromIntegral
+	fromAlg = fromIntegral
+
+instance Algebraic Word16 where
+	type AlgRep Word16 = Int
+	toAlg = fromIntegral
+	fromAlg = fromIntegral
+
+instance Algebraic Word32 where
+	type AlgRep Word32 = Int
+	toAlg = fromIntegral
+	fromAlg = fromIntegral
+
+instance Algebraic Integer where
+	type AlgRep Integer = AlgRep [Word8]
+	toAlg = toAlg . unroll
+	fromAlg = roll . fromAlg
+
+instance Algebraic ByteString where
+	type AlgRep ByteString = AlgRep [Word8]
+	toAlg = toAlg . unpack
+	fromAlg = pack . fromAlg
+
+unroll :: Integer -> [Word8]
+unroll = unfoldr step
+  where
+    step 0 = Nothing
+    step i = Just (fromIntegral i, i `shiftR` 8)
+
+roll :: [Word8] -> Integer
+roll   = foldr unstep 0
+  where
+    unstep b a = a `shiftL` 8 .|. fromIntegral b
+
+
+{-# RULES
+	"toAlg/fromAlg" forall x . toAlg (fromAlg x) = x;
+ #-}
diff --git a/TrieMap/Applicative.hs b/TrieMap/Applicative.hs
--- a/TrieMap/Applicative.hs
+++ b/TrieMap/Applicative.hs
@@ -4,11 +4,7 @@
 import Control.Applicative
 import Data.Traversable (sequenceA)
 import GHC.Exts (build)
-
-newtype Id a = Id {unId :: a}
-
-instance Functor Id where
-	fmap f (Id x) = Id (f x)
+import TrieMap.MapTypes
 
 instance Applicative Id where
 	pure = return
diff --git a/TrieMap/MapTypes.hs b/TrieMap/MapTypes.hs
--- a/TrieMap/MapTypes.hs
+++ b/TrieMap/MapTypes.hs
@@ -1,25 +1,49 @@
-{-# LANGUAGE IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, KindSignatures, StandaloneDeriving, GeneralizedNewtypeDeriving, IncoherentInstances, TypeOperators, FlexibleContexts, StandaloneDeriving, ExistentialQuantification #-}
 
 module TrieMap.MapTypes where
 
 import Data.Foldable
 import Data.Traversable
-import Control.Applicative
+import Control.Applicative hiding (Const)
 import Prelude hiding (foldl, foldr)
 import qualified Data.IntMap as IMap
 
--- | 'ProdMap' is used to hold a map on the product of two key types.
-newtype ProdMap m1 m2 v = PMap {unPMap :: m1 (m2 v)} deriving (Eq, Ord)
+data (f :*: g) a = f a :*: g a deriving (Eq, Ord, Show)
+data (f :+: g) a = A (f a) | B (g a) deriving (Eq, Ord, Show)
+newtype Const a b = Const {unConst :: a} deriving (Eq, Ord, Show)
+newtype Id a = Id {unId :: a} deriving (Eq, Ord, Show)
+newtype Fix f = Fix (f (Fix f))
+newtype FixMap f t a = FixMap (t (Fix f) (FixMap f t) a)
 
--- | 'UnionMap' is used to hold a map on the sum of two key types.
-data UnionMap m1 m2 v = m1 v :+: m2 v deriving (Eq, Ord)
+newtype O f g a = O (f (App g a))
+newtype App f a = App {unApp :: f a}
 
+o :: Functor f => f (g a) -> (f `O` g) a
+o = O . fmap App
+
+unO :: Functor f => (f `O` g) a -> f (g a)
+unO (O x) = fmap unApp x
+
+-- | 'ProdMap' is used to hold a map on the product of two key types.
+newtype ProdMap t1 t2 k (m :: * -> *) a = PMap {unPMap :: t1 k m (t2 k m a)}
+data UnionMap t1 t2 k (m :: * -> *) a = UMap (t1 k m a) (t2 k m a)
+newtype CProdMap m1 k2 m2 a = CPMap {unCPMap :: m1 (m2 a)}
+data CUnionMap m1 k2 m2 a = CUMap (m1 a) (m2 a)
+
 data Edge k m v = Edge {-# UNPACK #-} !Int [k] (Maybe v) (m (Edge k m v))
 type MEdge k m v = Maybe (Edge k m v)
 
 -- | 'RadixTrie' is used to hold a map on a list of keys.
 newtype RadixTrie k m v = Radix {unRad :: MEdge k m v} 
 
+newtype IdMap k m a = IdMap {unIdMap :: m a} 
+
+newtype ConstMap (m :: * -> *) k (x :: * -> *) a = ConstMap {unConstMap :: m a}
+
+newtype CompMap t1 f2 (t2 :: * -> (* -> *) -> * -> *) k (m :: * -> *) a = CompMap (t1 (App f2 k) (App (t2 k m)) a)
+
+-- newtype FixMap (m :: (* -> *) -> * -> *) a = FixMap (m (FixMap m) a)
+
 newtype Elem a = Elem {getElem :: a} deriving (Eq, Ord)
 
 instance Functor Elem where
@@ -34,6 +58,8 @@
 
 infixr 5 `ProdMap`
 infixr 5 :+:
+infixr 8 :*:
+infixr 9 `O`
 
 class Sized a where
 	getSize :: a -> Int
@@ -41,46 +67,100 @@
 instance Sized (Elem a) where
 	getSize _ = 1
 
-instance (Functor m1, Functor m2) => Functor (ProdMap m1 m2) where
-	fmap f (PMap m) = PMap (fmap (fmap f) m)
+instance Functor m => Functor (Edge k m) where
+	fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
+raverse f (Radix e) = Radix <$> traverse (traverse f) e
 
-instance (Foldable m1, Foldable m2) => Foldable (ProdMap m1 m2) where
-	foldr f z (PMap m) = foldr (flip (foldr f)) z m
-	foldl f z (PMap m) = foldl (foldl f) z m
+instance (Functor f, Functor g) => Functor (f :*: g) where
+	fmap f (a :*: b) = fmap f a :*: fmap f b
 
-instance (Traversable m1, Traversable m2) => Traversable (ProdMap m1 m2) where
-	traverse f (PMap m) = PMap <$> traverse (traverse f) m
+instance (Foldable f, Foldable g) => Foldable (f :*: g) where
+	foldr f z (a :*: b) = foldr f (foldr f z b) a
+	foldl f z (a :*: b) = foldl f (foldl f z a) b
 
-instance (Functor m1, Functor m2) => Functor (UnionMap m1 m2) where
-	fmap f (m1 :+: m2) = fmap f m1 :+: fmap f m2
+instance (Traversable f, Traversable g) => Traversable (f :*: g) where
+	traverse f (a :*: b) = liftA2 (:*:) (traverse f a) (traverse f b)
 
-instance (Foldable m1, Foldable m2) => Foldable (UnionMap m1 m2) where
-	foldr f z (m1 :+: m2) = foldr f (foldr f z m2) m1
-	foldl f z (m1 :+: m2) = foldl f (foldl f z m1) m2
+instance (Functor f, Functor g) => Functor (f :+: g) where
+	fmap f (A a) = A (fmap f a)
+	fmap f (B b) = B (fmap f b)
 
-instance (Traversable m1, Traversable m2) => Traversable (UnionMap m1 m2) where
-	traverse f (m1 :+: m2) = liftA2 (:+:) (traverse f m1) (traverse f m2)
+instance (Foldable f, Foldable g) => Foldable (f :+: g) where
+	foldr f z (A a) = foldr f z a
+	foldr f z (B b) = foldr f z b
+	foldl f z (A a) = foldl f z a
+	foldl f z (B b) = foldl f z b
 
-instance Functor m => Functor (Edge k m) where
-	fmap f (Edge n ks v ts) = Edge n ks (fmap f v) (fmap (fmap f) ts)
+instance (Traversable f, Traversable g) => Traversable (f :+: g) where
+	traverse f (A a) = A <$> traverse f a
+	traverse f (B b) = B <$> traverse f b
 
-instance Functor m => Functor (RadixTrie k m) where
-	fmap f (Radix e) = Radix (fmap (fmap f) e)
+instance Functor (Const a) where
+	fmap f (Const x) = Const x
 
-instance Foldable m => Foldable (Edge k m) where
-	foldr f z (Edge _ _ v ts) = foldr (flip (foldr f)) (foldr f z v) ts
-	foldl f z (Edge _ _ v ts) = foldl f (foldl (foldl f) z ts) v
+instance Foldable (Const a) where
+	foldr f z _ = z
+	foldl f z _ = z
 
-instance Foldable m => Foldable (RadixTrie k m) where
-	foldr f z (Radix e) = foldr (flip (foldr f)) z e
-	foldl f z (Radix e) = foldl (foldl f) z e
+instance Traversable (Const a) where
+	traverse f (Const x) = pure (Const x)
 
-instance Traversable m => Traversable (Edge k m) where
-	traverse f (Edge n ks v ts) = 
-		liftA2 (Edge n ks) (traverse f v) (traverse (traverse f) ts)
+instance Functor Id where
+	fmap f (Id a) = Id (f a)
 
-instance Traversable m => Traversable (RadixTrie k m) where
-	traverse f (Radix e) = Radix <$> traverse (traverse f) e
+instance Foldable Id where
+	foldr f z (Id a) = a `f` z
+	foldl f z (Id a) = z `f` a
+
+instance Traversable Id where
+	traverse f (Id a) = Id <$> f a
+
+class EqT f where
+	eq :: Eq a => f a -> f a -> Bool
+
+instance EqT f => Eq (Fix f) where
+	Fix x == Fix y = x `eq` y
+
+instance (EqT f, EqT g) => EqT (f :*: g) where
+	(a :*: x) `eq` (b :*: y) = a `eq` b && x `eq` y
+
+instance (EqT f, EqT g) => EqT (f :+: g) where
+	A a `eq` A b = a `eq` b
+	B x `eq` B y = x `eq` y
+	_ `eq` _ = False
+
+instance Eq a => EqT (Const a) where
+	Const a `eq` Const b = a == b
+
+instance EqT Id where
+	Id a `eq` Id b = a == b
+
+instance EqT [] where
+	eq = (==)
+
+instance EqT Maybe where
+	eq = (==)
+
+instance Eq a => EqT ((,) a) where
+	eq = (==)
+
+instance Eq a => EqT (Either a) where
+	eq = (==)
+
+instance EqT f => EqT (App f) where
+	App a `eq` App b = a `eq` b
+
+instance (EqT f, Eq a) => Eq (App f a) where
+	(==) = eq
+
+instance (EqT f, EqT g) => EqT (f `O` g) where
+	O a `eq` O b = a `eq` b
+
+instance (EqT f, EqT g, Eq a) => Eq ((f `O` g) a) where
+	(==) = eq
+
+instance (Functor f, Functor g) => Functor (f `O` g) where
+	fmap f (O x) = O (fmap (\ (App x) -> App (fmap f x)) x)
 
 instance Traversable IMap.IntMap where
 	traverse f m = IMap.fromDistinctAscList <$> traverse (\ (k, v) -> ((,) k) <$> f v) (IMap.assocs m)
diff --git a/TrieMap/RadixTrie.hs b/TrieMap/RadixTrie.hs
--- a/TrieMap/RadixTrie.hs
+++ b/TrieMap/RadixTrie.hs
@@ -1,301 +1,274 @@
-{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, StandaloneDeriving, PatternGuards #-}
+{-# LANGUAGE IncoherentInstances, PatternGuards, MultiParamTypeClasses, UndecidableInstances #-}
 
-module TrieMap.RadixTrie (RadixTrie) where
+module TrieMap.RadixTrie where
 
-import Control.Applicative hiding (Alternative(..))
-import Control.Monad
-import Data.Foldable
-import Data.Traversable
-import Data.Monoid
+import Control.Applicative
+
 import Data.Maybe
-import Data.Ord
+import Data.Monoid
+import Data.Foldable
 import Data.Sequence (Seq, (|>))
 import qualified Data.Sequence as Seq
+import Data.Traversable
 
+import TrieMap.Algebraic
+import TrieMap.Applicative
 import TrieMap.MapTypes
 import TrieMap.TrieAlgebraic
-import TrieMap.Applicative
 
-import Prelude hiding (null, foldr, all)
-
-instance (Eq k, Eq v, TrieKey k m) => Eq (Edge k m v) where
-	Edge n1 ks1 v1 ts1 == Edge n2 ks2 v2 ts2 = n1 == n2 && ks1 == ks2 && v1 == v2 && assocsAlg ts1 == assocsAlg ts2
-
-instance (Ord k, Ord v, TrieKey k m) => Ord (Edge k m v) where
-	Edge _ ks1 v1 ts1 `compare` Edge _ ks2 v2 ts2 = 
-		compare ks1 ks2 `mappend` compare v1 v2 `mappend` comparing assocsAlg ts1 ts2
-
-deriving instance (Eq k, Eq v, TrieKey k m) => Eq (RadixTrie k m v)
-deriving instance (Ord k, Ord v, TrieKey k m) => Ord (RadixTrie k m v)
-deriving instance (Show k, Show v, Functor m, Show (m String)) => Show (RadixTrie k m v)
-
-instance (Show k, Show v, Functor m, Show (m String)) => Show (Edge k m v) where
-	show (Edge _ k v ts) = "Edge " ++ show k ++ " " ++ show v ++ " " ++ show (fmap show ts)
-
-instance Sized (Edge k m v) where
-	getSize (Edge n _ _ _) = n
+import Prelude hiding (foldr)
 
-instance (Ord k, TrieKey k m) => TrieKey [k] (RadixTrie k m) where
-	emptyAlg = Radix Nothing
-	nullAlg = isNothing . unRad
-	sizeAlg (Radix e) = maybe 0 getSize e
-	getSingleAlg (Radix e) = e >>= getSingleEdge
-	guardNullAlg (Radix e) = do	e <- guardNullEdge =<< e
-					return (Radix (Just e))
-	lookupAlg ks = unRad >=> lookupEdge (==) ks
--- 	sizeAlg (Radix e) = maybe 0 sizeEdge e
-	alterLookupAlg f k = fmap Radix .
-		maybe (fmap (maybeSingleEdge k) $ f Nothing)
-			(alterLookupEdge (==) f k) . unRad
-	foldWithKeyAlg f z = foldr (flip (foldWithKeyEdge f)) z . unRad
-	mapMaybeAlg f (Radix e) = Radix (e >>= mapMaybeEdge f)
-	mapEitherAlg f (Radix Nothing) = (emptyAlg, emptyAlg)
-	mapEitherAlg f (Radix (Just e)) = (Radix e1, Radix e2)
-		where	(e1, e2) = mapEitherEdge f e
--- 	mapMaybeAlg f (Radix e) = (Radix . join) <$> traverse (mapAppMaybeEdge f) e
-	mapAppAlg f = fmap Radix . traverse (mapAppEdge f) . unRad
-	unionMaybeAlg f (Radix e1) (Radix e2) = Radix (unionMaybe (unionMaybeEdge f) e1 e2)
-	intersectAlg f (Radix e1) (Radix e2) = Radix (intersectMaybe (intersectEdge f) e1 e2)
-	differenceAlg f (Radix e1) (Radix e2) = Radix (differenceMaybe (differenceEdge f) e1 e2)
+instance Sized (Edge k m a) where
+	getSize (Edge s _ _ _) = s
 
-	getMinAlg (Radix e) = fmap (fmap Radix . getMinEdge) e
-	getMaxAlg (Radix e) = fmap (fmap Radix . getMaxEdge) e
--- 	updateMinAlg f (Radix e) = Radix $ e >>= updateMinEdge f
--- 	updateMaxAlg f (Radix e) = Radix $ e >>= updateMaxEdge f
+instance TrieKeyT [] RadixTrie where
+	compareKeyT (a:as) (b:bs) = compareKey a b `mappend` compareKeyT as bs
+	compareKeyT [] (_:_) = LT
+	compareKeyT (_:_) [] = GT
+	compareKeyT [] [] = EQ
+	emptyT = Radix Nothing
+	nullT (Radix m) = isNothing m
+	sizeT (Radix m) = getSize m
+	getSingleT (Radix m) = m >>= getSingleEdge
+	guardNullT (Radix m) = m >>= guardNullEdge >>= return . Radix . Just
+	alterLookupT f ks (Radix Nothing) = (Radix . single ks) <$> f Nothing
+	alterLookupT f ks (Radix (Just e)) = Radix <$> alterLookupEdge f ks e
+	lookupT ks (Radix m) = m >>= lookupEdge ks
+	foldWithKeyT f z (Radix m) = foldr (foldEdge f) z m
+	mapAppT f (Radix m) = Radix <$> traverse (mapAppEdge f) m
+	mapMaybeT f (Radix m) = Radix (m >>= mapMaybeEdge f)
+	mapEitherT f (Radix m) = radBoth (maybe (Nothing, Nothing) (mapEitherEdge f) m)
+		where	 radBoth (e1, e2) = (Radix e1, Radix e2)
+	fromDistAscListT = fromAscListT (\ _ x _ -> x)
+	fromAscListT _ [] = Radix Nothing
+	fromAscListT f (x:xs) = Radix (Just (groupAscHeads' f x xs))
+	fromListT f xs = Radix (groupHeads f xs)
+	splitLookupT _ _ (Radix Nothing) = (emptyT, Nothing, emptyT)
+	splitLookupT f k (Radix (Just e)) = case splitLookupEdge f k e of
+		(eL, ans, eR)	-> (Radix eL, ans, Radix eR)
+	isSubmapT (<=) (Radix m1) (Radix m2) = isSubmapAlg (isSubEdge (<=)) m1 m2
+	getMinT (Radix m) = fmap (Radix <$>) (m >>= getMinEdge)
+	getMaxT (Radix m) = fmap (Radix <$>) (m >>= getMaxEdge)
+	updateMinT _ (Radix Nothing) = (False, Radix Nothing)
+	updateMinT f (Radix (Just e)) = Radix <$> updateMinEdge f e
+	updateMaxT _ (Radix Nothing) = (False, Radix Nothing)
+	updateMaxT f (Radix (Just e)) = Radix <$> updateMaxEdge f e
+	unionT f (Radix m1) (Radix m2) = Radix (unionMaybe (unionEdge f) m1 m2)
+	intersectT f (Radix m1) (Radix m2) = Radix (intersectMaybe (intersectEdge f) m1 m2)
+	differenceT f (Radix m1) (Radix m2) = Radix (differenceMaybe (differenceEdge f) m1 m2)
 
-	fromListAlg f xs = Radix (edgeFromList f xs)
-	fromAscListAlg f xs = Radix (edgeFromAscList f xs)
-	fromDistAscListAlg = fromAscListAlg (\ _ v _ -> v)
+instance TrieKey k m => TrieKey [k] (RadixTrie k m) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
 
-	isSubmapAlg (<=) (Radix e1) (Radix e2) = isSubmapAlg subEdge e1 e2 -- hehe, using the Maybe instance here!
-		where	subEdge = isSubmapEdge (==) (<=) lookupAlg $! isSubmapAlg subEdge
+single :: (Sized a, TrieKey k m) => [k] -> Maybe a -> MEdge k m a
+single ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)
 
-	valid (Radix e) = maybe True validEdge e
+edge :: (Sized a, TrieKey k m) => [k] -> Maybe a -> m (Edge k m a) -> Edge k m a
+edge ks v ts = Edge (getSize v + getSize ts) ks v ts
 
-	splitLookupAlg _ _ (Radix Nothing) = (Radix Nothing, Nothing, Radix Nothing)
-	splitLookupAlg f k (Radix (Just e)) = case splitEdge f k e of
-		(eL, ans, eR)	-> (Radix eL, ans, Radix eR)
+getSingleEdge :: TrieKey k m => Edge k m a -> Maybe ([k], a)
+getSingleEdge (Edge _ ks (Just v) ts)
+	| nullAlg ts	= Just (ks, v)
+getSingleEdge (Edge _ ks Nothing ts) = do
+	(l, e') <- getSingleAlg ts
+	(ls, v) <- getSingleEdge e'
+	return (ks ++ l:ls, v)
+getSingleEdge _ = Nothing
 
--- sizeEdge :: Edge k m v -> Int
--- sizeEdge (Edge n _ _ _) = n
+guardNullEdge :: TrieKey k m => Edge k m a -> MEdge k m a
+guardNullEdge (Edge s ks Nothing ts)
+	| nullAlg ts	= Nothing
+	| Just (l, Edge _ ls v ts') <- getSingleAlg ts
+			= Just (Edge s (ks ++ l:ls) v ts')
+guardNullEdge e = Just e
 
-{-# INLINE edge #-}
-edge :: (Sized v, TrieKey k m) => [k] -> Maybe v -> m (Edge k m v) -> Edge k m v
-edge ks v ts = Edge (getSize v + getSize ts) ks v ts
+alterLookupEdge :: (Eq k, TrieKey k m, Sized a) => (Maybe a -> (b, Maybe a)) -> [k] -> Edge k m a -> (b, MEdge k m a)
+alterLookupEdge f ks0 e@(Edge s ls0 v0 ts) = procEdge 0 ks0 ls0 where
+	procEdge i _ _ | i `seq` False = undefined
+	procEdge i (k:ks) (l:ls)
+		| k == l	= procEdge (i+1) ks ls
+		| otherwise	= breakEdge <$> f Nothing where
+			breakEdge Nothing	= Just e
+			breakEdge (Just v)	= let sV = getSize v in
+				Just (Edge (sV + s) (take i ls0) Nothing 
+					(fromListAlg (\ _ v _ -> v) [(k, Edge sV ks (Just v) emptyAlg), (l, Edge s ls v0 ts)]))
+	procEdge _ [] (l:ls) = splitEdge <$> f Nothing where
+		splitEdge Nothing = Just e
+		splitEdge (Just v) = let sV = getSize v in
+			Just (Edge (sV + s) ks0 (Just v) (singletonAlg l (Edge s ls v0 ts)))
+	procEdge _(k:ks) [] = (guardNullEdge . edge ls0 v0) <$> alterLookupAlg g k ts where
+		g Nothing = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg) <$> f Nothing 
+		g (Just e) = alterLookupEdge f ks e
+	procEdge _ [] [] = fmap (\ v -> guardNullEdge $ edge ls0 v ts) (f v0)
 
-lookupEdge :: TrieKey k m => (k -> k -> Bool) -> [k] -> Edge k m v -> Maybe v
-lookupEdge (==) ks (Edge _ ls v ts) = procEdge ks ls where
+lookupEdge :: (Eq k, TrieKey k m) => [k] -> Edge k m a -> Maybe a
+lookupEdge ks (Edge _ ls v ts) = procEdge ks ls where
 	procEdge (k:ks) (l:ls)
-		| k == l  = procEdge ks ls
-	procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge (==) ks
+		| k == l	= procEdge ks ls
+	procEdge (k:ks) [] = lookupAlg k ts >>= lookupEdge ks
 	procEdge [] [] = v
 	procEdge _ _ = Nothing
 
-edgeFromList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromList f xs = guardNullEdge $ edge [] v0 $ mapMaybeAlg (\ k (Elem xs)-> edgeFromList (f . (k:)) xs) $ 
-	fromListAlg (\ _ (Elem xs) (Elem ys) -> Elem (ys ++ xs)) ys
-	where	part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys)
-		part (k:ks, v) (v0, ys) = (v0, (k, Elem [(ks, v)]):ys)
-		(v0, ys) = foldr part (Nothing, []) xs
+foldEdge :: TrieKey k m => ([k] -> a -> b -> b) -> Edge k m a -> b -> b
+foldEdge f (Edge _ ks v ts) z = foldr (f ks) (foldWithKeyAlg (\ l -> foldEdge (\ ls -> f (ks ++ l:ls))) z ts) v
 
-edgeFromAscList :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> MEdge k m v
-edgeFromAscList _ [] = Nothing
-edgeFromAscList f (x:xs) = Just $ edgeFromAscList' f x xs
+mapAppEdge :: (TrieKey k m, Applicative f, Sized b) => ([k] -> a -> f b) -> Edge k m a -> f (Edge k m b)
+mapAppEdge f (Edge _ ks v ts) = edge ks <$> traverse (f ks) v <*> mapAppAlg (\ l -> mapAppEdge (\ ls -> f (ks ++ l:ls))) ts
 
-edgeFromAscList' :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> ([k], v) -> [([k], v)] -> Edge k m v
-edgeFromAscList' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg
-edgeFromAscList' f x xs = case groupHead f (x:xs) of
-	(Nothing, [(k, ~(Edge n ks v ts))])
-			-> Edge n (k:ks) v ts
-	(ans, xs')	-> edge [] ans (fromDistAscListAlg xs')
+mapMaybeEdge :: (TrieKey k m, Sized b) => ([k] -> a -> Maybe b) -> Edge k m a -> MEdge k m b
+mapMaybeEdge f (Edge _ ks v ts) = 
+	guardNullEdge (edge ks (v >>= f ks) (mapMaybeAlg (\ l -> mapMaybeEdge (\ ls -> f (ks ++ l:ls))) ts))
 
-groupHead :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> v) -> [([k], v)] -> (Maybe v, [(k, Edge k m v)])
-groupHead f (([], v):xs) = case groupHead f xs of
-	(v', ans)	-> (Just $ maybe v (f [] v) v', ans)
-groupHead f ((k:ks, v):xs) = (Nothing, groupHead' k (ks, v) Seq.empty xs) where
-	groupHead' k0 x xs ((k:ks, v):ys)
-		| k == k0	= groupHead' k0 x (xs |> (ks, v)) ys
-		| otherwise	= (k0, edgeFromAscList' (f . (k0:)) x (toList xs)):groupHead' k (ks, v) Seq.empty ys
-	groupHead' k0 x xs [] = [(k0, edgeFromAscList' (f . (k0:)) x (toList xs))]
-	groupHead' _ _ _ _ = error "Violation of ascending invariant!"
-groupHead _ [] = (Nothing, [])
- {-guardNullEdge $ Edge [] v0 $ mapMaybeAlg (\ k -> edgeFromAscList (f . (k:))) $ fromAscListAlg (const (flip (++))) ys
-	where	part ([], v) (v0, ys) = (Just $ maybe v (flip (f []) v) v0, ys)
-		part (k:ks, v) (v0, ys) = (v0, (k, [(ks, v)]):ys)
-		(v0, ys) = foldr part (Nothing, []) xs-}
+mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> (Maybe b, Maybe c)) -> Edge k m a -> 
+	(MEdge k m b, MEdge k m c)
+mapEitherEdge f (Edge _ ks v ts) = guardBoth (edge ks vL tsL, edge ks vR tsR)
+	where	(vL, vR) = maybe (Nothing, Nothing) (f ks) v
+		ts' = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+		(tsL, tsR) = mapEitherAlg (\ l -> mapEitherEdge (\ ls -> f (ks ++ l:ls))) ts
+		guardBoth (e1, e2) = (guardNullEdge e1, guardNullEdge e2)
 
-maybeSingleEdge :: Sized v => TrieKey k m => [k] -> Maybe v -> MEdge k m v
-maybeSingleEdge ks = fmap (\ v -> Edge (getSize v) ks (Just v) emptyAlg)
+groupAscHeads' :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> ([k], a) -> [([k], a)] -> Edge k m a
+groupAscHeads' f (ks, v) [] = Edge (getSize v) ks (Just v) emptyAlg
+groupAscHeads' f x xs = group0 Nothing (x:xs) where
+	group0 v0 (([], v):xs) = group0 (Just (maybe v (f [] v) v0)) xs
+	group0 (Just v0) [] = Edge (getSize v0) [] (Just v0) emptyAlg
+	group0 v0 ((k:ks, v):xs) = group1 Seq.empty k (ks, v) Seq.empty xs where
+		group1 ts k vk vs ((l:ls, v):xs)
+			| k == l	= group1 ts k vk (vs |> (ls, v)) xs
+			| otherwise	= group1 (ts |> (k, groupAscHeads' (f . (k:)) vk (toList vs))) l (ls, v) Seq.empty xs
+		group1 ts k v vs []
+			| Nothing <- v0, Seq.null ts, Edge s xs vX tsX <- groupAscHeads' (f . (k:)) v (toList vs)
+				= Edge s (k:xs) vX tsX
+			| otherwise
+				= edge [] v0 (fromDistAscListAlg (toList ts ++ [(k, groupAscHeads' (f . (k:)) v (toList vs))]))
 
-getSingleEdge :: (TrieKey k m) => Edge k m v -> Maybe ([k], v)
-getSingleEdge (Edge _ ks (Just v) ts)
-	| nullAlg ts	= Just (ks, v)
-getSingleEdge (Edge _ ks Nothing ts) = do
-	(x, e') <- getSingleAlg ts
-	(xs, v) <- getSingleEdge e'
-	return (ks ++ x:xs, v) 
-getSingleEdge _ = Nothing
+groupHeads :: (Eq k, TrieKey k m, Sized a) => ([k] -> a -> a -> a) -> [([k], a)] -> MEdge k m a
+groupHeads _ [] = Nothing
+groupHeads f xs = guardNullEdge $ edge [] v0 (mapMaybeAlg (\ k (Elem xs) -> groupHeads (f . (k:)) xs) $
+		fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k, Elem [(ks, v)]) | (k, ks, v) <- ts])
+	where	(v0, ts) = let	proc ([], v) (v0, ts) = (Just (maybe v (f [] v) v0), ts)
+				proc (k:ks, v) (v0, ts) = (v0, (k, ks, v):ts)
+				in foldr proc (Nothing, []) xs
 
-{-# INLINE guardNullEdge #-}
-guardNullEdge :: TrieKey k m => Edge k m v -> MEdge k m v
-guardNullEdge (Edge n ks Nothing ts)
-	| nullAlg ts	= Nothing
-	| Just (x, Edge n' xs v ts') <- getSingleAlg ts
-		= Just (Edge n' (ks ++ x:xs) v ts')
-guardNullEdge e = Just e
+mapEdge :: (Sized b, TrieKey k m) => ([k] -> a -> b) -> Edge k m a -> Edge k m b
+mapEdge f (Edge _ ks v ts) = edge ks (fmap (f ks) v) (mapWithKeyAlg (\ l -> mapEdge (\ ls -> f (ks ++ l:ls))) ts)
 
-alterLookupEdge :: (TrieKey k m, Sized v) => (k -> k -> Bool) ->
-	(Maybe v -> (a, Maybe v)) -> [k] -> Edge k m v -> (a, MEdge k m v)
-alterLookupEdge (==) f ks0 e@(Edge n0 ls0 v ts) = procEdge 0 ks0 ls0 where
-	procEdge i _ _ | i `seq` False = undefined
-	procEdge i (k:ks) (l:ls)
-		| k == l	= procEdge (i+1) ks ls
-		| otherwise	= fmap (Just . g) (f Nothing)
-		where	g Nothing = e
-			g (Just v') = let nV = getSize v' in Edge (n0 + nV) (take i ks0) Nothing $
-						fromListAlg' [(k, Edge nV ks (Just v') emptyAlg), (l, Edge n0 ls v ts)]
-	procEdge i (k:ks) [] = proc (alterLookupAlg g k ts) where
-		g Nothing = maybeSingleEdge ks <$> f Nothing
-		g (Just e') = alterLookupEdge (==) f ks e'
-		proc = fmap (guardNullEdge . edge ls0 v)
-	procEdge i [] (l:ls) = fmap (Just . g) $ f Nothing
-		where	g Nothing = e
-			g (Just v') = Edge (getSize v' + n0) ks0 (Just v') $ insertAlg l (Edge n0 ls v ts) emptyAlg
-	procEdge i [] [] = (ans, guardNullEdge (Edge (getSize fv - getSize v + n0) ks0 fv ts))
-		where	(ans, fv) = f v
+splitLookupEdge :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> 
+	(MEdge k m a, Maybe b, MEdge k m a)
+splitLookupEdge f ks e@(Edge s ls v ts) = procEdge ks ls where
+	procEdge (k:ks) (l:ls) = case compareKey k l of
+		LT	-> (Nothing, Nothing, Just e)
+		GT	-> (Just e, Nothing, Nothing)
+		EQ	-> procEdge ks ls
+	procEdge (k:ks) [] = case splitLookupAlg g k ts of
+		(tsL, ans, tsR)	-> (guardNullEdge (edge ls v tsL), ans, guardNullEdge (edge ls Nothing tsR))
+		where	g = splitLookupEdge f ks 
+	procEdge [] (l:ls) = (Nothing, Nothing, Just e)
+	procEdge [] [] = case v of
+		Nothing	-> (Nothing, Nothing, Just e)
+		Just v	-> case f v of
+			(vL, ans, vR)	-> (single ls vL, ans, guardNullEdge (edge ls vR ts))
 
-foldWithKeyEdge :: TrieKey k m => ([k] -> v -> x -> x) -> x -> Edge k m v -> x
-foldWithKeyEdge f z (Edge _ ks v ts) =
-	foldr (f ks) (foldWithKeyAlg (\ x -> flip (foldWithKeyEdge (\ xs -> f (ks ++ x:xs)))) z ts) v
+isSubEdge :: (TrieKey k m, Sized a, Sized b) => (a -> b -> Bool) -> Edge k m a -> Edge k m b -> Bool
+isSubEdge (<=) (Edge sK ks vK tsK) (Edge _ ls vL tsL) = procEdge ks ls where
+	procEdge (k:ks) (l:ls)
+		| k == l	= procEdge ks ls
+	procEdge (k:ks) []
+		| Just e' <- lookupAlg k tsL
+			= isSubEdge (<=) (Edge sK ks vK tsK) e'
+	procEdge [] [] = isSubmapAlg (<=) vK vL && isSubmapAlg (isSubEdge (<=)) tsK tsL
 
-mapMaybeEdge :: (TrieKey k m, Sized w) => ([k] -> v -> Maybe w) -> Edge k m v -> MEdge k m w
-mapMaybeEdge f (Edge _ ks v ts) = guardNullEdge $
-	edge ks (join $ traverse (f ks) v) (mapMaybeAlg (\ x -> mapMaybeEdge (\ xs -> f (ks ++ x:xs))) ts)
+getMinEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMinEdge (Edge s ks (Just v) ts) = Just ((ks, v), guardNullEdge (Edge (s - getSize v) ks Nothing ts))
+getMinEdge (Edge _ ks Nothing ts) = do
+	((l, e'), ts') <- getMinAlg ts
+	((ls, v), e'') <- getMinEdge e'
+	return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts') 
+		(\ e'' -> Just $ snd $ updateMinAlg (\ _ _ -> (False, Just e'')) ts) e''))
 
-mapEitherEdge :: (TrieKey k m, Sized b, Sized c) => ([k] -> a -> Either b c) -> Edge k m a -> (MEdge k m b, MEdge k m c)
-mapEitherEdge f (Edge _ ks v ts) =
-	(guardNullEdge $ edge ks vL tsL, guardNullEdge $ edge ks vR tsR) 
-	where	(vL, vR) = case fmap (f ks) v of
-			Nothing	-> (Nothing, Nothing)
-			Just (Left v)	-> (Just v, Nothing)
-			Just (Right v)	-> (Nothing, Just v)
-		ts' = mapWithKeyAlg (\ x -> Elem . mapEitherEdge (\ xs -> f (ks ++ x:xs))) ts
-		tsL = mapMaybeAlg (\ _ (Elem (tsL, _)) -> tsL) ts'
-		tsR = mapMaybeAlg (\ _ (Elem (_, tsR)) -> tsR) ts'
+getMaxEdge :: (TrieKey k m, Sized a) => Edge k m a -> Maybe (([k], a), MEdge k m a)
+getMaxEdge (Edge _ ks v0 ts)
+	| nullAlg ts = maybe Nothing (\ v -> Just ((ks, v), Nothing)) v0
+	| otherwise	= do
+		((l, e'), ts') <- getMaxAlg ts
+		((ls, v), e'') <- getMaxEdge e'
+		return ((ks ++ l:ls, v), fmap (edge ks Nothing) (maybe (guardNullAlg ts') 
+			(\ e'' -> Just $ snd $ updateMaxAlg (\ _ _ -> (False, Just e'')) ts) e''))
 
-mapAppEdge :: (Applicative f, TrieKey k m, Sized w) => ([k] -> v -> f w) -> Edge k m v -> f (Edge k m w)
-mapAppEdge f (Edge _ ks v ts) = liftA2 (edge ks) (traverse (f ks) v) (mapAppAlg (\ x -> mapAppEdge (\ xs -> f (ks ++ x:xs))) ts)
+updateMinEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+updateMinEdge f (Edge _ ks (Just v) ts)
+	= fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)
+updateMinEdge f (Edge _ ks Nothing ts) = fmap (guardNullEdge . edge ks Nothing) (updateMinAlg g ts) where
+	g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
 
-unionMaybeEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> v -> Maybe v) -> Edge k m v -> Edge k m v -> MEdge k m v
-unionMaybeEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge 0 ks0 ls0 where
+updateMaxEdge :: (TrieKey k m, Sized a) => ([k] -> a -> (Bool, Maybe a)) -> Edge k m a -> (Bool, MEdge k m a)
+updateMaxEdge f (Edge _ ks (Just v) ts)
+	| nullAlg ts = fmap (\ v -> guardNullEdge (edge ks v ts)) (f ks v)
+updateMaxEdge f (Edge _ ks v ts) = fmap (guardNullEdge . edge ks v) (updateMinAlg g ts) where
+	g l = updateMinEdge (\ ls -> f (ks ++ l:ls))
+
+unionEdge :: (TrieKey k m, Sized a) => ([k] -> a -> a -> Maybe a) -> Edge k m a -> Edge k m a -> MEdge k m a
+unionEdge f (Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge 0 ks0 ls0 where
 	procEdge i _ _ | i `seq` False = undefined
 	procEdge i (k:ks) (l:ls)
 		| k == l	= procEdge (i+1) ks ls
-		| otherwise	= Just $ Edge (nK + nL) (take i ks0) Nothing $ fromListAlg' [(k, Edge nK ks vK tsK), (l, Edge nL ls vL tsL)]
-	procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK
-	  where	g Nothing = Just (Edge nL ls vL tsL)
-		g (Just e') = unionMaybeEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
-	procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL 
-	  where	g Nothing = Just $ Edge nK ks vK tsK
-		g (Just e') = unionMaybeEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
-	procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe (f ks0) vK vL) $
-		unionMaybeAlg (\ x -> unionMaybeEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+		| otherwise	= Just (Edge (sK + sL) (take i ks0) Nothing 
+					(insertAlg k (Edge sK ks vK tsK) $ singletonAlg l (Edge sL ls vL tsL)))
+	procEdge _ (k:ks) [] = guardNullEdge $ edge ls0 vL $ alterAlg g k tsL where
+		g Nothing = Just (Edge sK ks vK tsK)
+		g (Just e) = unionEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e
+	procEdge _ [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK where
+		g Nothing = Just (Edge sL ls vL tsL)
+		g (Just e) = unionEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+	procEdge _ [] [] = guardNullEdge $ edge ks0 (unionMaybe	(f ks0) vK vL) $
+		unionMaybeAlg (\ x -> unionEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
 
-intersectEdge :: (Eq k, TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c
-intersectEdge f (Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where
+intersectEdge :: (TrieKey k m, Sized c) => ([k] -> a -> b -> Maybe c) -> Edge k m a -> Edge k m b -> MEdge k m c
+intersectEdge f (Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge ks0 ls0 where
 	procEdge (k:ks) (l:ls)
 		| k == l	= procEdge ks ls
 		| otherwise	= Nothing
 	procEdge (k:ks) [] = do
 		e' <- lookupAlg k tsL
-		Edge nX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
-		return (Edge nX (ls0 ++ k:xs) vX tsX)
+		Edge sX xs vX tsX <- intersectEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+		return (Edge sX (ls0 ++ k:xs) vX tsX)
 	procEdge [] (l:ls) = do
 		e' <- lookupAlg l tsK
-		Edge nX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
-		return (Edge nX (ks0 ++ l:xs) vX tsX)
-	procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $
-		intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+		Edge sX xs vX tsX <- intersectEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge sL ls vL tsL)
+		return (Edge sX (ks0 ++ l:xs) vX tsX)
+	procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) 
+		(intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL)
 
-{-# SPECIALIZE differenceEdge :: (Eq k, TrieKey k m) => ([k] -> Elem v -> w -> Maybe (Elem v)) -> 
-	Edge k m (Elem v) -> Edge k m w -> MEdge k m (Elem v) #-}
-differenceEdge :: (Eq k, TrieKey k m, Sized v) => ([k] -> v -> w -> Maybe v) -> Edge k m v -> Edge k m w -> MEdge k m v
-differenceEdge f e@(Edge nK ks0 vK tsK) (Edge nL ls0 vL tsL) = procEdge ks0 ls0 where
+differenceEdge :: (TrieKey k m, Sized a) => ([k] -> a -> b -> Maybe a) -> Edge k m a -> Edge k m b -> MEdge k m a
+differenceEdge f e@(Edge sK ks0 vK tsK) (Edge sL ls0 vL tsL) = procEdge ks0 ls0 where
 	procEdge (k:ks) (l:ls)
 		| k == l	= procEdge ks ls
 	procEdge (k:ks) []
 		| Just e' <- lookupAlg k tsL
-		= do	Edge nX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge nK ks vK tsK) e'
-			return (Edge nX (ls0 ++ k:xs) vX tsX)
-	procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK $ alterAlg g l tsK
-	  where	g Nothing = Nothing
-	  	g (Just e') = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e' (Edge nL ls vL tsL)
-	procEdge [] [] = guardNullEdge $ edge ks0 (differenceMaybe (f ks0) vK vL) $
-		differenceAlg (\ x -> differenceEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
+			= do	Edge sX xs vX tsX <- differenceEdge (\ ks' -> f (ls0 ++ k:ks')) (Edge sK ks vK tsK) e'
+				return (Edge sX (ls0 ++ k:xs) vX tsX)
+	procEdge [] (l:ls) = guardNullEdge $ edge ks0 vK (alterAlg (>>= g) l tsK) where
+		g e = differenceEdge (\ ls' -> f (ks0 ++ l:ls')) e (Edge sL ls vL tsL)
+	procEdge [] [] = guardNullEdge $ edge ks0 (intersectMaybe (f ks0) vK vL) $ 
+		intersectAlg (\ x -> intersectEdge (\ xs -> f (ks0 ++ x:xs))) tsK tsL
 	procEdge _ _ = Just e
-
-{-# SPECIALIZE getMinEdge :: TrieKey k m => Edge k m (Elem v) -> (([k], Elem v), MEdge k m (Elem v)) #-}
-getMinEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)
-getMinEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)
-getMinEdge (Edge nK ks _ ts) 
-	| Just ((l, e), ts') <- getMinAlg ts, ((ls, v), e') <- getMinEdge e
-		= ((ks ++ l:ls, v), guardNullEdge $ edge ks Nothing $ maybe ts' (\ e' -> snd $ updateMinAlg (\ _ _ -> (False, Just e')) ts) e')
-getMinEdge _ = error "Uncompacted edge"
-
-getMaxEdge :: (Sized v, TrieKey k m) => Edge k m v -> (([k], v), MEdge k m v)
-getMaxEdge (Edge nK ks v0 ts)
-	| Just ((l, e), ts') <- getMaxAlg ts, ((ls, v), e') <- getMaxEdge e
-		= ((ks ++ l:ls, v), guardNullEdge $ edge ks v0 $ maybe ts' (\ e' -> snd $ updateMaxAlg (\ _ _ -> (False, Just e')) ts) e')
-getMaxEdge (Edge nK ks (Just v) ts) = ((ks, v), guardNullEdge $ Edge (nK - getSize v) ks Nothing ts)
-getMaxEdge _ = error "Uncompacted edge"
-
-updateMinEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)
-updateMinEdge f (Edge _ ks (Just v) ts) = fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)
-updateMinEdge f (Edge _ ks Nothing ts)
-	= fmap (guardNullEdge . edge ks Nothing) $ updateMinAlg (\ l -> updateMinEdge (\ ls -> f (ks ++ l:ls))) ts
-
-updateMaxEdge :: (TrieKey k m, Sized v) => ([k] -> v -> (Bool, Maybe v)) -> Edge k m v -> (Bool, MEdge k m v)
-updateMaxEdge f (Edge _ ks (Just v) ts)
-	| nullAlg ts	= fmap (\ v' -> guardNullEdge $ edge ks v' ts) (f ks v)
-updateMaxEdge f (Edge _ ks v ts) = 
-	fmap (guardNullEdge . edge ks v) $ updateMaxAlg (\ l -> updateMaxEdge (\ ls -> f (ks ++ l:ls))) ts
-
-isSubmapEdge :: TrieKey k m => (k -> k -> Bool) -> (a -> b -> Bool) -> (k -> m (Edge k m b) -> MEdge k m b) -> (m (Edge k m a) -> m (Edge k m b) -> Bool) -> 
-	Edge k m a -> Edge k m b -> Bool
-isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) (Edge nL ls vL tsL) = procEdge ks ls where
-	procEdge (k:ks) (l:ls)
-		| k == l	= procEdge ks ls
-	procEdge (k:ks) []
-		| Just e <- lookup k tsL
-			= isSubmapEdge (==) (<=) lookup (<<=) (Edge nK ks vK tsK) e
-	procEdge [] [] 
-		| Nothing <- vK	= tsK <<= tsL
-		| Just x <- vK, Just y <- vL, x <= y
-				= tsK <<= tsL
-	procEdge _ _ = False
-validEdge :: TrieKey k m => Edge k m v -> Bool
-validEdge (Edge _ _ Nothing m)
-	| nullAlg m	= False
-	| Just{} <- getSingleAlg m
-			= False
-validEdge (Edge _ _ _ m)
-	= valid m && all validEdge m
-
-
-splitEdge :: (Ord k, TrieKey k m, Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> [k] -> Edge k m a -> (MEdge k m a, Maybe b, MEdge k m a)
-splitEdge f ks0 e@(Edge nL ls0 v ts) = procEdge ks0 ls0 where
-	answerLess = (Nothing, Nothing, Just e) -- if ks0 < ls0
-	answerMore = (Just e, Nothing, Nothing) -- if ks0 > ls0 
-	procEdge (k:ks) (l:ls) = case compare k l of
-		LT	-> answerLess
-		EQ	-> procEdge ks ls
-		GT	-> answerMore
-	procEdge (k:ks) [] = case splitLookupAlg (splitEdge f ks) k ts of
-		(tsL, ans, tsR)	-> (guardNullEdge $ edge ls0 Nothing tsL, ans, guardNullEdge $ edge ls0 v tsR)
-	procEdge [] (l:ls) = answerLess
-	procEdge [] [] 
-		| Just v <- v, (vL, ans, vR) <- f v
-			= (fmap (\ v' -> edge ls0 (Just v') emptyAlg) vL, ans, 
-				guardNullEdge $ edge ls0 vR ts)
-		| otherwise	= answerLess -- all children of e match ks0 initially but are longer, and v is Nothing
-		
diff --git a/TrieMap/Reflection.hs b/TrieMap/Reflection.hs
--- a/TrieMap/Reflection.hs
+++ b/TrieMap/Reflection.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, UndecidableInstances #-}
 
 module TrieMap.Reflection where
 
@@ -11,21 +11,37 @@
 import qualified TrieMap.TrieAlgebraic as TA
 
 instance Algebraic v => Algebraic (Elem v) where
-	type Alg (Elem v) = Alg v
+	type AlgRep (Elem v) = AlgRep v
 	toAlg (Elem v) = toAlg v
 	fromAlg v = Elem (fromAlg v)
 
-instance Algebraic (m1 (m2 v)) => Algebraic (ProdMap m1 m2 v) where
-	type Alg (ProdMap m1 m2 v) = Alg (m1 (m2 v))
-	toAlg (PMap m) = toAlg m
-	fromAlg = PMap . fromAlg
+-- instance Algebraic (t1 k (m2 v)) => Algebraic (ProdMap m1 m2 v) where
+-- 	type AlgRep (ProdMap m1 m2 v) = AlgRep (m1 (m2 v))
+-- 	toAlg (PMap m) = toAlg m
+-- 	fromAlg = PMap . fromAlg
+-- 
+-- instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
+-- 	type AlgRep (RadixTrie k m v) = AlgRep [([k], v)]
+-- 	toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m))
+-- 	fromAlg = fromDistAscListAlg . fromAlg
 
-instance (Algebraic (m1 v), Algebraic (m2 v)) => Algebraic (UnionMap m1 m2 v) where
-	type Alg (UnionMap m1 m2 v) = (Alg (m1 v), Alg (m2 v))
-	toAlg (m1 :+: m2) = (toAlg m1, toAlg m2)
-	fromAlg (m1, m2) = fromAlg m1 :+: fromAlg m2
+instance (Algebraic k, TrieKey k m) => SAlgebraicT (RadixTrie k m) where
+	type SAlgRepT (RadixTrie k m) = AlgRepT ([] `O` ((,) [k]))
+	toSAlgT = toAlgT . o . assocsAlg
+	fromSAlgT = fromDistAscListAlg . unO . fromAlgT
 
-instance (Ord k, Algebraic k, Sized v, Algebraic v, TrieKey k m) => Algebraic (RadixTrie k m v) where
-	type Alg (RadixTrie k m v) = Alg [([k], v)]
-	toAlg m = toAlg (build (\ c n -> foldWithKeyAlg (curry c) n m))
-	fromAlg = fromDistAscListAlg . fromAlg
+-- instance (AlgebraicT m, Algebraic k) => SAlgebraicT (Edge k m) where
+-- 	type SAlgRepT (Edge k m) = AlgRepT (O Fix (O ((:*:) (Const Int :*: Co{--}nst [k] :*: AlgRepT m)) (O Const Maybe)))
+
+
+instance (AlgebraicT m, Algebraic k,  Algebraic a) => Algebraic (Edge k m a) where
+	type AlgRep (Edge k m a) = Fix (AlgRepT (Const (Int, [k], Maybe a)) :*: AlgRepT m)
+	toAlg (Edge s ks v ts) = Fix (toAlgT (Const (s, ks, v)) :*: fmap toAlg (toAlgT ts))
+	fromAlg (Fix (a :*: b)) = case (fromAlgT a, fmap fromAlg b) of
+		(Const (s, ks, v), ts) ->
+			Edge s ks v (fromAlgT ts)
+
+instance (AlgebraicT m, Algebraic k, Algebraic a) => Algebraic (RadixTrie k m a) where
+	type AlgRep (RadixTrie k m a) = AlgRep (Maybe (Edge k m a))
+	toAlg (Radix e) = toAlg e
+	fromAlg = Radix . fromAlg
diff --git a/TrieMap/TrieAlgebraic.hs b/TrieMap/TrieAlgebraic.hs
--- a/TrieMap/TrieAlgebraic.hs
+++ b/TrieMap/TrieAlgebraic.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances #-}
-
-module TrieMap.TrieAlgebraic (TrieKey (..), ProdMap (..), UnionMap(..), RadixTrie(..), Edge (..), Ordered (..), unionMaybe, intersectMaybe, differenceMaybe, mapWithKeyAlg, assocsAlg, insertAlg, alterAlg, fromListAlg') where
+{-# LANGUAGE TypeFamilies, FlexibleInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, PatternGuards, IncoherentInstances, TypeOperators #-}
+module TrieMap.TrieAlgebraic where
 
+import Control.Arrow ((***))
 import Data.Traversable
 import Data.Foldable
 import Data.Either
@@ -15,8 +15,7 @@
 import qualified Data.Map as Map
 
 import Control.Monad
-import Control.Applicative hiding (Alternative(..))
-
+import Control.Applicative hiding (Alternative(..), Const(..))
 import GHC.Exts (build)
 
 import TrieMap.Applicative
@@ -33,33 +32,77 @@
 instance Functor Ordered where
 	fmap f (Ord x) = Ord (f x)
 
+type L a = Fix (Const () :+: (Const a :*: Id))
+
+class EqT f => TrieKeyT f t | f -> t, t -> f where
+	compareKeyT :: TrieKey k m => f k -> f k -> Ordering
+	emptyT :: (Sized a, TrieKey k m) => t k m a
+	nullT :: (Sized a, TrieKey k m) => t k m a -> Bool
+	guardNullT :: (Sized a, TrieKey k m) => t k m a -> Maybe (t k m a)
+	sizeT :: (Sized a, TrieKey k m) => t k m a -> Int
+	getSingleT :: (Sized a, TrieKey k m) => t k m a -> Maybe (f k, a)
+	alterLookupT :: (Sized a, TrieKey k m) =>
+		(Maybe a -> (b, Maybe a)) -> f k -> t k m a -> (b, t k m a)
+	lookupT :: (Sized a, TrieKey k m) => f k -> t k m a -> Maybe a
+	foldWithKeyT :: (TrieKey k m) => (f k -> a -> b -> b) -> b -> t k m a -> b
+	mapAppT :: (Applicative g, Sized a, Sized b, TrieKey k m) =>
+		(f k -> a -> g b) -> t k m a -> g (t k m b)
+	mapMaybeT :: (Sized a, Sized b, TrieKey k m) =>
+		(f k -> a -> Maybe b) -> t k m a -> t k m b
+	mapEitherT :: (Sized a, Sized b, Sized c, TrieKey k m) => 
+		(f k -> a -> (Maybe b, Maybe c)) -> t k m a -> (t k m b, t k m c)
+	unionT :: (Sized a, TrieKey k m) => (f k -> a -> a -> Maybe a) -> t k m a -> t k m a -> t k m a
+	intersectT :: (Sized a, Sized b, Sized c, TrieKey k m) =>
+		(f k -> a -> b -> Maybe c) -> t k m a -> t k m b -> t k m c
+	differenceT :: (Sized a, Sized b, TrieKey k m) => (f k -> a -> b -> Maybe a) -> t k m a -> t k m b -> t k m a
+	fromDistAscListT :: (Sized a, TrieKey k m) => [(f k, a)] -> t k m a
+	fromAscListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
+	fromListT :: (Sized a, TrieKey k m) => (f k -> a -> a -> a) -> [(f k, a)] -> t k m a
+	getMinT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
+	getMaxT :: (Sized a, TrieKey k m) => t k m a -> Maybe ((f k, a), t k m a)
+	updateMinT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
+	updateMaxT :: (Sized a, TrieKey k m) => (f k -> a -> (Bool, Maybe a)) -> t k m a -> (Bool, t k m a)
+	isSubmapT :: (Sized a, Sized b, TrieKey k m) => (a -> b -> Bool) -> t k m a -> t k m b -> Bool
+	splitLookupT :: (Sized a, TrieKey k m) => (a -> (Maybe a, Maybe b, Maybe a)) -> f k -> t k m a -> (t k m a, Maybe b, t k m a)
+
+	guardNullT m
+		| nullT m	= Nothing
+		| otherwise	= Just m
+
+eqKey :: TrieKey k m => k -> k -> Bool
+eqKey a b = compareKey a b == EQ
+
+eqKeyT :: (TrieKey k m, TrieKeyT f t) => f k -> f k -> Bool
+eqKeyT a b = compareKeyT a b == EQ
+
 -- | TrieKey defines a bijection between map types and algebraic key types.
-class (Eq a, Foldable m, Traversable m) => TrieKey a m | a -> m, m -> a where
-	emptyAlg :: Sized v => m v
-	nullAlg :: Sized v => m v -> Bool
-	sizeAlg :: Sized v => m v -> Int
-	getSingleAlg :: Sized v => m v -> Maybe (a, v)
-	guardNullAlg :: Sized v => m v -> Maybe (m v)
+class Eq k => TrieKey k m | k -> m, m -> k where
+	compareKey :: k -> k -> Ordering
+	emptyAlg :: Sized a => m a
+	nullAlg :: Sized a => m a -> Bool
+	sizeAlg :: Sized a => m a -> Int
+	getSingleAlg :: Sized a => m a -> Maybe (k, a)
+	guardNullAlg :: Sized a => m a -> Maybe (m a)
 -- 	{-# SPECIALIZE alterAlg :: Sized v => (Maybe v -> Id (b, Maybe v)) -> a -> m v -> Id (b, m v) #-}
-	alterLookupAlg :: Sized v => (Maybe v -> (b, Maybe v)) -> a -> m v -> (b, m v)
-	lookupAlg :: Sized v => a -> m v -> Maybe v
-	foldWithKeyAlg :: Sized v => (a -> v -> x -> x) -> x -> m v -> x
-	mapAppAlg :: (Applicative f, Sized v, Sized w) => (a -> v -> f w) -> m v -> f (m w)
-	mapMaybeAlg :: (Sized v, Sized w) => (a -> v -> Maybe w) -> m v -> m w
-	mapEitherAlg :: (Sized v, Sized x, Sized y) => (a -> v -> Either x y) -> m v -> (m x, m y)
-	unionMaybeAlg :: Sized v => (a -> v -> v -> Maybe v) -> m v -> m v -> m v
-	intersectAlg :: (Sized v, Sized w, Sized x) => (a -> v -> w -> Maybe x) -> m v -> m w -> m x
-	differenceAlg :: (Sized v, Sized w) => (a -> v -> w -> Maybe v) -> m v -> m w -> m v
-	fromDistAscListAlg :: Sized v => [(a, v)] -> m v
-	fromAscListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v
-	fromListAlg :: Sized v => (a -> v -> v -> v) -> [(a, v)] -> m v
-	getMinAlg :: Sized v => m v -> Maybe ((a, v), m v)
-	getMaxAlg :: Sized v => m v -> Maybe ((a, v), m v)
-	updateMinAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
-	updateMaxAlg :: Sized v => (a -> v -> (Bool, Maybe v)) -> m v -> (Bool, m v)
-	valid :: Sized v =>  m v -> Bool
-	isSubmapAlg :: (Sized v, Sized w) => (v -> w -> Bool) -> m v -> m w -> Bool
-	splitLookupAlg :: (Sized v) => (v -> (Maybe v, Maybe x, Maybe v)) -> a -> m v -> (m v, Maybe x, m v)
+	alterLookupAlg :: Sized a => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)
+	lookupAlg :: Sized a => k -> m a -> Maybe a
+	foldWithKeyAlg :: (k -> a -> b -> b) -> b -> m a -> b
+	mapAppAlg :: (Applicative f, Sized a, Sized b) => (k -> a -> f b) -> m a -> f (m b)
+	mapMaybeAlg :: (Sized a, Sized b) => (k -> a -> Maybe b) -> m a -> m b
+	mapEitherAlg :: (Sized a, Sized b, Sized c) => (k -> a -> (Maybe b, Maybe c)) -> m a -> (m b, m c)
+	unionMaybeAlg :: Sized a => (k -> a -> a -> Maybe a) -> m a -> m a -> m a
+	intersectAlg :: (Sized a, Sized b, Sized c) => (k -> a -> b -> Maybe c) -> m a -> m b -> m c
+	differenceAlg :: (Sized a, Sized b) => (k -> a -> b -> Maybe a) -> m a -> m b -> m a
+	fromDistAscListAlg :: Sized a => [(k, a)] -> m a
+	fromAscListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
+	fromListAlg :: Sized a => (k -> a -> a -> a) -> [(k, a)] -> m a
+	getMinAlg :: Sized a => m a -> Maybe ((k, a), m a)
+	getMaxAlg :: Sized a => m a -> Maybe ((k, a), m a)
+	updateMinAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
+	updateMaxAlg :: Sized a => (k -> a -> (Bool, Maybe a)) -> m a -> (Bool, m a)
+	valid :: Sized a =>  m a -> Bool
+	isSubmapAlg :: (Sized a, Sized b) => (a -> b -> Bool) -> m a -> m b -> Bool
+	splitLookupAlg :: (Sized a) => (a -> (Maybe a, Maybe b, Maybe a)) -> k -> m a -> (m a, Maybe b, m a)
 
 	lookupAlg k = fst . alterLookupAlg (\ v -> (v, v)) k
 	guardNullAlg m
@@ -73,24 +116,52 @@
 	fromAscListAlg _ [] = emptyAlg
 	fromAscListAlg f ((k, v):xs) = fromDistAscListAlg (distinct k v xs) where
 		distinct k v ((k', v'):xs)
-			| k == k'	= distinct k (f k v v') xs
+			| k `eqKey` k'	= distinct k (f k v v') xs
 			| otherwise	= (k, v):distinct k' v' xs
 		distinct k v [] = [(k, v)]
 	fromDistAscListAlg = fromListAlg'
-	sizeAlg = foldl' (\ n _ -> n + 1) 0
+	sizeAlg = foldWithKeyAlg (\ _ x n -> n + getSize x) 0
 
 	updateMinAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMinAlg m)
 	updateMaxAlg f m = maybe (False, m) (\ ((k, v), m') -> maybe m' (\ v' -> insertAlg k v' m) <$> f k v) (getMaxAlg m)
 	valid = (`seq` True)
 
-instance (TrieKey k m, Sized a) => Sized (m a) where
-	{-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (ProdMap m1 m2 a) #-}
-	{-# SPECIALIZE instance (Sized a, TrieKey k1 m1, TrieKey k2 m2) => Sized (UnionMap m1 m2 a) #-}
-	{-# SPECIALIZE instance Sized a => Sized (Maybe a) #-}
-	{-# SPECIALIZE instance Sized a => Sized (IntMap a) #-}
-	{-# SPECIALIZE instance (Ord k, Sized a) => Sized (Map k a) #-}
+instance TrieKeyT f t => TrieKey (Fix f) (FixMap f t) where
+	compareKey (Fix a) (Fix b) = compareKeyT a b
+	emptyAlg = FixMap emptyT
+	nullAlg (FixMap m) = nullT m
+	sizeAlg (FixMap m) = sizeT m
+	getSingleAlg (FixMap m) = do
+		(k, v) <- getSingleT m
+		return (Fix k, v)
+	lookupAlg (Fix k) (FixMap m) = lookupT k m
+	alterLookupAlg f (Fix k) (FixMap m) = FixMap <$> alterLookupT f k m
+	foldWithKeyAlg f z (FixMap m) = foldWithKeyT (f . Fix) z m
+	mapAppAlg f (FixMap m) = FixMap <$> mapAppT (f . Fix) m
+	mapMaybeAlg f (FixMap m) = FixMap (mapMaybeT (f . Fix) m)
+	mapEitherAlg f (FixMap m) = case mapEitherT (f . Fix) m of
+		(mL, mR) -> (FixMap mL, FixMap mR)
+	unionMaybeAlg f (FixMap m1) (FixMap m2) = FixMap (unionT (f . Fix) m1 m2)
+	intersectAlg f (FixMap m1) (FixMap m2) = FixMap (intersectT (f . Fix) m1 m2)
+	differenceAlg f (FixMap m1) (FixMap m2) = FixMap (differenceT (f . Fix) m1 m2)
+	getMinAlg (FixMap m) = do
+		(~(k, v), m') <- getMinT m
+		return ((Fix k, v), FixMap m')
+	getMaxAlg (FixMap m) = do
+		(~(k, v), m') <- getMaxT m
+		return ((Fix k, v), FixMap m')
+	updateMinAlg f (FixMap m) = FixMap <$> updateMinT (f . Fix) m
+	updateMaxAlg f (FixMap m) = FixMap <$> updateMaxT (f . Fix) m
+	isSubmapAlg (<=) (FixMap m1) (FixMap m2) = isSubmapT (<=) m1 m2
+	splitLookupAlg f (Fix k) (FixMap m) = case splitLookupT f k m of
+		(mL, ans, mR) -> (FixMap mL, ans, FixMap mR)
+
+instance (Sized a, TrieKey k m) => Sized (m a) where
 	getSize = sizeAlg
 
+instance (Sized a, TrieKey k m, TrieKeyT f t) => Sized (t k m a) where
+	getSize = sizeT
+
 fromListAlg' :: (Sized v, TrieKey k m) => [(k, v)] -> m v
 fromListAlg' = fromListAlg (const const)
 
@@ -100,15 +171,30 @@
 mapWithKeyAlg :: (Sized v, Sized w, TrieKey k m) => (k -> v -> w) -> m v -> m w
 mapWithKeyAlg f m = unId (mapAppAlg (\ k v -> Id (f k v)) m)
 
+mapWithKeyT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (f k -> v -> w) -> t k m v -> t k m w
+mapWithKeyT f m = unId (mapAppT (\ k v -> Id (f k v)) m)
+
+mapAlg :: (Sized v, Sized w, TrieKey k m) => (v -> w) -> m v -> m w
+mapAlg = mapWithKeyAlg . const
+
+mapT :: (Sized v, Sized w, TrieKeyT f t, TrieKey k m) => (v -> w) -> t k m v -> t k m w
+mapT = mapWithKeyT . const
+
 -- mapMaybeWithKeyAlg :: TrieKey k m => (k -> v -> Maybe w) -> m v -> m w
 -- mapMaybeWithKeyAlg f m = unId (mapAppMaybeAlg (\ k v -> Id (f k v)) m)
 
 insertAlg :: (Sized v, TrieKey k m) => k -> v -> m v -> m v
 insertAlg k v = alterAlg (const (Just v)) k
 
+insertT :: (Sized v, TrieKey k m, TrieKeyT f t) => f k -> v -> t k m v -> t k m v
+insertT k v = alterT (const (Just v)) k
+
 alterAlg :: (Sized v, TrieKey k m) => (Maybe v -> Maybe v) -> k -> m v -> m v
 alterAlg f k = snd . alterLookupAlg (\ x -> ((), f x)) k
 
+alterT :: (Sized v, TrieKey k m, TrieKeyT f t) => (Maybe v -> Maybe v) -> f k -> t k m v -> t k m v
+alterT f k = snd . alterLookupT (\ x -> ((), f x)) k
+
 -- alterLookupAlg :: TrieKey k m => (Maybe a -> (b, Maybe a)) -> k -> m a -> (b, m a)
 -- alterLookupAlg f = unId .: alterAppAlg (Id . f)
 
@@ -138,131 +224,480 @@
 filterRight _ _ = Nothing
 
 {-# INLINE assocsAlg #-}
-assocsAlg :: (Sized a, TrieKey k m) => m a -> [(k, a)]
+assocsAlg :: (TrieKey k m) => m a -> [(k, a)]
 assocsAlg m = build (\ c n -> foldWithKeyAlg (\ k v xs -> (k,v) `c` xs) n m)
 
-instance (Eq a1, Eq a2, TrieKey a1 m1, TrieKey a2 m2) => TrieKey (a1, a2) (m1 `ProdMap` m2) where
-	emptyAlg = PMap emptyAlg
-	nullAlg (PMap m) = nullAlg m
-	sizeAlg (PMap m) = sizeAlg m
-	getSingleAlg (PMap m) = do	(k1, m') <- getSingleAlg m
-					(k2, v) <- getSingleAlg m'
-					return ((k1, k2), v)
-	alterLookupAlg f (k1, k2) (PMap m) = PMap <$> alterLookupAlg g k1 m
-		where g = fmap guardNullAlg . alterLookupAlg f k2 . fromMaybe emptyAlg
-	lookupAlg (k1, k2) (PMap m) = lookupAlg k1 m >>= lookupAlg k2
-	foldWithKeyAlg f z (PMap m) = foldWithKeyAlg (\ k1 -> flip (foldWithKeyAlg (\ k2 -> f (k1, k2)))) z m
-	mapAppAlg f (PMap m) =
-		PMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m
-	mapMaybeAlg f (PMap m) =
-		PMap $ mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m
-	mapEitherAlg f (PMap m) = (PMap (fmap (\ (Elem (mL, _)) -> mL) m'), PMap (fmap (\ (Elem (_, mR)) -> mR) m'))
-		where	m' = mapWithKeyAlg (\ k1 -> Elem . mapEitherAlg (\ k2 -> f (k1, k2))) m
-	unionMaybeAlg f (PMap m1) (PMap m2) = 
-		PMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2)
-	intersectAlg f (PMap m1) (PMap m2) =
-		PMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2)
-	differenceAlg f (PMap m1) (PMap m2) =
-		PMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)
-	fromListAlg f xs = PMap $ mapWithKeyAlg (\ k1 (Elem xs) -> fromListAlg (\ k2 -> f (k1, k2)) xs) $
-		fromListAlg (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs]
-	fromDistAscListAlg xs = PMap $ fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst xs]		
-	fromAscListAlg f xs = PMap $ fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst xs]
-	getMinAlg (PMap m) = do
-		((k1, m'), m1') <- getMinAlg m
-		((k2, v), m2') <- getMinAlg m'
-		return (((k1, k2), v), PMap (maybe m1' (\ m2' -> insertAlg k1 m2' m) (guardNullAlg m2')))
-	getMaxAlg (PMap m) = do
-		((k1, m'), m1') <- getMaxAlg m
-		((k2, v), m2') <- getMaxAlg m'
-		return (((k1, k2), v), PMap (maybe m1' (\ m2' -> insertAlg k1 m2' m) (guardNullAlg m2')))
-	updateMinAlg f (PMap m) = 
-		PMap <$> updateMinAlg (\ k1 -> guardNullAlg <.> updateMinAlg (\ k2 -> f (k1, k2))) m
-	updateMaxAlg f (PMap m) =
-		PMap <$> updateMaxAlg (\ k1 -> guardNullAlg <.> updateMaxAlg (\ k2 -> f (k1, k2))) m
-	isSubmapAlg (<=) (PMap m1) (PMap m2) =
-		isSubmapAlg (isSubmapAlg (<=)) m1 m2
-		
-	splitLookupAlg f (k1, k2) (PMap m) = case splitLookupAlg g k1 m of
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :*: f2) (t1 `ProdMap` t2) where
+	compareKeyT (a :*: x) (b :*: y) = compareKeyT a b `mappend` compareKeyT x y
+	emptyT = PMap emptyT
+	nullT (PMap m) = nullT m
+	sizeT (PMap m) = sizeT m
+	getSingleT (PMap m) = do
+		(k1, m') <- getSingleT m
+		(k2, v) <- getSingleT m'
+		return (k1 :*: k2, v)
+	lookupT (k1 :*: k2) (PMap m) = lookupT k1 m >>= lookupT k2
+	alterLookupT f (k1 :*: k2) (PMap m) = PMap <$> alterLookupT g k1 m where
+		g = fmap guardNullT . alterLookupT f k2 . fromMaybe emptyT
+	foldWithKeyT f z (PMap m) = foldWithKeyT (\ k1 -> flip (foldWithKeyT (\ k2 -> f (k1 :*: k2)))) z m
+	mapAppT f (PMap m) = PMap <$> mapAppT (\ k1 -> mapAppT (\ k2 -> f (k1 :*: k2))) m
+	mapMaybeT f (PMap m) = PMap (mapMaybeT (\ k1 -> guardNullT . mapMaybeT (\ k2 -> f (k1 :*: k2))) m)
+	mapEitherT f (PMap m) = (PMap *** PMap) (mapEitherT (\ k1 -> (guardNullT *** guardNullT) . mapEitherT (\ k2 -> f (k1 :*: k2))) m)
+	unionT f (PMap m1) (PMap m2) = PMap (unionT (\ k1 -> guardNullT .: unionT (\ k2 -> f (k1 :*: k2))) m1 m2)
+	intersectT f (PMap m1) (PMap m2) = PMap (intersectT (\ k1 -> guardNullT .: intersectT (\ k2 -> f (k1 :*: k2))) m1 m2)
+	differenceT f (PMap m1) (PMap m2) = PMap (differenceT (\ k1 -> guardNullT .: differenceT (\ k2 -> f (k1 :*: k2))) m1 m2)
+	fromListT f xs = PMap $ mapWithKeyT (\ k1 (Elem xs) -> fromListT (\ k2 -> f (k1 :*:  k2)) xs) $
+		fromListT (\ _ (Elem x) (Elem y) -> Elem (x ++ y)) [(k1, Elem [(k2, v)]) | ((k1 :*: k2), v) <- xs]
+	fromDistAscListT xs = PMap $ fromDistAscListT [(k1, fromDistAscListT ys) | (k1, ys) <- breakFst eqKeyT xs]	
+	fromAscListT f xs = PMap $ fromDistAscListT [(k1, fromAscListT (\ k2 -> f (k1 :*: k2)) ys) | (k1, ys) <- breakFst eqKeyT xs]
+	getMinT (PMap m) = do
+		((k1, m'), m1') <- getMinT m
+		((k2, v), m2') <- getMinT m'
+		return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
+	getMaxT (PMap m) = do
+		((k1, m'), m1') <- getMaxT m
+		((k2, v), m2') <- getMaxT m'
+		return ((k1 :*: k2, v), PMap (maybe m1' (\ m2' -> insertT k1 m2' m) (guardNullT m2')))
+	updateMinT f (PMap m) = 
+		PMap <$> updateMinT (\ k1 -> guardNullT <.> updateMinT (\ k2 -> f (k1 :*: k2))) m
+	updateMaxT f (PMap m) =
+		PMap <$> updateMaxT (\ k1 -> guardNullT <.> updateMaxT (\ k2 -> f (k1 :*: k2))) m
+	isSubmapT (<=) (PMap m1) (PMap m2) =
+		isSubmapT (isSubmapT (<=)) m1 m2
+	splitLookupT f (k1 :*: k2) (PMap m) = case splitLookupT g k1 m of
 			(mL, ans, mR)	-> (PMap mL, ans, PMap mR)
-		where g m' = case splitLookupAlg f k2 m' of
-			(mL, ans, mR)	-> (guardNullAlg mL, ans, guardNullAlg mR)
+		where g m' = case splitLookupT f k2 m' of
+			(mL, ans, mR)	-> (guardNullT mL, ans, guardNullT mR)
 
-	valid (PMap m) = valid m && all valid m && not (any nullAlg m)
+instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :*: f2) k) (ProdMap t1 t2 k m) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
 
-breakFst :: (Eq k1, Eq k2) => [((k1, k2), v)] -> [(k1, [(k2, v)])]
-breakFst [] = []
-breakFst (((k1, k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where
-	breakFst' k xs (((k', k2), x):xss)
-		| k == k'	= breakFst' k ((Seq.|>) xs (k2, x)) xss
+breakFst :: (f1 k -> f1 k -> Bool) -> [((f1 :*: f2) k, v)] -> [(f1 k, [(f2 k, v)])]
+breakFst _ [] = []
+breakFst eq (((k1 :*: k2), x):xs) = breakFst' k1 (Seq.singleton (k2, x)) xs where
+	breakFst' k xs (((k' :*: k2), x):xss)
+		| k `eq` k'	= breakFst' k ((Seq.|>) xs (k2, x)) xss
 		| otherwise	= (k, toList xs):breakFst' k' (Seq.singleton (k2, x)) xss
 	breakFst' k xs [] = [(k, toList xs)]
 
-instance (TrieKey a1 m1, TrieKey a2 m2) => TrieKey (Either a1 a2) (m1 `UnionMap` m2) where
-	emptyAlg = emptyAlg :+: emptyAlg
-	nullAlg (m1 :+: m2) = nullAlg m1 && nullAlg m2
-	sizeAlg (m1 :+: m2) = sizeAlg m1 + sizeAlg m2
-	getSingleAlg (m1 :+: m2) = case (getSingleAlg m1, getSingleAlg m2) of
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 :+: f2) (UnionMap t1 t2) where
+	compareKeyT (A a) (A b) = compareKeyT a b
+	compareKeyT (B x) (B y) = compareKeyT x y
+	compareKeyT A{} B{} = LT
+	compareKeyT B{} A{} = GT
+	emptyT = UMap emptyT emptyT
+	nullT (UMap m1 m2) = nullT m1 && nullT m2
+	getSingleT (UMap m1 m2) = case (getSingleT m1, getSingleT m2) of
+		(Just (k, v), Nothing)	-> Just (A k, v)
+		(Nothing, Just (k, v))	-> Just (B k, v)
+		_			-> Nothing
+	sizeT (UMap m1 m2) = sizeT m1 + sizeT m2
+	lookupT (A k) (UMap m1 _) = lookupT k m1
+	lookupT (B k) (UMap _ m2) = lookupT k m2
+	alterLookupT f (A k) (UMap m1 m2) = (`UMap` m2) <$> alterLookupT f k m1
+	alterLookupT f (B k) (UMap m1 m2) = UMap m1 <$> alterLookupT f k m2
+	foldWithKeyT f z (UMap m1 m2) = foldWithKeyT (f . A) (foldWithKeyT (f . B) z m2) m1
+	mapAppT f (UMap m1 m2) = UMap <$> mapAppT (f . A) m1 <*> mapAppT (f . B) m2
+	mapMaybeT f (UMap m1 m2) = UMap (mapMaybeT (f . A) m1) (mapMaybeT (f . B) m2)
+	mapEitherT f (UMap m1 m2) = (UMap m1L m2L, UMap m1R m2R)
+		where	(m1L, m1R) = mapEitherT (f . A) m1
+			(m2L, m2R) = mapEitherT (f . B) m2
+	unionT f (UMap m11 m12) (UMap m21 m22) = 
+		UMap (unionT (f . A) m11 m21) (unionT (f . B) m12 m22)
+	intersectT f (UMap m11 m12) (UMap m21 m22) =
+		UMap (intersectT (f . A) m11 m21) (intersectT (f . B) m12 m22)
+	differenceT f (UMap m11 m12) (UMap m21 m22) =
+		UMap (differenceT (f . A) m11 m21) (differenceT (f . B) m12 m22)
+	getMinT (UMap m1 m2) 
+		| Just ~(~(k, v), m1') <- getMinT m1
+			= Just ((A k, v), UMap m1' m2)
+		| Just ~(~(k, v), m2') <- getMinT m2
+			 = Just ((B k, v), UMap m1 m2')
+		| otherwise = Nothing
+	getMaxT (UMap m1 m2)
+		| Just ~(~(k, v), m2') <- getMaxT m2
+			= Just ((B k, v), UMap m1 m2')
+		| Just ~(~(k, v), m1') <- getMaxT m1
+			= Just ((A k, v), UMap m1' m2)
+		| otherwise = Nothing
+	updateMinT f (UMap m1 m2)
+		| nullT m1	= UMap m1 <$> updateMinT (f . B) m2
+		| otherwise	= (`UMap` m2) <$> updateMinT (f . A) m1
+	updateMaxT f (UMap m1 m2)
+		| nullT m2	= (`UMap` m2) <$> updateMaxT (f . A) m1
+		| otherwise	= UMap m1 <$> updateMaxT (f . B) m2
+	fromDistAscListT xs = UMap (fromDistAscListT ys) (fromDistAscListT zs)
+		where	(ys, zs) = partitionEithers' (map pullEither xs)
+	fromAscListT f xs = UMap (fromAscListT (f . A) ys) (fromAscListT (f . B) zs) 
+		where	(ys, zs) = partitionEithers' (map pullEither xs)
+	fromListT f xs = UMap (fromListT (f . A) ys) (fromListT (f . B) zs)
+		where	(ys, zs) = partitionEithers' (map pullEither xs)
+	isSubmapT (<=) (UMap m11 m12) (UMap m21 m22) = isSubmapT (<=) m11 m21 && isSubmapT (<=) m12 m22
+	splitLookupT f (A k) (UMap m1 m2) = case splitLookupT f k m1 of
+		(m1L, ans, m1R)	-> (UMap m1L emptyT, ans, UMap m1R m2)
+	splitLookupT f (B k) (UMap m1 m2) = case splitLookupT f k m2 of
+		(m2L, ans, m2R)	-> (UMap m1 m2L, ans, UMap emptyT m2R)
+
+instance (Eq (f1 k), Eq (f2 k), TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 :+: f2) k) (UnionMap t1 t2 k m) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
+
+instance TrieKey k m => TrieKeyT ((,) k) (CProdMap m) where
+	compareKeyT (a, x) (b, y) = compareKey a b `mappend` compareKey x y
+	emptyT = CPMap emptyAlg
+	nullT (CPMap m) = nullAlg m
+	getSingleT (CPMap m) = do
+		(k1, m') <- getSingleAlg m
+		(k2, v) <- getSingleAlg m'
+		return ((k1, k2), v)
+	guardNullT (CPMap m) = CPMap <$> guardNullAlg m
+	sizeT (CPMap m) = sizeAlg m
+	lookupT (k1, k2) (CPMap m) = lookupAlg k1 m >>= lookupAlg k2
+	alterLookupT f (k1, k2) (CPMap m) = CPMap <$> alterLookupAlg g k1 m where
+		g = guardNullAlg <.> alterLookupAlg f k2 . fromMaybe emptyAlg
+	foldWithKeyT f z (CPMap m) = foldWithKeyAlg (\ k1 -> flip $ foldWithKeyAlg (\ k2 -> f (k1, k2))) z m
+	mapAppT f (CPMap m) = CPMap <$> mapAppAlg (\ k1 -> mapAppAlg (\ k2 -> f (k1, k2))) m
+	mapMaybeT f (CPMap m) = CPMap (mapMaybeAlg (\ k1 -> guardNullAlg . mapMaybeAlg (\ k2 -> f (k1, k2))) m)
+	mapEitherT f (CPMap m) = (CPMap *** CPMap) (mapEitherAlg (\ k1 -> (guardNullAlg *** guardNullAlg) . mapEitherAlg (\ k2 -> f (k1, k2))) m)
+	unionT f (CPMap m1) (CPMap m2) =
+		CPMap (unionMaybeAlg (\ k1 -> guardNullAlg .: unionMaybeAlg (\ k2 -> f (k1, k2))) m1 m2)
+	intersectT f (CPMap m1) (CPMap m2) =
+		CPMap (intersectAlg (\ k1 -> guardNullAlg .: intersectAlg (\ k2 -> f (k1, k2))) m1 m2)
+	differenceT f (CPMap m1) (CPMap m2) = 
+		CPMap (differenceAlg (\ k1 -> guardNullAlg .: differenceAlg (\ k2 -> f (k1, k2))) m1 m2)
+	getMinT (CPMap m) = do
+		((k1, m1), m') <- getMinAlg m
+		((k2, v), m1') <- getMinAlg m1
+		return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMinAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))
+	getMaxT (CPMap m) = do
+		((k1, m1), m') <- getMaxAlg m
+		((k2, v), m1') <- getMaxAlg m1
+		return (((k1, k2), v), CPMap $ maybe m' (\ m1' -> snd $ updateMaxAlg (\ _ _ -> (False, Just m1')) m) (guardNullAlg m1'))	
+	updateMinT f (CPMap m) = 
+		CPMap <$> updateMinAlg (\ k1 -> guardNullAlg <.> updateMinAlg (\ k2 -> f (k1, k2))) m
+	updateMaxT f (CPMap m) =
+		CPMap <$> updateMaxAlg (\ k1 -> guardNullAlg <.> updateMaxAlg (\ k2 -> f (k1, k2))) m
+	isSubmapT (<=) (CPMap m1) (CPMap m2) = isSubmapAlg (isSubmapAlg (<=)) m1 m2
+	splitLookupT f (k1, k2) (CPMap m) = case splitLookupAlg g k1 m of
+		(mL, ans, mR)	-> (CPMap mL, ans, CPMap mR)
+		where g m = case splitLookupAlg f k2 m of
+			(mL, ans, mR)	-> (guardNullAlg mL, ans, guardNullAlg mR)
+	fromDistAscListT xs = CPMap (fromDistAscListAlg [(k1, fromDistAscListAlg ys) | (k1, ys) <- breakFst' (==) xs])
+	fromAscListT f xs = CPMap (fromDistAscListAlg [(k1, fromAscListAlg (\ k2 -> f (k1, k2)) ys) | (k1, ys) <- breakFst' (==) xs])
+	fromListT f xs = CPMap (mapWithKeyAlg (\ k1 (Elem ys) -> fromListAlg (\ k2 -> f (k1, k2)) ys) $
+		fromListAlg (\ _ (Elem ys) (Elem zs) -> Elem (ys ++ zs)) [(k1, Elem [(k2, v)]) | ((k1, k2), v) <- xs])
+
+breakFst' :: (k1 -> k1 -> Bool) -> [((k1, k2), v)] -> [(k1, [(k2, v)])]
+breakFst' _ [] = []
+breakFst' eq (((k1, k2), x):xs) = breakFst'' k1 (Seq.singleton (k2, x)) xs where
+	breakFst'' k xs (((k', k2), x):xss)
+		| k `eq` k'	= breakFst'' k ((Seq.|>) xs (k2, x)) xss
+		| otherwise	= (k, toList xs):breakFst'' k' (Seq.singleton (k2, x)) xss
+	breakFst'' k xs [] = [(k, toList xs)]
+
+instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (k1, k2) (CProdMap m1 k2 m2) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
+
+instance TrieKey k m => TrieKeyT (Either k) (CUnionMap m) where
+	{-# SPECIALIZE instance TrieKeyT (Either ()) (CUnionMap Maybe) #-}
+	compareKeyT (Left a) (Left b) = compareKey a b
+	compareKeyT (Right a) (Right b) = compareKey a b
+	compareKeyT Left{} Right{} = LT
+	compareKeyT Right{} Left{} = GT
+	emptyT = CUMap emptyAlg emptyAlg
+	nullT (CUMap m1 m2) = nullAlg m1 && nullAlg m2
+	sizeT (CUMap m1 m2) = sizeAlg m1 + sizeAlg m2
+	getSingleT (CUMap m1 m2) = case (getSingleAlg m1, getSingleAlg m2) of
 		(Just (k, v), Nothing)	-> Just (Left k, v)
 		(Nothing, Just (k, v))	-> Just (Right k, v)
 		_			-> Nothing
-	alterLookupAlg f (Left k) (m1 :+: m2) = 
-		(:+: m2) <$> alterLookupAlg f k m1
-	alterLookupAlg f (Right k) (m1 :+: m2) =
-		(m1 :+:) <$> alterLookupAlg f k m2
-	lookupAlg k (m1 :+: m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k
-	foldWithKeyAlg f z (m1 :+: m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1
-	mapAppAlg f (m1 :+: m2) = 
-		liftA2 (:+:) (mapAppAlg (f . Left) m1) (mapAppAlg (f . Right) m2)
-	mapMaybeAlg f (m1 :+: m2) = mapMaybeAlg (f . Left) m1 :+: mapMaybeAlg  (f . Right) m2
-	mapEitherAlg f (m1 :+: m2) = (m1L :+: m2L, m1R :+: m2R)
+	lookupT k (CUMap m1 m2) = either (`lookupAlg` m1) (`lookupAlg` m2) k
+	alterLookupT f (Left k) (CUMap m1 m2) = (`CUMap` m2) <$> alterLookupAlg f k m1
+	alterLookupT f (Right k) (CUMap m1 m2) = CUMap m1 <$> alterLookupAlg f k m2
+	foldWithKeyT f z (CUMap m1 m2) = foldWithKeyAlg (f . Left) (foldWithKeyAlg (f . Right) z m2) m1
+	mapAppT f (CUMap m1 m2) = CUMap <$> mapAppAlg (f . Left) m1 <*> mapAppAlg (f . Right) m2
+	mapMaybeT f (CUMap m1 m2) = CUMap (mapMaybeAlg (f . Left) m1) (mapMaybeAlg (f . Right) m2)
+	mapEitherT f (CUMap m1 m2) = (CUMap m1L m2L, CUMap m1R m2R)
 		where	(m1L, m1R) = mapEitherAlg (f . Left) m1
 			(m2L, m2R) = mapEitherAlg (f . Right) m2
-	unionMaybeAlg f (m11 :+: m12) (m21 :+: m22)
-		= unionMaybeAlg (f . Left) m11 m21 :+: unionMaybeAlg (f . Right) m12 m22
-	intersectAlg f (m11 :+: m12) (m21 :+: m22)
-		= intersectAlg (f . Left) m11 m21 :+: intersectAlg (f . Right) m12 m22
-	differenceAlg f (m11 :+: m12) (m21 :+: m22)
-		= differenceAlg (f . Left) m11 m21 :+: differenceAlg (f . Right) m12 m22
-	fromListAlg f xs = fromListAlg (f . Left) ys :+: fromListAlg (f . Right) zs
-		where	(ys, zs) = partitionEithers (map pullEither xs)
-	fromAscListAlg f xs = fromAscListAlg (f . Left) ys :+: fromAscListAlg (f . Right) zs
-		where	(ys, zs) = partitionEithers (map pullEither xs)
-	fromDistAscListAlg xs = fromDistAscListAlg ys :+: fromDistAscListAlg zs
-		where	(ys, zs) = partitionEithers (map pullEither xs)
-	getMinAlg (m1 :+: m2)
-		| Just ((k, v), m1') <- getMinAlg m1
-			= Just ((Left k, v), m1' :+: m2)
-		| Just ((k, v), m2') <- getMinAlg m2
-			= Just ((Right k, v), m1 :+: m2')
-	getMinAlg _ = Nothing
-	getMaxAlg (m1 :+: m2) = getFirst $ First
-		(do	((k, v), m2') <- getMaxAlg m2
-			return ((Right k, v), m1 :+: m2')) `mappend` First
-		(do	((k, v), m1') <- getMaxAlg m1
-			return ((Left k, v), m1' :+: m2))
-	updateMinAlg f (m1 :+: m2)
-		| nullAlg m1	= fmap (m1 :+:) (updateMinAlg (f . Right) m2)
-		| otherwise	= fmap (:+: m2) (updateMinAlg (f . Left) m1)
-	updateMaxAlg f (m1 :+: m2)
-		| nullAlg m2	= fmap (:+: m2) (updateMaxAlg (f . Left) m1)
-		| otherwise	= fmap (m1 :+:) (updateMaxAlg (f . Right) m2)
-	isSubmapAlg (<=) (m11 :+: m12) (m21 :+: m22) =
+	unionT f (CUMap m11 m12) (CUMap m21 m22) = 
+		CUMap (unionMaybeAlg (f . Left) m11 m21) (unionMaybeAlg (f . Right) m12 m22)
+	intersectT f (CUMap m11 m12) (CUMap m21 m22) =
+		CUMap (intersectAlg (f . Left) m11 m21) (intersectAlg (f . Right) m12 m22)
+	differenceT f (CUMap m11 m12) (CUMap m21 m22) = 
+		CUMap (differenceAlg (f . Left) m11 m21) (differenceAlg (f . Right) m12 m22)
+	isSubmapT (<=) (CUMap m11 m12) (CUMap m21 m22) = 
 		isSubmapAlg (<=) m11 m21 && isSubmapAlg (<=) m12 m22
-	valid (m1 :+: m2) = valid m1 && valid m2
-	splitLookupAlg f (Left k) (m1 :+: m2) = case splitLookupAlg f k m1 of
-		(m1L, ans, m1R)	-> (m1L :+: emptyAlg, ans, m1R :+: m2)
-	splitLookupAlg f (Right k) (m1 :+: m2) = case splitLookupAlg f k m2 of
-		(m2L, ans, m2R)	-> (m1 :+: m2L, ans, emptyAlg :+: m2R)
+	splitLookupT f (Left k) (CUMap m1 m2) = case splitLookupAlg f k m1 of
+		(m1L, ans, m1R)	-> (CUMap m1L emptyAlg, ans, CUMap m1R m2)
+	splitLookupT f (Right k) (CUMap m1 m2) = case splitLookupAlg f k m2 of
+		(m2L, ans, m2R)	-> (CUMap m1 m2L, ans, CUMap emptyAlg m2R)
+	getMinT (CUMap m1 m2) = case (getMinAlg m1, getMinAlg m2) of
+		(Just ((k, v), m1'), _)	-> Just ((Left k, v), CUMap m1' m2)
+		(_, Just ((k, v), m2'))	-> Just ((Right k, v), CUMap m1 m2')
+		_			-> Nothing
+	getMaxT (CUMap m1 m2) = case (getMaxAlg m1, getMaxAlg m2) of
+		(_, Just ((k, v), m2'))	-> Just ((Right k, v), CUMap m1 m2')
+		(Just ((k, v), m1'), _)	-> Just ((Left k, v), CUMap m1' m2)
+		_			-> Nothing
+	updateMinT f (CUMap m1 m2)
+		| nullAlg m1	= CUMap m1 <$> updateMinAlg (f . Right) m2
+		| otherwise	= (`CUMap` m2) <$> updateMinAlg (f . Left) m1
+	updateMaxT f (CUMap m1 m2)
+		| nullAlg m2	= (`CUMap` m2) <$> updateMaxAlg (f . Left) m1
+		| otherwise	= CUMap m1 <$> updateMaxAlg (f . Right) m2
+	fromListT f xs = CUMap (fromListAlg (f . Left) ys) (fromListAlg (f . Right) zs)
+		where	(ys, zs) = partitionEithers (map pullEither' xs)
+	fromAscListT f xs = CUMap (fromAscListAlg (f . Left) ys) (fromAscListAlg (f . Right) zs)
+		where	(ys, zs) = partitionEithers (map pullEither' xs)
+	fromDistAscListT xs = CUMap (fromDistAscListAlg ys) (fromDistAscListAlg zs) 
+		where	(ys, zs) = partitionEithers (map pullEither' xs)
 
-pullEither :: (Either k1 k2, v) -> Either (k1, v) (k2, v)
-pullEither (Left k, v) = Left (k, v)
-pullEither (Right k, v) = Right (k, v)
+instance (TrieKey k1 m1, TrieKey k2 m2) => TrieKey (Either k1 k2) (CUnionMap m1 k2 m2) where
+	{-# SPECIALIZE instance TrieKey k m => TrieKey (Either () k) (CUnionMap Maybe k m) #-}
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
 
+partitionEithers' :: [Either a b] -> ([a], [b])
+partitionEithers' = foldr part ([], []) where
+	part (Left x) (xs, ys) = (x:xs, ys)
+	part (Right y) (xs, ys) = (xs, y:ys)
+
+pullEither :: ((f1 :+: f2) k, v) -> Either (f1 k, v) (f2 k, v)
+pullEither (A k, v) = Left (k, v)
+pullEither (B k, v) = Right (k, v)
+
+pullEither' :: (Either k1 k2, v) -> Either (k1, v) (k2, v)
+pullEither' (Left k, v) = Left (k, v)
+pullEither' (Right k, v) = Right (k, v)
+
+instance TrieKey k m => TrieKeyT (Const k) (ConstMap m) where
+	compareKeyT (Const a) (Const b) = compareKey a b
+	emptyT = ConstMap emptyAlg
+	nullT (ConstMap m) = nullAlg m
+	sizeT (ConstMap m) = sizeAlg m
+	getSingleT (ConstMap m) = do
+		(k, v) <- getSingleAlg m
+		return (Const k, v)
+	lookupT (Const k) (ConstMap m) = lookupAlg k m
+	alterLookupT f (Const k) (ConstMap m) = ConstMap <$> alterLookupAlg f k m
+	foldWithKeyT f z (ConstMap m) = foldWithKeyAlg (f . Const) z m
+	mapAppT f (ConstMap m) = ConstMap <$> mapAppAlg (f . Const) m
+	mapMaybeT f (ConstMap m) = ConstMap (mapMaybeAlg (f . Const) m)
+	mapEitherT f (ConstMap m) = case mapEitherAlg (f . Const) m of
+		(mL, mR) -> (ConstMap mL, ConstMap mR)
+	unionT f (ConstMap m1) (ConstMap m2) = ConstMap (unionMaybeAlg (f . Const) m1 m2)
+	intersectT f (ConstMap m1) (ConstMap m2) = ConstMap (intersectAlg (f . Const) m1 m2)
+	differenceT f (ConstMap m1) (ConstMap m2) = ConstMap (differenceAlg (f . Const) m1 m2)
+	fromDistAscListT xs = ConstMap (fromDistAscListAlg [(k, v) | (Const k, v) <- xs])
+	fromAscListT f xs = ConstMap (fromAscListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
+	fromListT f xs = ConstMap (fromListAlg (f . Const) [(k, v) | (Const k, v) <- xs])
+	getMinT (ConstMap m) = do
+		(~(k, v), m') <- getMinAlg m
+		return ((Const k, v), ConstMap m')
+	getMaxT (ConstMap m) = do
+		(~(k, v), m') <- getMaxAlg m
+		return ((Const k, v), ConstMap m')
+	updateMinT f (ConstMap m) = ConstMap <$> updateMinAlg (f . Const) m
+	updateMaxT f (ConstMap m) = ConstMap <$> updateMaxAlg (f . Const) m
+	isSubmapT (<=) (ConstMap m1) (ConstMap m2) = isSubmapAlg (<=) m1 m2
+	splitLookupT f (Const k) (ConstMap m) = case splitLookupAlg f k m of
+		(mL, ans, mR) -> (ConstMap mL, ans, ConstMap mR)
+
+instance (TrieKey k m, TrieKey k' m') => TrieKey (Const k k') (ConstMap m k' m') where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
+
+instance TrieKeyT Id IdMap where
+	compareKeyT (Id a) (Id b) = compareKey a b
+	emptyT = IdMap emptyAlg
+	nullT (IdMap m) = nullAlg m
+	sizeT (IdMap m) = sizeAlg m
+	getSingleT (IdMap m) = do
+		(k, v) <- getSingleAlg m
+		return (Id k, v)
+	lookupT (Id k) (IdMap m) = lookupAlg k m
+	alterLookupT f (Id k) (IdMap m) = IdMap <$> alterLookupAlg f k m
+	foldWithKeyT f z (IdMap m) = foldWithKeyAlg (f . Id) z m
+	mapAppT f (IdMap m) = IdMap <$> mapAppAlg (f . Id) m
+	mapMaybeT f (IdMap m) = IdMap (mapMaybeAlg (f . Id) m)
+	mapEitherT f (IdMap m) = case mapEitherAlg (f . Id) m of
+		(mL, mR) -> (IdMap mL, IdMap mR)
+	unionT f (IdMap m1) (IdMap m2) = IdMap (unionMaybeAlg (f . Id) m1 m2)
+	intersectT f (IdMap m1) (IdMap m2) = IdMap (intersectAlg (f . Id) m1 m2)
+	differenceT f (IdMap m1) (IdMap m2) = IdMap (differenceAlg (f . Id) m1 m2)
+	fromDistAscListT xs = IdMap (fromDistAscListAlg [(k, v) | (Id k, v) <- xs])
+	fromAscListT f xs = IdMap (fromAscListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
+	fromListT f xs = IdMap (fromListAlg (f . Id) [(k, v) | (Id k, v) <- xs])
+	getMinT (IdMap m) = do
+		(~(k, v), m') <- getMinAlg m
+		return ((Id k, v), IdMap m')
+	getMaxT (IdMap m) = do
+		(~(k, v), m') <- getMaxAlg m
+		return ((Id k, v), IdMap m')
+	updateMinT f (IdMap m) = IdMap <$> updateMinAlg (f . Id) m
+	updateMaxT f (IdMap m) = IdMap <$> updateMaxAlg (f . Id) m
+	isSubmapT (<=) (IdMap m1) (IdMap m2) = isSubmapAlg (<=) m1 m2
+	splitLookupT f (Id k) (IdMap m) = case splitLookupAlg f k m of
+		(mL, ans, mR) -> (IdMap mL, ans, IdMap mR)
+
+instance TrieKey k m => TrieKey (Id k) (IdMap k m) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT
+
+-- instance (Sized k, TrieKey k m) => TrieKey (SizeElem k) (SizedMap k m) where
+-- 	compareKey (SElem a) (SElem b) = compareKey a b
+-- 	emptyAlg = SizedMap emptyAlg
+-- 	nullAlg (SizedMap m) = nullAlg m
+-- 	sizeAlg (SizedMap m) = sizeAlg m
+-- 	getSingleAlg (SizedMap m) = do
+-- 		(k, v) <- getSingleAlg m
+-- 		return (SElem k, v)
+-- 	lookupAlg (SElem k) (SizedMap m) = lookupAlg k m
+-- 	alterLookupAlg f (SElem k) (SizedMap m) = SizedMap <$> alterLookupAlg f k m
+-- 	foldWithKeyAlg f z (SizedMap m) = foldWithKeyAlg (f . SElem) z m
+-- 	mapAppAlg f (SizedMap m) = SizedMap <$> mapAppAlg (f . SElem) m
+-- 	mapMaybeAlg f (SizedMap m) = SizedMap (mapMaybeAlg (f . SElem) m)
+-- 	mapEitherAlg f (SizedMap m) = case mapEitherAlg (f . SElem) m of
+-- 		(mL, mR) -> (SizedMap mL, SizedMap mR)
+-- 	unionMaybeAlg f (SizedMap m1) (SizedMap m2) = SizedMap (unionMaybeAlg (f . SElem) m1 m2)
+-- 	intersectAlg f (SizedMap m1) (SizedMap m2) = SizedMap (intersectAlg (f . SElem) m1 m2)
+-- 	differenceAlg f (SizedMap m1) (SizedMap m2) = SizedMap (differenceAlg (f . SElem) m1 m2)
+-- 	fromDistAscListAlg xs = SizedMap (fromDistAscListAlg [(k, v) | (SElem k, v) <- xs])
+-- 	fromAscListAlg f xs = SizedMap (fromAscListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
+-- 	fromListAlg f xs = SizedMap (fromListAlg (f . SElem) [(k, v) | (SElem k, v) <- xs])
+-- 	getMinAlg (SizedMap m) = do
+-- 		(~(k, v), m') <- getMinAlg m
+-- 		return ((SElem k, v), SizedMap m')
+-- 	getMaxAlg (SizedMap m) = do
+-- 		(~(k, v), m') <- getMaxAlg m
+-- 		return ((SElem k, v), SizedMap m')
+-- 	updateMinAlg f (SizedMap m) = SizedMap <$> updateMinAlg (f . SElem) m
+-- 	updateMaxAlg f (SizedMap m) = SizedMap <$> updateMaxAlg (f . SElem) m
+-- 	isSubmapAlg (<=) (SizedMap m1) (SizedMap m2) = isSubmapAlg (<=) m1 m2
+-- 	splitLookupAlg f (SElem k) (SizedMap m) = case splitLookupAlg f k m of
+-- 		(mL, ans, mR) -> (SizedMap mL, ans, SizedMap mR)
+
 instance TrieKey Int IntMap where
+	compareKey = compare
 	emptyAlg = IMap.empty
 	nullAlg = IMap.null
-	sizeAlg = foldl' (\ n x -> n + getSize x) 0
 	getSingleAlg m
 		| IMap.size m == 1, [(k, v)] <- IMap.toList m
 			= Just (k, v)
@@ -273,7 +708,7 @@
 	foldWithKeyAlg = IMap.foldWithKey
 	mapAppAlg = sequenceA .: IMap.mapWithKey
 	mapMaybeAlg = IMap.mapMaybeWithKey
-	mapEitherAlg = IMap.mapEitherWithKey
+	mapEitherAlg f m = (IMap.mapMaybeWithKey (fst .: f) m, IMap.mapMaybeWithKey (snd .: f) m)
 	unionMaybeAlg f m1 m2 = IMap.mapMaybe (either Just id) (IMap.unionWithKey g (fmap Left m1) (fmap Left m2)) where
 		g k (Left v1) (Left v2) = Right (f k v1 v2)
 		g k (Right v) _ = Right v
@@ -300,9 +735,10 @@
 			(vL, ans, vR)	-> (maybe mL (flip (IMap.insert k) mL) vL, ans, maybe mR (flip (IMap.insert k) mR) vR)
 
 instance Ord k => TrieKey (Ordered k) (Map k) where
+	compareKey = compare
 	emptyAlg = Map.empty
 	nullAlg = Map.null
-	sizeAlg = foldl' (\ n x -> n + getSize x) 0
+-- 	sizeAlg = foldl' (\ n x -> n + getSize x) 0
 	getSingleAlg m
 		| Map.size m == 1, (k, v) <- Map.findMin m
 			= Just (Ord k, v)
@@ -312,7 +748,7 @@
 	foldWithKeyAlg f = Map.foldWithKey (f . Ord)
 	mapAppAlg f = sequenceA . Map.mapWithKey (f . Ord)
  	mapMaybeAlg f = Map.mapMaybeWithKey (f . Ord)
-	mapEitherAlg f = Map.mapEitherWithKey (f . Ord)
+	mapEitherAlg f m = (Map.mapMaybeWithKey (fst .: f . Ord) m, Map.mapMaybeWithKey (snd .: f . Ord) m)
 	unionMaybeAlg f m1 m2 = Map.mapMaybe (either Just id) (Map.unionWithKey g (fmap Left m1) (fmap Left m2)) where
 		g k (Left v1) (Left v2) = Right (f (Ord k) v1 v2)
 		g k (Right v) _ = Right v
@@ -322,9 +758,9 @@
 	fromListAlg f xs = Map.fromListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
 	fromAscListAlg f xs = Map.fromAscListWithKey (f . Ord) [(k, v) | (Ord k, v) <- xs]
 	fromDistAscListAlg xs = Map.fromDistinctAscList [(k, v) | (Ord k, v) <- xs]
-	getMinAlg m = do	~(~(k, v), m') <- Map.minViewWithKey m
+	getMinAlg m = do	(~(k, v), m') <- Map.minViewWithKey m
 				return ((Ord k, v), m')
-	getMaxAlg m = do	~(~(k, v), m') <- Map.maxViewWithKey m
+	getMaxAlg m = do	(~(k, v), m') <- Map.maxViewWithKey m
 				return ((Ord k, v), m')
 	updateMinAlg f m
 		| Map.null m	= (False, m)
@@ -341,6 +777,7 @@
 			(vL, ans, vR) -> (maybe mL (flip (Map.insert k) mL) vL, ans, maybe mR (flip (Map.insert k) mR) vR) 
 
 instance TrieKey () Maybe where
+	compareKey _ _ = EQ
 	emptyAlg = Nothing
 	nullAlg = isNothing
 	sizeAlg = maybe 0 getSize
@@ -350,10 +787,7 @@
 	foldWithKeyAlg f = foldr (f ())
 	mapAppAlg f = traverse (f ())
 	mapMaybeAlg f = (>>= f ())
-	mapEitherAlg _ Nothing = (Nothing, Nothing)
-	mapEitherAlg f (Just v) = case f () v of
-		Left v	-> (Just v, Nothing)
-		Right v	-> (Nothing, Just v)
+	mapEitherAlg f = maybe (Nothing, Nothing) (f ())
 	unionMaybeAlg f = unionMaybe (f ())
 	intersectAlg f = intersectMaybe (f ())
 	differenceAlg f = differenceMaybe (f ())
@@ -372,10 +806,93 @@
 	isSubmapAlg (<=) (Just x) (Just y) = x <= y
 	splitLookupAlg f _ = maybe (Nothing, Nothing, Nothing) f
 
-first :: (a -> c) -> (a, b) -> (c, b)
-first f (x, y) = (f x, y)
-
 {-# RULES
 	"sizeAlg/Map/Elem" forall (m :: Map k (Elem v)) . sizeAlg m = Map.size m;
 	"sizeAlg/IMap/Elem" forall (m :: IntMap (Elem v)) . sizeAlg m = IMap.size m;
 	#-}
+
+instance (TrieKeyT f t, TrieKey k m) => TrieKey (App f k) (App (t k m)) where
+	compareKey (App a) (App b) = compareKeyT a b
+	emptyAlg = App emptyT
+	nullAlg (App m) = nullT m
+	getSingleAlg (App m) = do
+		(k, v) <- getSingleT m
+		return (App k, v)
+	alterLookupAlg f (App k) (App m) = App <$> alterLookupT f k m
+	foldWithKeyAlg f z (App m) = foldWithKeyT (f . App) z m
+	mapAppAlg f (App m) = App <$> mapAppT (f . App) m
+	mapMaybeAlg f (App m) = App (mapMaybeT (f . App) m)
+	mapEitherAlg f (App m) = (App *** App) (mapEitherT (f . App) m)
+	fromListAlg f xs = App (fromListT (f . App) [(k, v) | (App k, v) <- xs])
+	fromAscListAlg f xs = App (fromAscListT (f . App) [(k, v) | (App k, v) <- xs])
+	fromDistAscListAlg xs = App (fromDistAscListT [(k, v) | (App k, v) <- xs])
+	unionMaybeAlg f (App m1) (App m2) = App (unionT (f . App) m1 m2)
+	intersectAlg f (App m1) (App m2) = App (intersectT (f . App) m1 m2)
+	differenceAlg f (App m1) (App m2) = App (differenceT (f . App) m1 m2)
+	getMinAlg (App m) = do
+		((k, v), m') <- getMinT m
+		return ((App k, v), App m')
+	getMaxAlg (App m) = do
+		((k, v), m') <- getMaxT m
+		return ((App k, v), App m')
+	updateMinAlg f (App m) = App <$> updateMinT (f . App) m
+	updateMaxAlg f (App m) = App <$> updateMaxT (f . App) m
+	isSubmapAlg (<=) (App m1) (App m2) = isSubmapT (<=) m1 m2
+	splitLookupAlg f (App k) (App m) = case splitLookupT f k m of
+		(mL, ans, mR)	-> (App mL, ans, App mR)
+
+instance (TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKeyT (f1 `O` f2) (CompMap t1 f2 t2) where
+	compareKeyT (O a) (O b) = compareKeyT a b
+	emptyT = CompMap emptyT
+	nullT (CompMap m) = nullT m
+	guardNullT (CompMap m) = CompMap <$> guardNullT m
+	sizeT (CompMap m) = sizeT m
+	getSingleT (CompMap m) = do
+		(k, v) <- getSingleT m
+		return (O k, v)
+	lookupT (O k) (CompMap m) = lookupT k m
+	alterLookupT f (O k) (CompMap m) = CompMap <$> alterLookupT f k m
+	foldWithKeyT f z (CompMap m) = foldWithKeyT (f . O) z m
+	mapAppT f (CompMap m) = CompMap <$> mapAppT (f . O) m
+	mapMaybeT f (CompMap m) = CompMap (mapMaybeT (f . O) m)
+	mapEitherT f (CompMap m) = (CompMap *** CompMap) (mapEitherT (f . O) m)
+	unionT f (CompMap m1) (CompMap m2) = CompMap (unionT (f . O) m1 m2)
+	intersectT f (CompMap m1) (CompMap m2) = CompMap (intersectT (f . O) m1 m2)
+	differenceT f (CompMap m1) (CompMap m2) = CompMap (differenceT (f . O) m1 m2)
+	fromDistAscListT xs = CompMap (fromDistAscListT [(k, v) | (O k, v) <- xs])
+	fromAscListT f xs = CompMap (fromAscListT (f . O) [(k, v) | (O k, v) <- xs])
+	fromListT f xs = CompMap (fromListT (f . O) [(k, v) | (O k, v) <- xs])
+	getMinT (CompMap m) = do
+		((k, v), m') <- getMinT m
+		return ((O k, v), CompMap m')
+	getMaxT (CompMap m) = do
+		((k, v), m') <- getMaxT m
+		return ((O k, v), CompMap m')
+	updateMinT f (CompMap m) = CompMap <$> updateMinT (f . O) m
+	updateMaxT f (CompMap m) = CompMap <$> updateMaxT (f . O) m
+	isSubmapT (<=) (CompMap m1) (CompMap m2) = isSubmapT (<=) m1 m2
+	splitLookupT f (O k) (CompMap m) = case splitLookupT f k m of
+		(mL, ans, mR)	-> (CompMap mL, ans, CompMap mR)
+
+instance (TrieKey k m, TrieKeyT f1 t1, TrieKeyT f2 t2) => TrieKey ((f1 `O` f2) k) (CompMap t1 f2 t2 k m) where
+	compareKey = compareKeyT
+	emptyAlg = emptyT
+	nullAlg = nullT
+	getSingleAlg = getSingleT
+	guardNullAlg = guardNullT
+	sizeAlg = sizeT
+	lookupAlg = lookupT
+	alterLookupAlg = alterLookupT
+	mapAppAlg = mapAppT
+	mapMaybeAlg = mapMaybeT
+	mapEitherAlg = mapEitherT
+	foldWithKeyAlg = foldWithKeyT
+	unionMaybeAlg = unionT
+	intersectAlg = intersectT
+	differenceAlg = differenceT
+	getMinAlg = getMinT
+	getMaxAlg = getMaxT
+	updateMinAlg = updateMinT
+	updateMaxAlg = updateMaxT
+	isSubmapAlg = isSubmapT
+	splitLookupAlg = splitLookupT