diff --git a/fixfile.cabal b/fixfile.cabal
--- a/fixfile.cabal
+++ b/fixfile.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                   fixfile
-version:                0.1.0.0
+version:                0.2.0.0
 synopsis:               File-backed recursive data structures.
 homepage:               https://github.com/revnull/fixfile
 license:                LGPL-3
@@ -35,6 +35,7 @@
                        ,hashtables
                        ,containers
                        ,lens
+                       ,vector
   hs-source-dirs:       src
   default-language:     Haskell2010
   exposed-modules:      Data.FixFile
diff --git a/src/Data/FixFile.hs b/src/Data/FixFile.hs
--- a/src/Data/FixFile.hs
+++ b/src/Data/FixFile.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables, RankNTypes, KindSignatures,
     MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
     FunctionalDependencies, TypeFamilies, UndecidableInstances,
-    DeriveDataTypeable, DeriveGeneric #-}
+    DeriveDataTypeable, DeriveGeneric, ConstraintKinds #-}
 
 {- |
     
@@ -20,7 +20,7 @@
     Transactions are used to ensure safety of the unsafe IO.
 
     The data structures used by a 'FixFile' should not be recursive directly,
-    but should have instances of 'Foldable', 'Traversable', and 'Binary' and
+    but should have instances of 'Typeable', 'Traversable', and 'Binary' and
     should be structured such that the fixed point of the data type is
     recursive.
 
@@ -44,7 +44,9 @@
                      ,para
                      ,iso
                      -- * Root Data
-                     ,Root(..)
+                     ,Fixable
+                     ,FixTraverse(..)
+                     ,Root
                      ,Ptr
                      ,Ref(..)
                      ,ref
@@ -62,7 +64,9 @@
                      ,lookupT
                      ,readTransaction
                      ,writeTransaction
+                     ,writeExceptTransaction
                      ,subTransaction
+                     ,getRoot
                      ,getFull
                      ) where
 
@@ -71,9 +75,8 @@
 import Control.Concurrent.MVar
 import Control.Exception
 import Control.Lens hiding (iso, para)
+import Control.Monad.Except
 import qualified Control.Monad.RWS as RWS
-import Control.Monad.Identity hiding (mapM)
-import Control.Monad.Trans
 import Data.Binary
 import Data.ByteString.Lazy as BSL
 import Data.Dynamic
@@ -82,7 +85,6 @@
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
-import Data.Traversable (mapM)
 import GHC.Generics
 import System.FilePath
 import System.Directory
@@ -219,26 +221,39 @@
 instance Hashable (Ptr f) where
     hashWithSalt x (Ptr y) = hashWithSalt x y
 
+-- | A Constraint for data that can be used with a 'Ref'
+type Fixable f = (Traversable f, Binary (f (Ptr f)), Typeable f)
+
 {- |
-    A 'Root' datastructure acts as a kind of header that can contain one or
-    more 'Ref's to different recursive structures. It takes one argument,
-    which has the kind of @((* -> *) -> *)@. This argument should be either an
-    instance of 'Fixed' or a 'Ptr'. If it is an instance of 'Fixed', then
-    the 'Root' can contain recursive data structures. If it is passed 'Ptr'
-    as an argument, then the 'Root' will contain a non-recursive structure,
-    but can be serialized.
+    'FixTraverse' is a class based on 'Traverse' but taking an argument of kind
+    @(* -> *) -> *)@ instead of @*@.
+-}
+class FixTraverse (t :: ((* -> *) -> *) -> *) where
+    -- | Given a function that maps from @a@ to @b@ over @'Fixable' g@ in the
+    --   'Applicative' @f@, traverse over @t@ changing the fixed-point
+    --   combinator from @a@ to @b@.
+    sequenceAFix :: Applicative f =>
+        (forall g. Fixable g => a g -> f (b g)) -> t a -> f (t b)
 
+{- | 
+    A 'Root' is a datastructure that is an instance of 'FixTraverse' and
+    'Binary'. This acts as a sort of "header" for the file where the 'Root'
+    may have several 'Ref's under it to different 'Functors'.
 -}
-class Root (r :: (((* -> *) -> *) -> *)) where
-    -- | Deserialize @'r' 'Ptr'@ inside a 'Transaction'.
-    readRoot :: r Ptr -> Transaction r' s (r (Stored s))
-    -- | Serialize @'r' 'Ptr'@ inside a 'Transaction'. This will result in
-    -- | changes to any recursive structures to be written as well.
-    writeRoot :: r (Stored s) -> Transaction r' s (r Ptr)
 
-    -- | 'iso', but applied to an instance of 'Root'.
-    rootIso :: (Fixed g, Fixed h) => r g -> r h
+type Root r = (FixTraverse r, Binary (r Ptr))
 
+readRoot :: Root r => r Ptr -> Transaction r' s (r (Stored s))
+readRoot = sequenceAFix readPtr where
+    readPtr p = withHandle $ flip readStoredLazy p
+
+writeRoot :: Root r => r (Stored s) -> Transaction r' s (r Ptr)
+writeRoot = sequenceAFix writeStored where
+    writeStored s = withHandle $ flip sync s
+
+rootIso :: (Root r, Fixed g, Fixed h) => r g -> r h
+rootIso = runIdentity . sequenceAFix (Identity . iso)
+
 {- |
     A 'Ref' is a reference to a 'Functor' 'f' in the 'Fixed' instance of 'g'.
 
@@ -248,13 +263,11 @@
 data Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }
     deriving (Generic)
 
-instance (Typeable f, Binary (f (Ptr f)), Traversable f) => Root (Ref f) where
-    readRoot (Ref p) = Ref <$> (withHandle $ flip readStoredLazy p)
-    writeRoot (Ref a) = Ref <$> (withHandle $ flip sync a)
-    rootIso = Ref . iso . deRef
-
 instance Binary (Ref f Ptr)
 
+instance Fixable f => FixTraverse (Ref f) where
+    sequenceAFix isoT (Ref a) = Ref <$> isoT a
+
 -- | Lens for accessing the value stored in a Ref
 ref :: Lens' (Ref f g) (g f)
 ref = lens (\(Ref a) -> a) (\_ b -> Ref b)
@@ -361,8 +374,7 @@
     Create a 'FixFile', using @'Fix' f@ as the initial structure to store
     at the location described by 'FilePath'.
 -}
-createFixFile :: (Root r, Binary (r Ptr), Typeable r) =>
-    r Fix -> FilePath -> IO (FixFile r)
+createFixFile :: Root r => r Fix -> FilePath -> IO (FixFile r)
 createFixFile initial path =
     openFile path ReadWriteMode >>= createFixFileHandle initial path
 
@@ -371,7 +383,7 @@
     at the location described by 'FilePath' and using the 'Handle' to the
     file to be created.
 -}
-createFixFileHandle :: (Root r, Binary (r Ptr), Typeable r) =>
+createFixFileHandle :: Root r =>
     r Fix -> FilePath -> Handle -> IO (FixFile r)
 createFixFileHandle initial path h = do
     ffh <- FFH <$> newMVar h <*> newMVar M.empty
@@ -435,7 +447,7 @@
     the readTransaction in that the root object stored in the file can
     potentially be updated by this 'Transaction'.
 -}
-writeTransaction :: (Root r, Binary (r Ptr), Typeable r) => 
+writeTransaction :: Root r => 
     FixFile r -> (forall s. Transaction r s a)
     -> IO a
 writeTransaction ff@(FixFile _ ffhmv _) t = res where
@@ -456,6 +468,42 @@
         return a
 
 {- |
+    The 'writeExceptTransaction' function behaves like 'writeTransaction', but
+    applies to a 'Transaction' wrapped in 'ExceptT'. In the event that an
+    exception propagates through the 'Transaction', the updates are not
+    committed to disk.
+
+    This is meant to provide a mechanism for aborting 'Transaction's.
+-}
+writeExceptTransaction :: Root r => 
+    FixFile r -> (forall s. ExceptT e (Transaction r s) a)
+    -> IO (Either e a)
+writeExceptTransaction ff@(FixFile _ ffhmv _) t = res where
+    res = withWriteLock ff runTransaction
+    runTransaction = do
+        (ffh, root) <- readMVar ffhmv
+        let t' = readRoot root >>= RWS.put >> runExceptT t >>= save
+            save l@(Left _) = return l
+            save r@(Right _) = do
+                dr <- RWS.get >>= writeRoot
+                (withHandle $ putRawBlock dr) >>= updateHeader
+                Transaction . RWS.tell . Last . Just $ dr
+                return r
+        (a, root') <- RWS.evalRWST (runRT t') ffh undefined
+        case (a, getLast root') of
+            (Right _, Just root'') -> do
+                void $ swapMVar ffhmv (ffh, root'')
+            _ -> return ()
+        return a
+
+
+{- |
+    Get the root datastructure from the transaction as @r 'Fix'@.
+-}
+getRoot :: Root r => Transaction r s (r Fix)
+getRoot = rootIso <$> RWS.get
+
+{- |
     Get the full datastructure from the transaction as a @'Fix' f@.
 -}
 getFull :: Functor f => Transaction (Ref f) s (Fix f)
@@ -470,8 +518,7 @@
     The memory usage of this operation scales with the recursive depth of the
     structure stored in the file.
 -}
-vacuum :: (Root r, Binary (r Ptr), Typeable r) =>
-    FixFile r -> IO ()
+vacuum :: Root r => FixFile r -> IO ()
 vacuum ff@(FixFile path mv _) = withWriteLock ff runVacuum where
     runVacuum = do
         mval <- takeMVar mv
diff --git a/src/Data/FixFile/BTree.hs b/src/Data/FixFile/BTree.hs
--- a/src/Data/FixFile/BTree.hs
+++ b/src/Data/FixFile/BTree.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable,
-    DeriveDataTypeable #-}
+    DeriveDataTypeable, DataKinds, KindSignatures #-}
 
 {- |
     Module      :  Data.FixFile.BTree
@@ -17,6 +17,7 @@
                           ,createBTreeFile
                           ,openBTreeFile
                           ,empty
+                          ,depth
                           ,insertBTree
                           ,insertBTreeT
                           ,lookupBTree
@@ -25,231 +26,297 @@
                           ,filterBTreeT
                           ,deleteBTree
                           ,deleteBTreeT
+                          ,partitionBTree
                           ,toListBTree
                           ,fromListBTree
                           ) where
 
-import Data.Array
+import Control.Monad.Writer
 import Data.Binary
 import Data.Dynamic
+import qualified Data.Vector as V
 import GHC.Generics
+import GHC.TypeLits
 
 import Data.FixFile
 
 {- |
-    A 'Fixed' @('BTree' k v)@ stores a BTree of key/value pairs.
+    A 'Fixed' @('BTree' n k v)@ stores a BTree of key/value pairs.
+    'n' should be a 'Nat' and will be the maximum number of elements in each
+    branch of the 'BTree'.
 -}
-data BTree k v a =
+data BTree (n :: Nat) k v a =
     Empty
   | Value v
-  | Node Word32 (Array Int (k, a))
+  | Node Word32 (V.Vector (k, a))
     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)
 
-instance (Binary k, Binary v, Binary a) => Binary (BTree k v a)
+instance (Binary k, Binary v, Binary a) => Binary (BTree n k v a) where
+    put Empty = putWord8 0x45
+    put (Value v) = putWord8 0x56 >> put v
+    put (Node d vec) = do
+        putWord8 0x4e
+        put d
+        put (V.length vec)
+        mapM_ put vec
+    get = getWord8 >>= getBTree where
+        getBTree 0x45 = return Empty
+        getBTree 0x56 = Value <$> get
+        getBTree 0x4e = Node <$> get <*> (get >>= \n -> V.replicateM n get)
+        getBTree _ = error "Can't decode into BTree"
 
+-- | Compute the depth of a 'BTree' 
+depth :: Fixed g => g (BTree n k v) -> Int
+depth = cata phi where
+    phi Empty = 0
+    phi (Value _) = 1
+    phi (Node d _) = fromIntegral $ 1 + d
+
 -- | An empty 'BTree' 
-empty :: Fixed g => g (BTree k v)
+empty :: Fixed g => g (BTree n k v)
 empty = inf Empty
 
-value :: Fixed g => v -> g (BTree k v)
+value :: Fixed g => v -> g (BTree n k v)
 value = inf . Value
 
-node :: Fixed g => Word32 -> Array Int (k, g (BTree k v)) -> g (BTree k v)
+node :: Fixed g => Word32 -> V.Vector (k, g (BTree n k v)) -> g (BTree n k v)
 node d = inf . Node d
 
 -- | Create a 'FixFile' storing a @('BTree' k v)@.
 --   The initial value is 'empty'.
-createBTreeFile :: (Binary k, Typeable k, Binary v, Typeable v) =>
-    FilePath -> IO (FixFile (Ref (BTree k v)))
+createBTreeFile :: (Typeable n, Binary k, Typeable k, Binary v, Typeable v) =>
+    FilePath -> IO (FixFile (Ref (BTree n k v)))
 createBTreeFile fp = createFixFile (Ref empty) fp
 
 -- | Open a 'FixFile' storing a @('BTree' k v)@.
 openBTreeFile :: (Binary k, Typeable k, Binary v, Typeable v) =>
-    FilePath -> IO (FixFile (Ref (BTree k v)))
+    FilePath -> IO (FixFile (Ref (BTree n k v)))
 openBTreeFile = openFixFile
 
-nodeSize :: Integral i => i
-nodeSize = 32
+treeNodeSize :: KnownNat n => g (BTree n k v) -> Integer
+treeNodeSize = validate . natVal . p where
+    p :: g (BTree n k v) -> Proxy n
+    p _ = Proxy
+    validate n = if n < 2
+        then error "BTree branch size must be > 1."
+        else n
 
-lookupPos :: (Ord k) => Bool -> k -> Array Int (k, v) ->
-    (Int, [(k, v)], (k, v), [(k, v)])
-lookupPos ff k arr = result . findFirst . uncurry binary $ bounds arr where
-    result i =
-        let (a, b:c) = splitAt i $ elems arr
-        in (i, a, b, c)
-    lookupi = fst . (arr !)
-    findFirst = if ff then findFirst' else id
-    findFirst' 0 = 0
-    findFirst' i = if lookupi (i - 1) == k
-        then findFirst' (i - 1)
-        else i
-    binary mini maxi = 
-        let avg = (maxi + mini) `div` 2
-            avgi = lookupi avg
-        in case (maxi - mini <= 1, compare k avgi) of 
-            (True, _) -> if lookupi maxi <= k then maxi else mini
-            (_, EQ) -> avg
-            (_, LT) -> binary mini (avg - 1)
-            (_, _) -> binary avg maxi
+splitRange :: Ord k => k -> V.Vector (k, v) -> (Int, Int)
+splitRange k vec = V.foldl' rangeSum (0,0) vec where
+    rangeSum t@(i1, i2) (k', _)
+        | k' < k = (i1 `seq` i1 + 1, i2 `seq` i2 + 1)
+        | k == k' = (i1, i2 `seq` i2 + 1)
+        | otherwise = t
 
-splitRange :: (Ord k) => k -> Array Int (k, v) ->
-    ([(k,v)], [(k,v)], [(k,v)])
-splitRange k = uncurry splitMax . splitMin id Nothing . elems where
-    splitMin f Nothing [] = (f [], [])
-    splitMin f (Just t) [] = (f [], [t])
-    splitMin f Nothing xl@(xt@(xk,_):xs) = case compare xk k of
-        LT -> splitMin f (Just xt) xs
-        _ -> (f [], xl)
-    splitMin f (Just t) xl@(xt@(xk,_):xs) = case compare xk k of
-        LT -> splitMin (f . (t:)) (Just xt) xs
-        _ -> (f [], t:xl)
-    splitMax p xs = 
-        let (c, n) = splitMax' id xs
-        in (p, c, n)
-    splitMax' f [] = (f [], [])
-    splitMax' f xl@(xt@(xk,_):xs) = case compare xk k of
-        GT -> (f [], xl)
-        _ -> splitMax' (f . (xt:)) xs
+split3 :: (Int, Int) -> V.Vector a -> (V.Vector a, V.Vector a, V.Vector a)
+split3 (s1, s2) vec = (vl, vm, vr) where
+    (vm',vr) = V.splitAt s2 vec
+    (vl, vm) = V.splitAt s1 vm'
 
-data Insert k v g =
-    Inserted k (g (BTree k v))
-  | Split Word32 (k, (g (BTree k v))) (k, (g (BTree k v)))
+data Insert n k v g =
+    Inserted k (g (BTree n k v))
+  | Split Word32 (k, (g (BTree n k v))) (k, (g (BTree n k v)))
 
 -- | Insert the value 'v' with the key 'k' into a 'Fixed' @('BTree' k v)@.
-insertBTree :: (Ord k, Fixed g) => k -> v -> g (BTree k v) -> g (BTree k v)
-insertBTree k v = merge . para phi where
+insertBTree :: (KnownNat n, Ord k, Fixed g) => k -> v -> g (BTree n k v) ->
+    g (BTree n k v)
+insertBTree k v t = merge . para phi $ t where
     merge (Inserted _ x) = x
-    merge (Split d lt rt) = node (d + 1) $ array (0, 1)
-        [(0, lt), (1, rt)]
-    
-    newNode d c ls = if c > nodeSize
-        then
-            let (l, r) = splitAt half ls
-                half = nodeSize `div` 2
-                half' = c - half
-                mini = fst . head
-            in Split d (mini l, node d $ array (0, half - 1) $ zip [0..] l)
-                (mini r, node d $ array (0, half' - 1) $ zip [0..] r)
-        else Inserted (fst $ head ls) (node d $ array (0, c-1) $ zip [0..] ls)
+    merge (Split d lt rt) = node (d + 1) $ V.fromList [lt, rt]
+    nodeSize = fromIntegral $ treeNodeSize t
 
-    children xs = [(i, x) | (i, (x, _)) <- xs]
+    newNode d c cs
+        | c > nodeSize =
+            let (l, r) = V.splitAt (nodeSize `div` 2) cs
+                l' = V.force l
+                r' = V.force r
+                mini = fst . V.head
+            in Split d (mini l, node d l') (mini r, node d r')
+        | otherwise = 
+            Inserted (fst $ V.head cs) (node d cs)
 
-    phi Empty = Inserted k $ node 0 $ array (0,0) [(0, (k, value v))]
+    nodes = fmap (\(a,(b,_)) -> (a, b))
+
+    phi Empty = Inserted k $ node 0 $ V.singleton (k, value v)
     phi (Value _) = error "insertBTree phi Value error"
-    phi (Node 0 a) =
-        let (_, p, (kc, (km, _)), n) = lookupPos False k a
-            newSize = (2+) . snd . bounds $ a
-        in if kc <= k
-            then newNode 0 newSize $
-                children p ++ [(kc, km), (k, value v)] ++ children n
-            else newNode 0 newSize $
-                children p ++ [(k, value v), (kc, km)] ++ children n
-    phi (Node d a) =
-        let (_, p, (_, (_, ka)), n) = lookupPos False k a
-            newSize = 1 + currSize
-            currSize = (1+) . snd . bounds $ a
-        in case ka of
-            Inserted k' n' -> newNode d currSize $
-                children p ++ (k', n'):children n
-            Split _ lt rt -> newNode d newSize $
-                children p ++ [lt, rt] ++ children n
 
+    phi (Node 0 vec) =
+        let (lt, eq, gt) = split3 (splitRange k vec) (nodes vec)
+            newSize = 1 + V.length vec
+        in newNode 0 newSize (V.concat [lt, eq, V.singleton (k, value v), gt])
+    phi (Node d vec) = 
+        let (lt, eq, gt) = split3 (splitRange k vec) vec
+            lt' = nodes lt
+            eq' = nodes eq
+            gt' = nodes gt
+            currSize = V.length vec
+            (c, csf) = case (V.null eq, V.null lt) of
+                (False, _) ->
+                    (V.last eq, \n -> V.concat [lt', V.init eq', n, gt'])
+                (_, False) ->
+                    (V.last lt, \n -> V.concat [V.init lt', n, gt'])
+                _ -> (V.head gt, \n -> V.concat [n, V.tail gt'])
+        in case snd (snd c) of
+            Inserted k' n' ->
+                newNode d currSize (csf $ V.singleton (k', n'))
+            Split _ ls rs ->
+                newNode d (currSize + 1) (csf $ V.fromList [ls, rs])
+
 -- | 'Transaction' version of 'insertBTree'.
-insertBTreeT :: (Ord k, Binary k, Binary v) => k -> v ->
-    Transaction (Ref (BTree k v)) s ()
+insertBTreeT :: (KnownNat n, Ord k, Binary k, Binary v) => k -> v ->
+    Transaction (Ref (BTree n k v)) s ()
 insertBTreeT k v = alterT (insertBTree k v)
 
 -- | Lookup the values stored for the key 'k' in a 'Fixed' @('BTree' k v)@.
-lookupBTree :: (Ord k, Fixed g) => k -> g (BTree k v) -> [v]
+lookupBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) -> [v]
 lookupBTree k = ($ []) . cata phi where
     phi Empty l = l
     phi (Value v) l = v:l
-    phi (Node 0 a) l = foldr ($) l . fmap snd . filter ((k ==) . fst) . elems
-        $ a
-    phi (Node _ a) l =
-        let (_, c, _) = splitRange k a
-        in foldr ($) l $ fmap snd c
+    phi (Node 0 vec) l =
+        let (_, eq, _) = split3 (splitRange k vec) vec
+        in V.foldr (($) . snd) l eq
+    phi (Node _ vec) l =
+        let (_, eq, _) = split3 (s1 - 1, s2) vec
+            (s1, s2) = splitRange k vec
+        in V.foldr (($) . snd) l eq
 
 -- | 'Transaction' version of 'lookupBTree'.
 lookupBTreeT :: (Ord k, Binary k, Binary v) => k ->
-    Transaction (Ref (BTree k v)) s [v]
+    Transaction (Ref (BTree n k v)) s [v]
 lookupBTreeT k = lookupT (lookupBTree k)
 
-data Deleted k v g =
-    Deleted k (g (BTree k v))
+data Deleted n k v g =
+    Deleted k (g (BTree n k v))
   | AllDeleted
   | UnChanged
 
 -- | Filter items from a 'Fixed' @('BTree' k v)@ for a key 'k' that match
 --   the predicate.
 filterBTree :: (Ord k, Fixed g) => k -> (v -> Bool) ->
-    g (BTree k v) -> g (BTree k v)
+    g (BTree n k v) -> g (BTree n k v)
 filterBTree k f t = deleted' . para phi $ t where
     deleted' UnChanged = t
     deleted' AllDeleted = empty
     deleted' (Deleted _ x) = x
+
+    nodes = fmap (\(a, (b, _)) -> (a, b))
+
     phi Empty = UnChanged
     phi (Value v) = if f v
         then UnChanged
         else AllDeleted
-    phi (Node 0 a) =
-        let al = do
-                (nk, (nn, nv)) <- elems a
-                case (nk == k, nv) of
-                    (False, _) -> return (False, ((nk, nn):))
-                    (_, UnChanged) -> return (False, ((nk, nn):))
-                    _ -> return (True, id)
-            alb = foldr ((||) . fst) False al
-            al' = foldr (($) . snd) [] al
-            mink = fst . head $ al'
-        in case (alb, null al') of
-            (True, True) -> AllDeleted
-            (True, False) -> Deleted mink $ node 0 $
-                array (0, length al' - 1) $ zip [0..] al'
-            (False, _) -> UnChanged
-    phi (Node d a) = 
-        let (p, c, n) = splitRange k a
-            p' = [(nk, nv) | (nk, (nv, _)) <- p]
-            c'' = do
-                (nk, (nn, nv)) <- c
-                case nv of
-                    UnChanged -> return (False, ((nk, nn):))
-                    AllDeleted -> return (True, id)
-                    Deleted k' v' -> return (True, ((k', v'):))
-            c' = foldr (($) . snd) [] c''
-            cb = foldr ((||) . fst) False c''
-            n' = [(nk, nv) | (nk, (nv, _)) <- n]
-            al = p' ++ c' ++ n'
-            mink = fst . head $ al
-        in case (cb, null al) of
-            (False, _) -> UnChanged
-            (True, True) -> AllDeleted
-            (True, False) -> Deleted mink $ node d $
-                array (0, length al - 1) $ zip [0..] al
 
+    phi (Node 0 vec) =
+        let (lt, eq, gt) = split3 (splitRange k vec) vec
+            lt' = nodes lt
+            gt' = nodes gt
+            (eq',del) = runWriter $ do
+                res <- flip V.filterM eq $ \(_, (_, a)) ->
+                    case a of
+                        UnChanged -> return True
+                        _ -> tell (Any True) >> return False
+                return $ nodes res
+            vec' = V.concat [lt', eq', gt']
+            mink = fst (V.head vec')
+        in case (V.null vec', getAny del) of
+            (True, _) -> AllDeleted
+            (_, False) -> UnChanged
+            _ -> Deleted mink $ node 0 vec'
+    phi (Node d vec) =
+        let (lt, eq, gt) = split3 (s1 - 1, s2) vec
+            (s1, s2) = splitRange k vec
+            lt' = nodes lt
+            gt' = nodes gt
+            (eq',del) = runWriter $ do
+                res <- flip V.filterM eq $ \(_, (_, a)) ->
+                    case a of
+                        UnChanged -> return True
+                        Deleted _ _ -> tell (Any True) >> return True
+                        AllDeleted -> tell (Any True) >> return False
+                forM res $ \(nk, (n, a)) -> do
+                    case a of
+                        UnChanged -> return (nk, n)
+                        Deleted nk' a' -> return (nk', a')
+                        AllDeleted -> error "AllDeleted?" -- should be unreachable
+            vec' = V.concat [lt', eq', gt']
+            mink = fst (V.head vec')
+        in case (V.null vec', getAny del) of
+            (True, _) -> AllDeleted
+            (_, False) -> UnChanged
+            _ -> Deleted mink $ node d vec'
+
 -- | 'Transaction' version of 'filterBTree'.
 filterBTreeT :: (Ord k, Binary k, Binary v) => k -> (v -> Bool) ->
-    Transaction (Ref (BTree k v)) s ()
+    Transaction (Ref (BTree n k v)) s ()
 filterBTreeT k f = alterT (filterBTree k f)
 
 -- | Delete all items for key 'k' from the 'Fixed' @('BTree' k v)@.
-deleteBTree :: (Ord k, Fixed g) => k -> g (BTree k v) -> g (BTree k v)
+deleteBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) -> g (BTree n k v)
 deleteBTree k = filterBTree k (const False)
 
 -- | 'Transaction' version of 'deleteBTree'.
 deleteBTreeT :: (Ord k, Binary k, Binary v) => k ->
-    Transaction (Ref (BTree k v)) s ()
+    Transaction (Ref (BTree n k v)) s ()
 deleteBTreeT k = alterT (deleteBTree k)
 
+data SkewDir = L | R
+
+data Parted n k v g =
+    NoPart SkewDir
+  | Parted (k, (g (BTree n k v))) (k, (g (BTree n k v)))
+
+-- | Split a 'BTree' into two two 'BTree's with keys < 'k' and keys > 'k'.
+partitionBTree :: (Ord k, Fixed g) => k -> g (BTree n k v) ->
+    (g (BTree n k v), g (BTree n k v))
+partitionBTree k t = parted . para phi $ t where
+    parted (NoPart L) = (t, empty)
+    parted (NoPart R) = (empty, t)
+    parted (Parted (_, l) (_, r)) = (l, r)
+
+    nodes = fmap (\(a, (b, _)) -> (a, b))
+
+    phi Empty = NoPart L
+    phi (Value _) = error "Unbalanced BTree"
+    phi (Node 0 vec) =
+        let (lt, gte) = V.splitAt s1 vec
+            (s1, _) = splitRange k vec
+            minkl = fst (V.head lt)
+            minkr = fst (V.head gte)
+        in case (V.null lt, V.null gte) of
+            (True, _) -> NoPart R
+            (_, True) -> NoPart L
+            _ -> Parted (minkl, node 0 (nodes lt)) (minkr, node 0 (nodes gte))
+    phi (Node d vec) = 
+        let (lt, eq, gt) = split3 (s1 - 1, s1) vec
+            (s1, _) = splitRange k vec
+            lt' = nodes lt
+            eq' = nodes eq
+            gt' = nodes gt
+            minkl = if V.null lt then fst (V.head eq) else fst (V.head lt)
+            (_,(_,eqa)) = V.head eq
+        in case (V.null eq, V.null gt, eqa) of
+            (True, _, _) -> NoPart R
+            (_, True, NoPart L) -> NoPart L
+            (_, _, NoPart R) -> error "Malformed BTree"
+            (_, _, NoPart L) ->
+                let minkr = fst (V.head gt')
+                    ln = node d (V.concat [lt', eq'])
+                    rn = node d (V.force gt')
+                in Parted (minkl, ln) (minkr, rn)
+            (_, _, Parted tl tr@(prk, _)) ->
+                let ln = node d (V.concat [lt', V.singleton tl])
+                    rn = node d (V.concat [V.singleton tr, gt'])
+                in Parted (minkl, ln) (prk, rn)
+
 -- | Turn a 'Fixed' @('BTree' k v)@ into a list of key value tuples.
-toListBTree :: (Ord k, Fixed g) => g (BTree k v) -> [(k,v)]
+toListBTree :: (Ord k, Fixed g) => g (BTree n k v) -> [(k,v)]
 toListBTree t = cata phi t Nothing [] where
     phi Empty _ l = l
     phi (Value v) (Just k) l = (k, v):l
     phi (Value _) _ _ = error "Value with no Key"
-    phi (Node _ a) _ l = foldr (\(k,v) -> ((v (Just k)) .)) id (elems a) l
+    phi (Node _ vec) _ l = V.foldr (\(k,v) -> ((v (Just k)) .)) id vec l
 
 -- | Turn a list of key value tuples into a 'Fixed' @('BTree' k v)@.
-fromListBTree :: (Ord k, Fixed g) => [(k,v)] -> g (BTree k v)
+fromListBTree :: (KnownNat n, Ord k, Fixed g) => [(k,v)] -> g (BTree n k v)
 fromListBTree = foldr (uncurry insertBTree) empty
 
diff --git a/src/Data/FixFile/Set.hs b/src/Data/FixFile/Set.hs
--- a/src/Data/FixFile/Set.hs
+++ b/src/Data/FixFile/Set.hs
@@ -29,6 +29,7 @@
                          ,toListSetT
                          ) where
 
+
 import Prelude hiding (lookup)
 
 import Data.Binary
@@ -39,6 +40,8 @@
 {- |
     A 'Fixed' @('Set' i)@ is a set of items represented as a binary tree.
 -}
+{-# WARNING Set "Set is unbalanced and not recommended." #-}
+
 data Set i a = Empty | Node a i a
     deriving (Read, Show, Generic, Functor, Foldable, Traversable, Typeable)
 
diff --git a/src/Data/FixFile/Tree23.hs b/src/Data/FixFile/Tree23.hs
--- a/src/Data/FixFile/Tree23.hs
+++ b/src/Data/FixFile/Tree23.hs
@@ -14,10 +14,10 @@
     used with 'FixFile'. It has two interfaces that are
 -}
 module Data.FixFile.Tree23 (Tree23
-                           ,TreeD
                            ,empty
                            ,null
                            ,size
+                           ,depth
                            -- | * Set
                            ,Set
                            ,createSetFile
@@ -25,11 +25,13 @@
                            ,insertSet
                            ,lookupSet
                            ,deleteSet
+                           ,partitionSet
                            ,toListSet
                            ,fromListSet
                            ,insertSetT
                            ,lookupSetT
                            ,deleteSetT
+                           ,partitionSetT
                            -- | * Map
                            ,Map
                            ,createMapFile
@@ -37,6 +39,7 @@
                            ,insertMap
                            ,lookupMap
                            ,deleteMap
+                           ,partitionMap
                            ,alterMap
                            ,mapMap
                            ,toListMap
@@ -44,9 +47,11 @@
                            ,insertMapT
                            ,lookupMapT
                            ,deleteMapT
+                           ,partitionMapT
                            ,alterMapT
                            ,keysMap
                            ,valuesMap
+                           ,partitionTree23
                            ) where
 
 import Prelude hiding (null)
@@ -67,15 +72,12 @@
             Typeable)
 
 {- |
-    'Fixed' @('TreeD' d)@ represents a Two-Three tree. The data type 'd' should
+    'Fixed' @('Tree23' d)@ represents a Two-Three tree. The data type 'd' should
     have data families for it's key and value. These data families are not
     exported from the module. As a result, the only valid types for 'd' are
     @('Set' k)@ as defined here or @('Map' k v)@, also defined here.
 -}
-type TreeD d = Tree23F (TreeKey d) (TreeValue d)
-
--- | Type synonym for the 'Fixed' representation of a Two-Three Tree.
-type Tree23 g d = g (TreeD d)
+type Tree23 d = Tree23F (TreeKey d) (TreeValue d)
 
 data family TreeKey d
 
@@ -85,35 +87,43 @@
     Binary (Tree23F (TreeKey d) (TreeValue d) a)
 
 -- | An empty 'Fixed' 'Tree23'.
-empty :: Fixed g => Tree23 g d
+empty :: Fixed g => g (Tree23 d)
 empty = inf Empty
 
-leaf :: Fixed g => TreeKey d -> TreeValue d -> Tree23 g d
+leaf :: Fixed g => TreeKey d -> TreeValue d -> g (Tree23 d)
 leaf k v = inf $ Leaf k v
 
-two :: Fixed g => Tree23 g d -> TreeKey d ->
-    Tree23 g d -> Tree23 g d
+two :: Fixed g => g (Tree23 d) -> TreeKey d ->
+    g (Tree23 d) -> g (Tree23 d)
 two l v r = inf $ Two l v r
 
-three :: Fixed g => Tree23 g d -> TreeKey d -> Tree23 g d ->
-    TreeKey d -> Tree23 g d -> Tree23 g d
+three :: Fixed g => g (Tree23 d) -> TreeKey d -> g (Tree23 d) ->
+    TreeKey d -> g (Tree23 d) -> g (Tree23 d)
 three l t1 m t2 r =
     inf $ Three l t1 m t2 r
 
 -- | Predicate that returns true if there are no items in the 'Tree23'.
-null :: Fixed g => Tree23 g d -> Bool
+null :: Fixed g => g (Tree23 d) -> Bool
 null = null' . outf where
     null' Empty = True
     null' _ = False
 
 -- | Number of entries in @('Tree23' g d)@.
-size :: Fixed g => Tree23 g d -> Int
+size :: Fixed g => g (Tree23 d) -> Int
 size = cata phi where
     phi Empty = 0
     phi (Leaf _ _) = 1
     phi (Two l _ r) = l + r
     phi (Three l _ m _ r) = l + m + r
 
+-- | The depth of @('Tree23' g d)@. @0@ represents en empty Tree.
+depth :: Fixed g => g (Tree23 d) -> Int
+depth = cata phi where
+    phi Empty = 0
+    phi (Leaf _ _) = 1
+    phi (Two l _ _) = l + 1
+    phi (Three l _ _ _ _) = l + 1
+
 -- | A 'Set' of 'k' represented as a Two-Three Tree.
 data Set k
 
@@ -128,19 +138,23 @@
 instance Binary (TreeValue (Set k))
 
 -- | Insert an item into a set.
-insertSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Tree23 g (Set k)
+insertSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> g f
 insertSet k = alterTree23 (SK k) (maybe (Just $ Just SV) (const Nothing))
 
 -- | Lookup an item in a set.
-lookupSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Bool
+lookupSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> Bool
 lookupSet k = isJust . lookupTree23 (SK k)
 
 -- | Delete an item from a set.
-deleteSet :: (Fixed g, Ord k) => k -> Tree23 g (Set k) -> Tree23 g (Set k)
+deleteSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> g f
 deleteSet k = alterTree23 (SK k) (const $ Just Nothing)
 
+-- | Split a set into sets of items < k and >= k
+partitionSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => k -> g f -> (g f, g f)
+partitionSet k = partitionTree23 (SK k)
+
 -- | Convert a set into a list of items.
-toListSet :: (Fixed g, Ord k) => Tree23 g (Set k) -> [k]
+toListSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => g f -> [k]
 toListSet = ($ []) . cata phi where
     phi Empty xs = xs
     phi (Leaf (SK k) _) xs = k:xs
@@ -148,34 +162,39 @@
     phi (Three la _ ma _ ra) xs = la . ma . ra $ xs
 
 -- | Convert a list of items into a set.
-fromListSet :: (Fixed g, Ord k) => [k] -> Tree23 g (Set k)
+fromListSet :: (Fixed g, Ord k, f ~ Tree23 (Set k)) => [k] -> g f
 fromListSet = Prelude.foldr insertSet empty
 
 -- | Create a 'FixFile' for storing a set of items.
-createSetFile :: (Binary k, Typeable k) =>
-    FilePath -> IO (FixFile (Ref (TreeD (Set k))))
+createSetFile :: (Binary k, Typeable k, f ~ Tree23 (Set k)) =>
+    FilePath -> IO (FixFile (Ref f))
 createSetFile fp = createFixFile (Ref empty) fp
 
 -- | Open a 'FixFile' for storing a set of items.
-openSetFile :: (Binary k, Typeable k) =>
-    FilePath ->IO (FixFile (Ref (TreeD (Set k))))
+openSetFile :: (Binary k, Typeable k, f ~ Tree23 (Set k)) =>
+    FilePath ->IO (FixFile (Ref f))
 openSetFile fp = openFixFile fp
 
 -- | 'Transaction' version of 'insertSet'.
-insertSetT :: (Binary k, Ord k) =>
-    k -> Transaction (Ref (TreeD (Set k))) s ()
+insertSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>
+    k -> Transaction (Ref f) s ()
 insertSetT k = alterT (insertSet k) 
 
 -- | 'FTransaction' version of 'lookupSet'.
-lookupSetT :: (Binary k, Ord k) =>
-    k -> Transaction (Ref (TreeD (Set k))) s Bool
+lookupSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>
+    k -> Transaction (Ref f) s Bool
 lookupSetT k = lookupT (lookupSet k)
 
 -- | 'FTransaction' version of 'deleteSet'.
-deleteSetT :: (Binary k, Ord k) =>
-    k -> Transaction (Ref (TreeD (Set k))) s ()
+deleteSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) =>
+    k -> Transaction (Ref f) s ()
 deleteSetT k = alterT (deleteSet k)
 
+-- | 'Transaction' version of 'partitionSet'.
+partitionSetT :: (Binary k, Ord k, f ~ Tree23 (Set k)) => k ->
+    Transaction (Ref f) s (Stored s f, Stored s f)
+partitionSetT k = lookupT (partitionSet k)
+
 -- | A 'Map' of keys 'k' to values 'v' represented as a Two-Three Tree.
 data Map k v
 
@@ -190,28 +209,32 @@
 instance Binary v => Binary (TreeValue (Map k v))
 
 -- | Insert value 'v' into a map for key 'k'. Any existing value is replaced.
-insertMap :: (Fixed g, Ord k) => k -> v -> Tree23 g (Map k v) ->
-    Tree23 g (Map k v)
+insertMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> v -> g f -> g f
 insertMap k v = alterTree23 (MK k) (const . Just . Just $ MV v)
 
 -- | Lookup an item in a map corresponding to key 'k'.
-lookupMap :: (Fixed g, Ord k) => k -> Tree23 g (Map k v) -> Maybe v
+lookupMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> g f -> Maybe v
 lookupMap k = fmap toV . lookupTree23 (MK k) where
     toV (MV v) = v
 
 -- | Delete an item from a map at key 'k'.
-deleteMap :: (Fixed g, Ord k) => k -> Tree23 g (Map k v) -> Tree23 g (Map k v)
+deleteMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => k -> g f -> g f
 deleteMap k = alterTree23 (MK k) (const . Just $ Nothing)
 
 -- | Apply a function to alter a Map at key 'k'. The function takes
 --   @('Maybe' v)@ as an argument for any possible exiting value and returns
 --   @Nothing@ to delete a value or @Just v@ to set a new value.
-alterMap :: (Fixed g, Ord k) => k -> (Maybe v -> Maybe v) ->
-    Tree23 g (Map k v) -> Tree23 g (Map k v)
+alterMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> (Maybe v -> Maybe v) -> g f -> g f
 alterMap k f = alterTree23 (MK k) (Just . fmap MV . f . fmap fromMV)
 
+-- | Split a set into maps for keys < k and >= k
+partitionMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> g f -> (g f, g f)
+partitionMap k = partitionTree23 (MK k)
+
 -- | Convert a map into a list of key-value tuples.
-toListMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [(k,v)]
+toListMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [(k,v)]
 toListMap = ($ []) . cata phi where
     phi Empty xs = xs
     phi (Leaf (MK k) (MV v)) xs = (k,v):xs
@@ -219,21 +242,21 @@
     phi (Three la _ ma _ ra) xs = la . ma . ra $ xs
 
 -- | Convert a lst of key-value tuples into a map.
-fromListMap :: (Fixed g, Ord k) => [(k,v)] -> Tree23 g (Map k v)
+fromListMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => [(k,v)] -> g f
 fromListMap = Prelude.foldr (uncurry insertMap) empty
 
 -- | Return the list of keys in a map.
-keysMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [k]
+keysMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [k]
 keysMap = fmap fst . toListMap
 
 -- | Return a list of values in a map.
-valuesMap :: (Fixed g, Ord k) => Tree23 g (Map k v) -> [v]
+valuesMap :: (Fixed g, Ord k, f ~ Tree23 (Map k v)) => g f -> [v]
 valuesMap = fmap snd . toListMap
 
 -- | Map a function over a map. Because of the way Tree23 is implemented, it is
 --   not possible to create a Functor instance to achieve this.
-mapMap :: (Fixed g, Fixed h, Ord k) => (a -> b) -> Tree23 g (Map k a) ->
-    Tree23 h (Map k b)
+mapMap :: (Fixed g, Fixed h, Ord k) => (a -> b) -> g (Tree23 (Map k a)) ->
+    h (Tree23 (Map k b))
 mapMap f = cata phi where
     phi Empty = empty
     phi (Leaf (MK k) (MV a)) = leaf (MK k) (MV (f a))
@@ -241,39 +264,45 @@
     phi (Three l (MK k1) m (MK k2) r) = three l (MK k1) m (MK k2) r
 
 -- | Create a 'FixFile' of a Map.
-createMapFile :: (Binary k, Typeable k, Binary v, Typeable v) =>
-    FilePath -> IO (FixFile (Ref (TreeD (Map k v))))
+createMapFile :: (Binary k, Typeable k, Binary v, Typeable v,
+        f ~ Tree23 (Map k v)) =>
+    FilePath -> IO (FixFile (Ref f))
 createMapFile fp = createFixFile (Ref empty) fp
 
 -- | Open a 'FixFile' of a Map.
-openMapFile :: (Binary k, Typeable k, Binary v, Typeable v) =>
-    FilePath -> IO (FixFile (Ref (TreeD (Map k v))))
+openMapFile :: (Binary k, Typeable k, Binary v, Typeable v,
+        f ~ Tree23 (Map k v)) =>
+    FilePath -> IO (FixFile (Ref f))
 openMapFile fp = openFixFile fp
 
 -- | 'Transaction' version of 'insertMap'.
-insertMapT :: (Binary k, Binary v, Ord k) =>
-    k -> v -> Transaction (Ref (TreeD (Map k v))) s ()
+insertMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> v -> Transaction (Ref f) s ()
 insertMapT k v = alterT (insertMap k v) 
 
 -- | 'Transaction' version of 'lookupMap'.
-lookupMapT :: (Binary k, Binary v, Ord k) =>
-    k -> Transaction (Ref (TreeD (Map k v))) s (Maybe v)
+lookupMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> Transaction (Ref f) s (Maybe v)
 lookupMapT k = lookupT (lookupMap k)
 
 -- | 'Transaction' version of 'deleteMap'.
-deleteMapT :: (Binary k, Binary v, Ord k) => k ->
-    Transaction (Ref (TreeD (Map k v))) s ()
+deleteMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> Transaction (Ref f) s ()
 deleteMapT k = alterT (deleteMap k)
 
+-- | 'Transaction' version of 'partitionMap'.
+partitionMapT :: (Binary k, Ord k, Binary v, f ~ Tree23 (Map k v)) =>
+    k -> Transaction (Ref f) s (Stored s f, Stored s f)
+partitionMapT k = lookupT (partitionMap k)
+
 -- | 'FTransaction' version of 'alterMap'.
-alterMapT :: (Binary k, Binary v, Ord k) => k ->
-    (Maybe v -> Maybe v) -> 
-    Transaction (Ref (TreeD (Map k v))) s ()
+alterMapT :: (Binary k, Binary v, Ord k, f ~ Tree23 (Map k v)) =>
+    k -> (Maybe v -> Maybe v) -> Transaction (Ref f) s ()
 alterMapT k f = alterT (alterMap k f)
 
 -- lookup the value (if it exists) from a Fixed Tree23 for a given key.
 lookupTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->
-    Tree23 g d -> Maybe (TreeValue d)
+    g (Tree23 d) -> Maybe (TreeValue d)
 lookupTree23 k = cata phi where
     phi Empty = Nothing
     phi (Leaf k' v)
@@ -291,10 +320,10 @@
 
 data Change g d =
     NoChange
-  | Changed (Maybe (TreeKey d)) (Tree23 g d)
-  | Unbalanced (Maybe (TreeKey d)) (Tree23 g d)
+  | Changed (Maybe (TreeKey d)) (g (Tree23 d))
+  | Unbalanced (Maybe (TreeKey d)) (g (Tree23 d))
   | Hole
-  | Split (Tree23 g d) (TreeKey d) (Tree23 g d)
+  | Split (g (Tree23 d)) (TreeKey d) (g (Tree23 d))
 
 -- So, this function is a bit overwhelming, but it does everything that to
 -- handle all of the operations that modify a 2-3 tree.
@@ -307,7 +336,7 @@
 -- to be written to the tree.
 alterTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->
     (Maybe (TreeValue d) -> Maybe (Maybe (TreeValue d))) ->
-    Tree23 g d -> Tree23 g d
+    g (Tree23 d) -> g (Tree23 d)
 alterTree23 k f t = processHead $ para phi t t where
     processHead NoChange = t
     processHead (Changed _ t') = t'
@@ -403,4 +432,86 @@
                 Two ln' k1' rn' -> Changed Nothing $ two ln k1
                     (three ln' k1' rn' (maybe k2 id uk) un)
                 _ -> error "Invalid Tree23"
+
+
+data SkewDir = L | R
+
+data Partition g d =
+    NoPartition
+  | Skew SkewDir
+  | Split2 (Int, g (Tree23 d)) (Int, g (Tree23 d))
+
+merge :: (Fixed g, Ord (TreeKey d)) => Int -> g (Tree23 d) -> TreeKey d ->
+    Int -> g (Tree23 d) -> (Int, g (Tree23 d))
+merge ld ln k rd rn
+    | ld == rd = (ld + 1, two ln k rn)
+    | ld < rd = case (rd - ld, outf rn) of
+        (1, Two rln rk rrn) -> (rd, three ln k rln rk rrn)
+        (1, Three rln rk1 rmn rk2 rrn) ->
+            (rd + 1, two (two ln k rln) rk1 (two rmn rk2 rrn))
+        (_, Two rln rk rrn) ->
+            let (ld', rln') = merge ld ln k (rd - 1) rln
+            in merge ld' rln' rk (rd - 1) rrn
+        (_, Three rln rk1 rmn rk2 rrn) ->
+            let (ld', rln') = merge ld ln k (rd - 1) rln
+            in merge ld' rln' rk1 (rd - 1) (two rmn rk2 rrn)
+        _ -> error "Malformed Tree23"
+    | otherwise = case (ld - rd, outf ln) of
+        (1, Two lln lk lrn) -> (ld, three lln lk lrn k rn)
+        (1, Three lln lk1 lmn lk2 lrn) ->
+            (ld + 1, two (two lln lk1 lmn) lk2 (two lrn k rn))
+        (_, Two lln lk lrn) ->
+            let (rd', lrn') = merge (ld - 1) lrn k rd rn
+            in merge (ld - 1) lln lk rd' lrn'
+        (_, Three lln lk1 lmn lk2 lrn) ->
+            let (rd', lrn') = merge (ld - 1) lrn k rd rn
+            in merge (ld - 1) (two lln lk1 lmn) lk2 rd' lrn'
+        _ -> error "Malformed Tree23"
+
+partitionTree23 :: (Fixed g, Ord (TreeKey d)) => TreeKey d ->
+    g (Tree23 d) -> (g (Tree23 d), g (Tree23 d))
+partitionTree23 k t = resp $ para phi t where
+    resp NoPartition = (t, t)
+    resp (Skew L) = (t, empty)
+    resp (Skew R) = (empty, t)
+    resp (Split2 (_, l) (_, r)) = (l, r)
+    phi Empty = NoPartition
+    phi (Leaf k' _) 
+        | k' < k = Skew L
+        | otherwise = Skew R
+    phi (Two (ln, la) k' (rn, ra))
+        | k' == k = Split2 (-1, ln) (-1, rn)
+        | k' < k = case ra of
+            Skew L -> Skew L
+            Skew R -> Split2 (-1, ln) (-1, rn)
+            Split2 (lbal, lv) (rbal, rv) ->
+                Split2 (merge (-1) ln k' lbal lv) (rbal - 1, rv)
+            _ -> error "Malformed Tree23"
+        | otherwise = case la of
+            Skew L -> Split2 (-1, ln) (-1, rn)
+            Skew R -> Skew R
+            Split2 (lbal, lv) (rbal, rv) ->
+                Split2 (lbal - 1, lv) (merge rbal rv k' (-1) rn)
+            _ -> error "Malformed Tree23"
+    phi (Three (ln, la) k1 (mn, ma) k2 (rn, ra))
+        | k1 == k = Split2 (-1, ln) (0, two mn k2 rn)
+        | k2 == k = Split2 (0, two ln k1 mn) (-1, rn)
+        | k2 < k = case ra of
+            Skew L -> Skew L
+            Skew R -> Split2 (0, two ln k1 mn) (-1, rn)
+            Split2 (lbal, lv) (rbal, rv) ->
+                Split2 (merge 0 (two ln k1 mn) k2 lbal lv) (rbal - 1, rv)
+            _ -> error "Malformed Tree23"
+        | k1 < k = case ma of
+            Skew L -> Split2 (0, two ln k1 mn) (-1, rn)
+            Skew R -> Split2 (-1, ln) (0, two mn k2 rn)
+            Split2 (lbal, lv) (rbal, rv) ->
+                Split2 (merge (-1) ln k1 lbal lv) (merge rbal rv k2 (-1) rn)
+            _ -> error "Malformed Tree23"
+        | otherwise = case la of
+            Skew R -> Skew R
+            Skew L -> Split2 (-1, ln) (0, two mn k2 rn)
+            Split2 (lbal, lv) (rbal, rv) ->
+                Split2 (lbal -1, lv) (merge rbal rv k2 0 (two mn k2 rn))
+            _ -> error "Malformed Tree23"