diff --git a/demo/Main.hs b/demo/Main.hs
--- a/demo/Main.hs
+++ b/demo/Main.hs
@@ -40,13 +40,12 @@
     store s t
 
   prTrees trees values = do
-    tnum <- readIORef trees >>= return . Map.size
-    tsum <- readIORef trees >>= return . sum . map (Map.size . third) . Map.elems
+    trMap <- readIORef trees
+    let tnum = Map.size trMap
+        tsum = sum $ map (Map.size . snd) $ Map.elems trMap
     vsum <- readIORef values >>= return . Map.size
     putStrLn $ show (tsum+vsum) ++ " (" ++ show tnum ++ "," ++ show tsum
                ++ "," ++ show vsum ++ ")"
-
-  third (_,_,x) = x
 
 -- |The typical way of storing key/value maps in SQL is to use a relational
 -- table, like this:
diff --git a/src/Data/StableTree/Persist.hs b/src/Data/StableTree/Persist.hs
--- a/src/Data/StableTree/Persist.hs
+++ b/src/Data/StableTree/Persist.hs
@@ -74,9 +74,9 @@
 -- |Write appropriate functions here to load and store primitive parts of
 -- trees.
 data Store m e k v = Store
-  { loadTree   :: Id -> m (Either e (Depth, ValueCount, Map k Id))
+  { loadTree   :: Id -> m (Either e (Depth, Map k Id))
   , loadValue  :: Id -> m (Either e v)
-  , storeTree  :: Id -> Depth -> ValueCount -> Map k Id -> m (Maybe e)
+  , storeTree  :: Id -> Depth -> Map k (ValueCount, Id) -> m (Maybe e)
   , storeValue :: Id -> v -> m (Maybe e)
   }
 
@@ -93,8 +93,8 @@
       -> ExceptT e m (StableTree k v)
 load' storage treeId =
   liftEither (loadTree storage treeId) >>= \case
-    (0, _, contents)     -> loadBottom contents
-    (depth, _, contents) -> loadBranch depth contents
+    (0, contents)     -> loadBottom contents
+    (depth, contents) -> loadBranch depth contents
   where
   loadBottom contents = do
     vals <- loadValues contents Map.empty
@@ -172,16 +172,16 @@
     key_ids <- storeSubtrees complete Map.empty
     case mIncomplete of
       Nothing -> storeKeyIds key_ids
-      Just (k,v) -> do
+      Just (k,c,v) -> do
         treeId <- store' storage v
-        storeKeyIds $ Map.insert k treeId key_ids
+        storeKeyIds $ Map.insert k (c,treeId) key_ids
 
   storeSubtrees kvmap accum =
     case Map.minViewWithKey kvmap of
       Nothing -> return accum
-      Just ((k,t), rest) -> do
+      Just ((k,(c,t)), rest) -> do
         treeId <- store' storage t
-        storeSubtrees rest $ Map.insert k treeId accum
+        storeSubtrees rest $ Map.insert k (c,treeId) accum
 
   storeBottom kvmap = do
     key_ids <- storeValues kvmap Map.empty
@@ -193,13 +193,12 @@
       Just ((k,v), rest) -> do
         let valId = calcId $ build v
         _ <- liftMaybe $ storeValue storage valId v
-        storeValues rest $ Map.insert k valId accum
+        storeValues rest $ Map.insert k (1,valId) accum
 
   storeKeyIds key_ids =
     let depth = getDepth tree
-        vcount = getValueCount tree
-        valId = treeHash depth key_ids
-    in do liftMaybe $ storeTree storage valId depth vcount key_ids
+        valId = treeHash depth $ Map.map snd key_ids
+    in do liftMaybe $ storeTree storage valId depth key_ids
           return valId
 
 treeHash :: Build k => Int -> Map k Id -> Id
diff --git a/src/Data/StableTree/Persist/Ram.hs b/src/Data/StableTree/Persist/Ram.hs
--- a/src/Data/StableTree/Persist/Ram.hs
+++ b/src/Data/StableTree/Persist/Ram.hs
@@ -28,7 +28,7 @@
 
 -- |Create a new RAM store
 storage :: IO ( Store IO RamError k v
-              , IORef (Map Id (Int,Int,Map k Id))
+              , IORef (Map Id (Int,Map k (Int,Id)))
               , IORef (Map Id v) )
 storage = do
   trees  <- newIORef Map.empty
@@ -41,7 +41,8 @@
     m <- readIORef store
     case Map.lookup tid m of
       Nothing -> return $ Left $ NoTree tid
-      Just tup -> return $ Right tup
+      Just (depth, children) ->
+        return $ Right (depth, Map.map snd children)
 
   lv store vid = do
     m <- readIORef store
@@ -49,8 +50,8 @@
       Nothing -> return $ Left $ NoVal vid
       Just v -> return $ Right v
 
-  st store tid depth vcount tree = do
-    modifyIORef store $ Map.insert tid (depth,vcount,tree)
+  st store tid depth tree = do
+    modifyIORef store $ Map.insert tid (depth,tree)
     return Nothing
 
   sv store vid val = do
diff --git a/src/Data/StableTree/Types.hs b/src/Data/StableTree/Types.hs
--- a/src/Data/StableTree/Types.hs
+++ b/src/Data/StableTree/Types.hs
@@ -104,11 +104,10 @@
          -> Tree Complete k v
 
   Branch :: Depth
-         -> ValueCount
-         -> (SomeKey k, Tree Complete k v)
-         -> (SomeKey k, Tree Complete k v)
-         -> Map (Key Nonterminal k) (Tree Complete k v)
-         -> (Key Terminal k, Tree Complete k v)
+         -> (SomeKey k, ValueCount, Tree Complete k v)
+         -> (SomeKey k, ValueCount, Tree Complete k v)
+         -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)
+         -> (Key Terminal k, ValueCount, Tree Complete k v)
          -> Tree Complete k v
 
   -- Either an empty or a singleton tree
@@ -123,24 +122,21 @@
 
   -- A strut to lift an incomplete tree to the next level up
   IBranch0 :: Depth
-           -> ValueCount
-           -> (SomeKey k, Tree Incomplete k v)
+           -> (SomeKey k, ValueCount, Tree Incomplete k v)
            -> Tree Incomplete k v
 
   -- A joining of a single complete and maybe an incomplete
   IBranch1 :: Depth
-           -> ValueCount
-           -> (SomeKey k, Tree Complete k v)
-           -> Maybe (SomeKey k, Tree Incomplete k v)
+           -> (SomeKey k, ValueCount, Tree Complete k v)
+           -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)
            -> Tree Incomplete k v
 
   -- A branch that doesn't have a terminal, and that might have an IBranch
   IBranch2 :: Depth
-           -> ValueCount
-           -> (SomeKey k, Tree Complete k v)
-           -> (SomeKey k, Tree Complete k v)
-           -> Map (Key Nonterminal k) (Tree Complete k v)
-           -> Maybe (SomeKey k, Tree Incomplete k v)
+           -> (SomeKey k, ValueCount, Tree Complete k v)
+           -> (SomeKey k, ValueCount, Tree Complete k v)
+           -> Map (Key Nonterminal k) (ValueCount, Tree Complete k v)
+           -> Maybe (SomeKey k, ValueCount, Tree Incomplete k v)
            -> Tree Incomplete k v
 
 -- |Wrap up some of a k/v map into a 'Tree'. A 'Right' result gives a complete
@@ -186,10 +182,9 @@
     Nothing -> 
       case mIncomplete of
         Nothing       -> Left $ IBottom0 Nothing
-        Just (ik, iv) -> Left $ IBranch0 depth (getValueCount iv) (wrap ik, iv)
+        Just (ik, iv) -> Left $ IBranch0 depth (wrap ik, getValueCount iv, iv)
     Just ((k,v), Nothing) ->
-      let vcount = getValueCount v + maybe 0 (getValueCount . snd) mIncomplete
-      in Left $ IBranch1 depth vcount (wrap k,v) $ wrapMKey mIncomplete
+      Left $ IBranch1 depth (wrap k, getValueCount v, v) $ wrapMKey mIncomplete
     Just (f1, Just (f2, remain)) ->
       go (wrapKey f1) (wrapKey f2) Map.empty remain
 
@@ -198,24 +193,14 @@
     let popd = Map.minViewWithKey remain >>= return . first wrapKey
     in case popd of
       Nothing ->
-        let vcount = (getValueCount . snd) f1
-                   + (getValueCount . snd) f2
-                   + sum (map getValueCount $ Map.elems accum)
-                   + maybe 0 (getValueCount . snd) mIncomplete
-        in Left $ IBranch2 depth vcount f1 f2 accum $ wrapMKey mIncomplete
-      Just ((SomeKey_T term,v), remain') ->
-        let vcount = (getValueCount . snd) f1
-                   + (getValueCount . snd) f2
-                   + sum (map getValueCount $ Map.elems accum)
-                   + getValueCount v
-        in Right ( Branch depth vcount f1 f2 accum (term, v), remain' )
-      Just ((SomeKey_N nonterm,v), remain') ->
-        go f1 f2 (Map.insert nonterm v accum) remain'
+        Left $ IBranch2 depth f1 f2 accum $ wrapMKey mIncomplete
+      Just ((SomeKey_T term,c,v), remain') ->
+        Right ( Branch depth f1 f2 accum (term, c, v), remain' )
+      Just ((SomeKey_N nonterm,c,v), remain') ->
+        go f1 f2 (Map.insert nonterm (c,v) accum) remain'
 
-  wrapKey :: IsKey k => (k,v) -> (SomeKey k, v)
-  wrapKey = first wrap
+  wrapKey (k,v) = (wrap k, getValueCount v, v)
 
-  wrapMKey :: IsKey k => Maybe (k,v) -> Maybe (SomeKey k, v)
   wrapMKey = (>>=return . wrapKey)
 
   depth = case Map.elems branches of
@@ -236,58 +221,65 @@
 -- returns Nothing.
 getKey :: Tree c k v -> Maybe k
 getKey (Bottom (k,_) _ _ _)       = Just $ unwrap k
-getKey (Branch _ _ (k,_) _ _ _)   = Just $ unwrap k
 getKey (IBottom0 Nothing)         = Nothing
 getKey (IBottom0 (Just (k,_)))    = Just $ unwrap k
 getKey (IBottom1 (k,_) _ _)       = Just $ unwrap k
-getKey (IBranch0 _ _ (k,_))       = Just $ unwrap k
-getKey (IBranch1 _ _ (k,_) _)     = Just $ unwrap k
-getKey (IBranch2 _ _ (k,_) _ _ _) = Just $ unwrap k
+getKey (Branch _ (k,_,_) _ _ _)   = Just $ unwrap k
+getKey (IBranch0 _ (k,_,_))       = Just $ unwrap k
+getKey (IBranch1 _ (k,_,_) _)     = Just $ unwrap k
+getKey (IBranch2 _ (k,_,_) _ _ _) = Just $ unwrap k
 
 -- |Get the key of the fist entry in this complete branch. This function is
 -- total.
 completeKey :: Tree Complete k v -> k
 completeKey (Bottom (k,_) _ _ _)     = unwrap k
-completeKey (Branch _ _ (k,_) _ _ _)   = unwrap k
+completeKey (Branch _ (k,_,_) _ _ _)   = unwrap k
 
 -- |Convert an entire Tree into a k/v map.
 treeContents :: Ord k => Tree c k v -> Map k v
 treeContents t =
   case branchContents t of
     Left ( completes, Nothing) ->
-      Map.unions $ map treeContents $ Map.elems completes
-    Left ( completes, Just (_k, iv)) ->
-      Map.unions $ treeContents iv:map treeContents (Map.elems completes)
+      Map.unions $ map (treeContents . snd) $ Map.elems completes
+    Left ( completes, Just (_k, _c, iv)) ->
+      Map.unions $ treeContents iv:map (treeContents . snd) (Map.elems completes)
     Right x -> x
 
 -- |Get the number of levels of branches that live below this one
 getDepth :: Tree c k v -> Depth
 getDepth (Bottom _ _ _ _)       = 0
-getDepth (Branch d _ _ _ _ _)   = d
+getDepth (Branch d _ _ _ _)   = d
 getDepth (IBottom0 _)           = 0
 getDepth (IBottom1 _ _ _)       = 0
-getDepth (IBranch0 d _ _)       = d
-getDepth (IBranch1 d _ _ _)     = d
-getDepth (IBranch2 d _ _ _ _ _) = d
+getDepth (IBranch0 d _)       = d
+getDepth (IBranch1 d _ _)     = d
+getDepth (IBranch2 d _ _ _ _) = d
 
 -- |Get the number of actual values that live below this branch
 getValueCount :: Tree c k v -> ValueCount
-getValueCount (Bottom _ _ m _)       = 3 + Map.size m
-getValueCount (Branch _ c _ _ _ _)   = c
+getValueCount (Bottom _ _ m _) = 3 + Map.size m
 getValueCount (IBottom0 Nothing)     = 0
 getValueCount (IBottom0 _)           = 1
 getValueCount (IBottom1 _ _ m)       = 2 + Map.size m
-getValueCount (IBranch0 _ c _)       = c
-getValueCount (IBranch1 _ c _ _)     = c
-getValueCount (IBranch2 _ c _ _ _ _) = c
 
+getValueCount (Branch _ (_,c1,_) (_,c2,_) nterm (_,c3,_)) =
+  c1 + c2 + c3 + sum (map fst $ Map.elems nterm)
+getValueCount (IBranch0 _ (_,c,_)) =
+  c
+getValueCount (IBranch1 _ (_,c,_) Nothing) =
+  c
+getValueCount (IBranch1 _ (_,c1,_) (Just (_,c2,_))) =
+  c1+c2
+getValueCount (IBranch2 _ (_,c1,_) (_,c2,_) m i) =
+  c1 + c2 + sum (map fst $ Map.elems m) + maybe 0 (\(_,c3,_)->c3) i
+
 -- |Non-recursive function to simply get the immediate children of the given
 -- branch. This will either give the key/value map of a Bottom, or the key/tree
 -- map of a non-bottom branch.
 branchContents :: Ord k
                => Tree c k v
-               -> Either ( Map k (Tree Complete k v)
-                         , Maybe (k, Tree Incomplete k v))
+               -> Either ( Map k (ValueCount, Tree Complete k v)
+                         , Maybe (k, ValueCount, Tree Incomplete k v))
                          ( Map k v )
 branchContents (Bottom (k1,v1) (k2,v2) terms (kt,vt)) =
   let terms' = Map.mapKeys fromKey terms
@@ -296,11 +288,11 @@
              $ Map.insert (fromKey kt) vt
              terms'
   in Right conts
-branchContents (Branch _d _c (k1,v1) (k2,v2) terms (kt,vt)) =
+branchContents (Branch _d (k1,c1,v1) (k2,c2,v2) terms (kt,ct,vt)) =
   let terms' = Map.mapKeys fromKey terms
-      conts  = Map.insert (unwrap k1) v1
-             $ Map.insert (unwrap k2) v2
-             $ Map.insert (fromKey kt) vt
+      conts  = Map.insert (unwrap k1) (c1,v1)
+             $ Map.insert (unwrap k2) (c2,v2)
+             $ Map.insert (fromKey kt) (ct,vt)
              terms'
   in Left (conts, Nothing)
 branchContents (IBottom0 Nothing) =
@@ -313,25 +305,26 @@
              $ Map.insert (unwrap k2) v2
              terms'
   in Right conts
-branchContents (IBranch0 _d _c incomplete) =
-  Left (Map.empty, Just $ first unwrap incomplete)
-branchContents (IBranch1 _d _c (k1,v1) mIncomplete) =
-  Left (Map.singleton (unwrap k1) v1, mIncomplete >>= return . first unwrap)
-branchContents (IBranch2 _d _c (k1,v1) (k2,v2) terms mIncomplete) =
+branchContents (IBranch0 _d (ik,ic,iv)) =
+  Left (Map.empty, Just (unwrap ik, ic, iv))
+branchContents (IBranch1 _d (k1,c1,v1) mIncomplete) =
+  Left ( Map.singleton (unwrap k1) (c1,v1)
+       , mIncomplete >>= (\(k,c,v) -> return (unwrap k,c,v)))
+branchContents (IBranch2 _d (k1,c1,v1) (k2,c2,v2) terms mIncomplete) =
   let terms' = Map.mapKeys fromKey terms
-      conts  = Map.insert (unwrap k1) v1
-             $ Map.insert (unwrap k2) v2
+      conts  = Map.insert (unwrap k1) (c1,v1)
+             $ Map.insert (unwrap k2) (c2,v2)
              terms'
-  in Left (conts, mIncomplete >>= return . first unwrap)
+  in Left (conts, mIncomplete >>= \(k,c,v) -> return (unwrap k, c, v))
 
 instance (Ord k, Show k, Show v) => Show (Tree c k v) where
   show t@(Bottom _ _ _ _)       = branchShow "Bottom" t
-  show t@(Branch _ _ _ _ _ _)   = branchShow "Branch" t
+  show t@(Branch _ _ _ _ _)   = branchShow "Branch" t
   show t@(IBottom0 _)           = branchShow "IBottom" t
   show t@(IBottom1 _ _ _)       = branchShow "IBottom" t
-  show t@(IBranch0 _ _ _)       = branchShow "IBranch" t
-  show t@(IBranch1 _ _ _ _)     = branchShow "IBranch" t
-  show t@(IBranch2 _ _ _ _ _ _) = branchShow "IBranch" t
+  show t@(IBranch0 _ _)       = branchShow "IBranch" t
+  show t@(IBranch1 _ _ _)     = branchShow "IBranch" t
+  show t@(IBranch2 _ _ _ _ _) = branchShow "IBranch" t
 
 branchShow :: (Ord k, Show k, Show v) => String -> Tree c k v -> String
 branchShow header t =
@@ -340,7 +333,7 @@
       let strs = [show k ++ " => " ++ show v | (k, v) <- Map.toAscList ts]
           str  = intercalate ", " strs
       in header ++ "(" ++ show (getDepth t) ++ ")<" ++ str ++ ">"
-    Left (ts, Just (ik, iv)) ->
+    Left (ts, Just (ik, _ic, iv)) ->
       let strs = [ show k ++ " => " ++ show v | (k, v) <- Map.toAscList ts
                  ] ++ [show ik ++ " => " ++ show iv]
           str  = intercalate ", " strs
diff --git a/stable-tree.cabal b/stable-tree.cabal
--- a/stable-tree.cabal
+++ b/stable-tree.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                stable-tree
-version:             0.3.1
+version:             0.4.0
 synopsis:            Trees whose branches are resistant to change
 -- description:         
 homepage:            https://github.com/tsuraan/stable-tree