-- |
--   Module      :  Data.Edison.Assoc.TernaryTrie
--   Copyright   :  Copyright (c) 2002, 2008 Andrew Bromage
--   License     :  MIT; see COPYRIGHT file for terms and conditions
--
--   Maintainer  :  robdockins AT fastmail DOT fm
--   Stability   :  stable
--   Portability :  GHC, Hugs (MPTC and FD)
--
--   Finite maps implemented as ternary search tries

module Data.Edison.Assoc.TernaryTrie (
    -- * Type of ternary search tries
    FM,

    -- * AssocX operations
    empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,
    deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,
    lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,
    lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,
    adjustOrDelete,adjustOrDeleteAll,strict,strictWith,
    map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,

    -- * Assoc operations
    toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,

    -- * FiniteMapX operations
    fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,
    insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,
    difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,
    properSubmap,submap,sameMap,

    -- * FiniteMap operations
    unionWithKey,unionSeqWithKey,intersectionWithKey,

    -- * OrdAssocX operations
    minView, minElem, deleteMin, unsafeInsertMin,
    maxView, maxElem, deleteMax, unsafeInsertMax,
    foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',
    unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,
    partitionLT_GE, partitionLE_GT, partitionLT_GT,

    -- * OrdAssoc operations
    minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,
    foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',
    toOrdSeq,

    -- * Other supported operations
    mergeVFM, mergeKVFM,

    -- * Documentation
    moduleName
) where

import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)
import qualified Prelude
import qualified Data.Edison.Assoc as A
import qualified Data.Edison.Seq as S
import qualified Data.List as L
import Control.Monad.Identity
import Data.Monoid
import Data.Maybe (isNothing)

import Data.Edison.Assoc.Defaults
import Test.QuickCheck (Arbitrary(..), Gen(), variant)


-- signatures for exported functions
moduleName    :: String
empty         :: Ord k => FM k a
singleton     :: Ord k => [k] -> a -> FM k a
fromSeq       :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a
insert        :: Ord k => [k] -> a -> FM k a -> FM k a
insertSeq     :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a
union         :: Ord k => FM k a -> FM k a -> FM k a
unionSeq      :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a
delete        :: Ord k => [k] -> FM k a -> FM k a
deleteAll     :: Ord k => [k] -> FM k a -> FM k a
deleteSeq     :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a
null          :: Ord k => FM k a -> Bool
size          :: Ord k => FM k a -> Int
member        :: Ord k => [k] -> FM k a -> Bool
count         :: Ord k => [k] -> FM k a -> Int
lookup        :: Ord k => [k] -> FM k a -> a
lookupM       :: (Ord k, Monad rm) => [k] -> FM k a -> rm a
lookupAll     :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a
lookupAndDelete    :: Ord k => [k] -> FM k a -> (a, FM k a)
lookupAndDeleteM   :: (Ord k, Monad rm) => [k] -> FM k a -> rm (a, FM k a)
lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a)
lookupWithDefault  :: Ord k => a -> [k] -> FM k a -> a
adjust        :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a
adjustAll     :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a
adjustOrInsert    :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a
adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a
adjustOrDelete    :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a
adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a
strict            :: FM k a -> FM k a
strictWith        :: (a -> b) -> FM k a -> FM k a
map           :: Ord k => (a -> b) -> FM k a -> FM k b
fold          :: Ord k => (a -> b -> b) -> b -> FM k a -> b
fold1         :: Ord k => (a -> a -> a) -> FM k a -> a
fold'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b
fold1'        :: Ord k => (a -> a -> a) -> FM k a -> a
filter        :: Ord k => (a -> Bool) -> FM k a -> FM k a
partition     :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a)
elements      :: (Ord k,S.Sequence seq) => FM k a -> seq a

fromSeqWith      :: (Ord k,S.Sequence seq) =>
                        (a -> a -> a) -> seq ([k],a) -> FM k a
fromSeqWithKey   :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a
insertWith       :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a
insertWithKey    :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a
insertSeqWith    :: (Ord k,S.Sequence seq) =>
                        (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a
insertSeqWithKey :: (Ord k,S.Sequence seq) =>
                        ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a
unionl           :: Ord k => FM k a -> FM k a -> FM k a
unionr           :: Ord k => FM k a -> FM k a -> FM k a
unionWith        :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a
unionSeqWith     :: (Ord k,S.Sequence seq) =>
                        (a -> a -> a) -> seq (FM k a) -> FM k a
intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c
difference       :: Ord k => FM k a -> FM k b -> FM k a
properSubset     :: Ord k => FM k a -> FM k b -> Bool
subset           :: Ord k => FM k a -> FM k b -> Bool
properSubmapBy   :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
submapBy         :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
sameMapBy        :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool
properSubmap     :: (Ord k, Eq a) => FM k a -> FM k a -> Bool
submap           :: (Ord k, Eq a) => FM k a -> FM k a -> Bool
sameMap          :: (Ord k, Eq a) => FM k a -> FM k a -> Bool

toSeq            :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)
keys             :: (Ord k,S.Sequence seq) => FM k a -> seq [k]
mapWithKey       :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b
foldWithKey      :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
foldWithKey'     :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
filterWithKey    :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a
partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a)
unionWithKey     :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a
unionSeqWithKey  :: (Ord k,S.Sequence seq) =>
                       ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a
intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c

foldr          :: Ord k => (a -> b -> b) -> b -> FM k a -> b
foldr1         :: Ord k => (a -> a -> a) -> FM k a -> a
foldr'         :: Ord k => (a -> b -> b) -> b -> FM k a -> b
foldr1'        :: Ord k => (a -> a -> a) -> FM k a -> a

foldrWithKey   :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
foldrWithKey'  :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b
foldlWithKey   :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b
foldlWithKey'  :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b
toOrdSeq       :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)

moduleName = "Data.Edison.Assoc.TernaryTrie"


data FM k a
  = FM !(Maybe a) !(FMB k a)

data FMB k v
  = E
  | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v)

newtype FMB' k v
  = FMB' (FMB k v)

balance :: Int
balance = 6

sizeFMB :: FMB k v -> Int
sizeFMB E = 0
sizeFMB (I size _ _ _ _ _) = size

mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
mkFMB k v l m r
  = I (1 + sizeFMB l + sizeFMB r) k v l m r

lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v
lookupFMB []        _
  = Nothing
lookupFMB (_:_) E
  = Nothing
lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r)
  = case compare x k of
        LT -> lookupFMB nk l
        GT -> lookupFMB nk r
        EQ -> if L.null xs then v else lookupFMB xs fmbm

listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v
listToFMB [x]    fv = mkFMB x (fv Nothing) E (FMB' E)                 E
listToFMB (x:xs) fv = mkFMB x Nothing      E (FMB' $ listToFMB xs fv) E
listToFMB _ _ = error "TernaryTrie.listToFMB: bug!"

addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v
addToFMB xs combiner E
  = listToFMB xs combiner
addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r)
  = case compare x k of
        LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r
        GT -> mkBalancedFMB k v l m (addToFMB nk combiner r)
        EQ -> case xs of
                [] -> I size k (combiner v) l m r
                _  -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r
addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!"

addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v
addToFM [] combiner (FM n fmb)
  = FM (combiner n) fmb
addToFM xs combiner (FM n fmb)
  = FM n (addToFMB xs combiner fmb)

lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z
lookupAndDelFromFMB onFail _ _ E = onFail
lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r)
  = case compare x k of
        LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l
        GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r
        EQ -> case xs of
                [] -> case v of
                        Nothing -> onFail
                        Just w  -> case fmbm of
                                      E -> cont w (appendFMB l r)
                                      _ -> cont w (I size k Nothing l m r)
                _  -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm
lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!"

lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z
lookupAndDelFromFM onFail _ [] (FM Nothing _)  = onFail
lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb)
lookupAndDelFromFM onFail cont xs (FM n fmb) =
   lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb


delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v
delFromFMB _ E
  = E
delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r)
  = case compare x k of
        LT -> mkBalancedFMB k v (delFromFMB nk l) m r
        GT -> mkBalancedFMB k v l m (delFromFMB nk r)
        EQ -> case xs of
                [] -> case fmbm of
                        E -> appendFMB l r
                        _ -> I size k Nothing l m r
                _  -> I size k v l (FMB' $ delFromFMB xs fmbm) r
delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!"


delFromFM :: (Ord k) => [k] -> FM k v -> FM k v
delFromFM [] (FM _ fmb)
  = FM Nothing fmb
delFromFM xs (FM n fmb)
  = FM n (delFromFMB xs fmb)


mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
mkBalancedFMB k v l m r
  | size_l + size_r < 2
    = mkFMB k v l m r
  | size_r > balance * size_l        -- Right tree too big
    = case r of
        I _ _ _ rl _ rr
            | sizeFMB rl < 2 * sizeFMB rr
                -> single_L l m r
            | otherwise
                -> double_L l m r
        _ -> error "TernaryTrie.mkBalancedFMB: bug!"

  | size_l > balance * size_r   -- Left tree too big
    = case l of
        I _ _ _ ll _ lr
            | sizeFMB lr < 2 * sizeFMB ll
                -> single_R l m r
            | otherwise
                -> double_R l m r
        _ -> error "TernaryTrie.mkBalancedFMB: bug!"

  | otherwise                           -- No imbalance
    = mkFMB k v l m r
  where
        size_l   = sizeFMB l
        size_r   = sizeFMB r

        single_L l m (I _ k_r v_r rl rm rr)
          = mkFMB k_r v_r (mkFMB k v l m rl) rm rr
        single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"

        double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr)
          = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr)
        double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"

        single_R (I _ k_l v_l ll lm lr) m r
          = mkFMB k_l v_l ll lm (mkFMB k v lr m r)
        single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"

        double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r
          = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r)
        double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"


mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v
mkVBalancedFMB k v E m E
  = mkFMB k v E m E
mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr)
  = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr
mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E
  = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)
mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr)
  | balance * size_l < size_r
    = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr
  | balance * size_r < size_l
    = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)
  | otherwise
    = mkFMB k v l m r
  where
        size_l = sizeFMB l
        size_r = sizeFMB r

    -- Constraint: All keys in the first FMB are less than
    -- that in the second FMB.
appendFMB :: FMB k v -> FMB k v -> FMB k v
appendFMB E m2 = m2
appendFMB m1 E = m1
appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2)
  | size1 > size2
    = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2)
  | otherwise
    = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2

mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b
mapVFM f (FM n fmb)
  = FM (f n) (mapVFMB f fmb)

mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b
mapVFMB f m
  = mapVFMB' m
  where
        mapVFMB' E = E
        mapVFMB' (I _ k v l (FMB' m) r)
          = case (mapVFMB' m, f v) of
                (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r)
                (m',v')     -> mkVBalancedFMB k v'
                                    (mapVFMB' l) (FMB' m') (mapVFMB' r)

mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b
mapKVFM f (FM n fmb)
  = FM (f [] n) (mapKVFMB [] fmb)
  where
        mapKVFMB _ E = E
        mapKVFMB ks (I _ k v l (FMB' m) r)
          = mkVBalancedFMB k (f (reverse (k:ks)) v)
              (mapKVFMB ks l)
              (FMB' (mapKVFMB (k:ks) m))
              (mapKVFMB ks r)

nullFMB :: FMB k v -> Bool
nullFMB E = True
nullFMB (I _ _ v l (FMB' m) r)
  = case v of
      Just _  -> False
      Nothing -> nullFMB l && nullFMB m && nullFMB r

nullFM :: FM k v -> Bool
nullFM (FM (Just _) _)  = False
nullFM (FM Nothing fmb) = nullFMB fmb

data FMBCtx k v
  = T
  | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v)
  | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v)

splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a)
splayFMB key fmb
  = splaydown T fmb
  where
    splaydown ctx E
      = splayup ctx Nothing E (FMB' E) E
    splaydown ctx (I _ k v l m r)
      = case compare key k of
            LT -> splaydown (L k v ctx m r) l
            GT -> splaydown (R k v l m ctx) r
            EQ -> splayup ctx v l m r

    splayup ctx v l m r
      = splayup' ctx l r
      where
          splayup' T l r
            = (v, l, m, r)
          splayup' (L ck cv ctx cm cr) tl tr
            = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr)
          splayup' (R ck cv cl cm ctx) tl tr
            = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr

mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->
                FMB k a -> FMB k b -> FMB k c
mergeVFMB f fmbx fmby
  = mergeVFMB' fmbx fmby
  where
    mergeVFMB' E E
      = E
    mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _)
      = mapVFMB (\v -> f Nothing v) fmby
    mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E
      = mapVFMB (\v -> f v Nothing) fmbx
    mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx)
               fmby@(I sizey ky vy ly (FMB' my) ry)
      | sizex >= sizey
        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
          in case (mergeVFMB' mx my, f vx vy) of
                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)
                (m',v)      -> mkVBalancedFMB kx v
                                   (mergeVFMB' lx ly)
                                   (FMB' m')
                                   (mergeVFMB' rx ry)
      | otherwise
        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
          in case (mergeVFMB' mx my, f vx vy) of
                (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)
                (m',v)      -> mkVBalancedFMB ky v
                                   (mergeVFMB' lx ly)
                                   (FMB' m')
                                   (mergeVFMB' rx ry)

mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->
                FM k a -> FM k b -> FM k c
mergeVFM f (FM vx fmbx) (FM vy fmby)
  = FM (f vx vy) (mergeVFMB f fmbx fmby)


mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->
                FMB k a -> FMB k b -> FMB k c
mergeKVFMB f fmbx fmby
  = mergeKVFMB' [] fmbx fmby
  where
    mergeKVFMB' _ E E
      = E
    mergeKVFMB' ks E fmby
      = mergeKVFMBs (\k v -> f k Nothing v) ks fmby
    mergeKVFMB' ks fmbx E
      = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx
    mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx)
                   fmby@(I sizey ky vy ly (FMB' my) ry)
      | sizex >= sizey
        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
              ks' = reverse (kx:ks)
          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of
                (E,Nothing) -> appendFMB
                                    (mergeKVFMB' ks lx ly)
                                    (mergeKVFMB' ks rx ry)
                (m',v)      -> mkVBalancedFMB kx v
                                    (mergeKVFMB' ks lx ly)
                                    (FMB' m')
                                    (mergeKVFMB' ks rx ry)
      | otherwise
        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
              ks' = reverse (ky:ks)
          in case (mergeKVFMB' ks' mx my, f ks' vx vy) of
                (E,Nothing) -> appendFMB
                                    (mergeKVFMB' ks lx ly)
                                    (mergeKVFMB' ks rx ry)
                (m',v)      -> mkVBalancedFMB ky v
                                    (mergeKVFMB' ks lx ly)
                                    (FMB' m')
                                    (mergeKVFMB' ks rx ry)

    mergeKVFMBs f ks fmb
      = mergeKVFMBs' ks fmb
      where
          mergeKVFMBs' _ E
            = E
          mergeKVFMBs' ks (I _ k v l (FMB' m) r)
            = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of
                (E, Nothing) -> appendFMB
                                    (mergeKVFMBs' ks l)
                                    (mergeKVFMBs' ks r)
                (m,v)        -> mkVBalancedFMB k v
                                    (mergeKVFMBs' ks l)
                                    (FMB' m)
                                    (mergeKVFMBs' ks r)

mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->
                FM k a -> FM k b -> FM k c
mergeKVFM f (FM vx fmbx) (FM vy fmby)
  = FM (f [] vx vy) (mergeKVFMB f fmbx fmby)


-- The public interface.
--

-- AssocX

empty = FM Nothing E

singleton [] v = FM (Just v) E
singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v))

fromSeq = fromSeqUsingInsertSeq

insert k v fm = addToFM k (\_ -> Just v) fm

insertSeq = insertSeqUsingFoldr

union = mergeVFM mplus

unionSeq = unionSeqUsingReduce

delete k fm = delFromFM k fm

deleteAll = delete

deleteSeq = deleteSeqUsingFoldr

null = nullFM

size (FM k fmb)
    | isNothing k = fmb_size fmb 0
    | otherwise   = fmb_size fmb 1
    where fmb_size E k = k
          fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k
          fmb_size (I _ _ _ l (FMB' m) r ) k      = fmb_size l $ fmb_size m $ fmb_size r $! k+1


member = memberUsingLookupM

count = countUsingMember

lookup m k = runIdentity (lookupM m k)

lookupM [] (FM Nothing _)
  = fail "TernaryTrie.lookup: lookup failed"
lookupM [] (FM (Just v) _)
  = return v
lookupM xs (FM _ fmb)
  = case  lookupFMB xs fmb  of
        Nothing -> fail "TernaryTrie.lookup: lookup failed"
        Just v  -> return v

lookupAll = lookupAllUsingLookupM

lookupAndDelete =
    lookupAndDelFromFM
      (error "TernaryTrie.lookupAndDelete: lookup failed")
      (,)

lookupAndDeleteM =
    lookupAndDelFromFM
      (fail  "TernaryTrie.lookupAndDeleteM: lookup failed")
      (\w m -> return (w,m))

lookupAndDeleteAll k m =
    lookupAndDelFromFM
      (S.empty,m)
      (\w m' -> (S.singleton w,m'))
      k m

lookupWithDefault = lookupWithDefaultUsingLookupM

adjust f k
  = addToFM k (\mv -> case mv of
                        Nothing -> mv
                        Just v  -> Just (f v))

adjustAll = adjust

adjustOrInsert f z k
  = addToFM k (\mv -> case mv of
                        Nothing -> Just z
                        Just v  -> Just (f v))

adjustAllOrInsert = adjustOrInsert

adjustOrDelete f k
  = addToFM k (\mv -> case mv of
                        Nothing -> mv
                        Just v  -> f v)

adjustOrDeleteAll = adjustOrDelete

map f
  = mapVFM (\mv -> case mv of
                        Nothing -> Nothing
                        Just v  -> Just (f v))

fold = foldr
fold' = foldr'

foldr op z (FM n fmb)
  = foldMV n . foldFMB fmb $ z
  where
    foldMV Nothing  = id
    foldMV (Just v) = op v

    foldFMB E
      = id
    foldFMB (I _ _ v l (FMB' m) r)
      = foldFMB l . foldMV v . foldFMB m . foldFMB r

foldrWithKey f z (FM n fmb)
  = foldMV [] n . foldFMB id fmb $ z
  where
     foldMV _ Nothing  = id
     foldMV ks (Just v) = f ks v

     foldFMB _ E = id
     foldFMB kf (I _ k mv l (FMB' m) r)
       = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r

foldlWithKey f z (FM n fmb)
  = foldFMB id fmb . foldMV [] n $ z
  where
     g k x a = f a k x

     foldMV _ Nothing  = id
     foldMV ks (Just v) = g ks v

     foldFMB _ E = id
     foldFMB kf (I _ k mv l (FMB' m) r)
       = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l

foldrWithKey' = foldrWithKey
foldlWithKey' = foldlWithKey

foldl :: (a -> b -> a) -> a -> FM t b -> a
foldl op z (FM n fmb)
  = foldFMB fmb . foldMV n $ z
  where
    foldMV Nothing  = id
    foldMV (Just v) = (flip op) v

    foldFMB E = id
    foldFMB (I _ _ v l (FMB' m) r)
      = foldFMB r . foldFMB m . foldMV v . foldFMB l


-- FIXME, undestand this code to strictify it
foldr' = foldr
foldl' :: (a -> b -> a) -> a -> FM t b -> a
foldl' = foldl

foldr1 f fm =
  case maxView fm of
     Just (z,fm') -> foldr f z fm'
     Nothing      -> error $ moduleName++".foldr1: empty map"

foldl1 :: (b -> b -> b) -> FM k b -> b
foldl1 f fm =
  case minView fm of
     Just (z,fm') -> foldl f z fm'
     Nothing      -> error $ moduleName++".foldl1: empty map"


basecase :: Maybe t1 -> (t1 -> t) -> t -> t
basecase Nothing  = \_ n -> n
basecase (Just x) = \j _ -> j x

comb ::                                (t1 -> t1 -> t1)
                                    -> ((t1 -> t2) -> t2 -> t3)
                                    -> ((t1 -> t) -> t -> t2)
                                    -> (t1 -> t)
                                    -> t
                                    -> t3
comb f p1 p2
   = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n)

fold1 f (FM mv fmb)
  = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map")
  where
      fold1FMB E
        = \_ n -> n
      fold1FMB (I _ _ mv l (FMB' m) r)
        = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r)

fold1' = fold1

{-
FIXME -- can these be somehow fixed to have the right order...

foldr1 f (FM v fmb)
  = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map")
  where
      fold1FMB E
        = \j n -> n
      fold1FMB (I _ _ v l (FMB' m) r)
        = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r)


foldl1 f (FM v fmb)
  = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map")
  where
      fold1FMB E
        = \j n -> n
      fold1FMB (I _ _ v l (FMB' m) r)
        = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l)
-}



-- FIXME, undestand this code to strictify it
foldr1' = foldr1
foldl1' :: (b -> b -> b) -> FM k b -> b
foldl1' = foldl1


filter p = mapVFM (\mv -> case mv of
                            Nothing -> mv
                            Just v  -> if p v then mv else Nothing)

partition = partitionUsingFilter

elements = elementsUsingFold

strict z@(FM _ fmb) = strictFMB fmb `seq` z
 where strictFMB n@E = n
       strictFMB n@(I _ _ _ l (FMB' m) r) =
           strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n

strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z
   where f' v@Nothing  = v
         f' v@(Just x) = f x `seq` v

         strictWithFMB n@E = n
         strictWithFMB n@(I _ _ v l (FMB' m) r) =
           f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n


-- FiniteMapX

fromSeqWith = fromSeqWithUsingInsertSeqWith

fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey

insertWith f k v
  = addToFM k (\vem ->
      case vem of
          Nothing -> Just v
          Just ve -> Just (f ve v))

insertWithKey = insertWithKeyUsingInsertWith

insertSeqWith = insertSeqWithUsingInsertWith

insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey

unionl = union
unionr = flip union

unionWith f = unionWithKey (const f)

unionSeqWith = unionSeqWithUsingReduce

intersectionWith f = intersectionWithKey (const f)

difference mx my
  = mergeVFM (\v1 v2 -> case v2 of
              Nothing -> v1
              Just _  -> Nothing) mx my

properSubset = properSubsetUsingSubset

subset (FM nx fmbx) (FM ny fmby)
  = subsetEqM nx ny && subsetEqFMB fmbx fmby
  where
    subsetEqM Nothing _ = True
    subsetEqM (Just _) Nothing = False
    subsetEqM (Just _) (Just _) = True

    subsetEqFMB E _ = True
    subsetEqFMB fmbx@(I _ _ _ _ _ _) E
      = nullFMB fmbx
    subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx)
            fmby@(I sizey ky vy ly (FMB' my) ry)
      | sizex >= sizey
        = let (vy, ly, FMB' my, ry) = splayFMB kx fmby
          in    subsetEqM vx vy
             && subsetEqFMB lx ly
             && subsetEqFMB mx my
             && subsetEqFMB rx ry
      | otherwise
        = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx
          in    subsetEqM vx vy
             && subsetEqFMB lx ly
             && subsetEqFMB mx my
             && subsetEqFMB rx ry


submapBy = submapByUsingLookupM
properSubmapBy = properSubmapByUsingSubmapBy
sameMapBy = sameMapByUsingSubmapBy
properSubmap = A.properSubmap
submap = A.submap
sameMap = A.sameMap

-- Assoc

toSeq = toSeqUsingFoldWithKey

keys = keysUsingFoldWithKey

mapWithKey f
  = mapKVFM (\k mv -> case mv of
          Nothing -> Nothing
          Just v  -> Just (f k v))

foldWithKey op r (FM n fmb)
  = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r
  where
      foldWithKeyB _ Nothing = id
      foldWithKeyB k (Just v) = op k v

      foldWithKeyFM _ E = id
      foldWithKeyFM ks (I _ k v l (FMB' m) r)
        = foldWithKeyFM ks l
        . foldWithKeyB (reverse (k:ks)) v
        . foldWithKeyFM (k:ks) m
        . foldWithKeyFM ks r


-- FIXME, make this strict
foldWithKey' = foldWithKey


filterWithKey f
  = mapKVFM (\k mv -> case mv of
          Nothing -> mv
          Just v  -> if f k v then mv else Nothing)

partitionWithKey f m
  = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m)

-- FiniteMap

unionWithKey f
  = mergeKVFM (\k v1m v2m ->
    case v1m of
        Nothing -> v2m
        Just v1 ->
            case v2m of
            Nothing -> v1m
            Just v2 -> Just (f k v1 v2))

unionSeqWithKey = unionSeqWithKeyUsingReduce

intersectionWithKey f
  = mergeKVFM (\k v1m v2m ->
    case v1m of
        Nothing -> Nothing
        Just v1 ->
            case v2m of
            Nothing -> Nothing
            Just v2 -> Just (f k v1 v2))

-- OrdAssocX

minViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)
minViewFMB E _ = fail $ moduleName++".minView: empty map"
minViewFMB (I i k (Just v) E m r)        f = return (v, f (I i k Nothing E m r))
minViewFMB (I _ _ Nothing  E (FMB' E) _) _ = error $ moduleName++".minView: bug!"
minViewFMB (I _ k Nothing  E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))
minViewFMB (I _ k mv l m r)              f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r))

minView :: Monad m => FM k a -> m (a,FM k a)
minView (FM (Just v) fmb) = return (v, FM Nothing fmb)
minView (FM Nothing fmb)  = minViewFMB fmb (FM Nothing)

minViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)
minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map"
minViewWithKeyFMB (I i k (Just v) E m r)        kf f = return ((kf [k],v),f (I i k Nothing E m r))
minViewWithKeyFMB (I _ _ Nothing  E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!"
minViewWithKeyFMB (I _ k Nothing  E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:))
                                                        (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))
minViewWithKeyFMB (I _ k mv l m r)              kf f = minViewWithKeyFMB l kf
                                                        (\l' -> f (mkVBalancedFMB k mv l' m r))

minViewWithKey :: Monad m => FM k a -> m (([k],a),FM k a)
minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb)
minViewWithKey (FM Nothing fmb)  = minViewWithKeyFMB fmb id (FM Nothing)


minElemFMB :: FMB k a -> a
minElemFMB E = error $ moduleName++".minElem: empty map"
minElemFMB (I _ _ (Just v) E _ _)        = v
minElemFMB (I _ _ Nothing  E (FMB' m) _) = minElemFMB m
minElemFMB (I _ _ _ l _ _)              = minElemFMB l

minElem :: FM t1 t -> t
minElem (FM (Just v) _) = v
minElem (FM Nothing  fmb) = minElemFMB fmb


minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a)
minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map"
minElemWithKeyFMB kf (I _ k (Just v) E _ _)        = (kf [k],v)
minElemWithKeyFMB kf (I _ k Nothing  E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m
minElemWithKeyFMB kf (I _ _ _ l _ _)              = minElemWithKeyFMB kf l

minElemWithKey :: FM k a -> ([k],a)
minElemWithKey (FM (Just v) _) = ([],v)
minElemWithKey (FM Nothing  fmb) = minElemWithKeyFMB id fmb

deleteMin :: Ord k => FM k a -> FM k a
deleteMin = deleteMinUsingMinView

unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a
unsafeInsertMin = insert

maxViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)
maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l)
--maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E))
maxViewFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!"
maxViewFMB (I i k mv l (FMB' m) E)       f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E))
maxViewFMB (I _ k mv l m r)              f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r'))
maxViewFMB E                             _ = error $ moduleName++".maxView: bug!"

maxView :: Monad m => FM k a -> m (a, FM k a)
maxView (FM Nothing E)  = fail $ moduleName++".maxView: empty map"
maxView (FM (Just v) E) = return (v,FM Nothing E)
maxView (FM mv fmb)     = maxViewFMB fmb (FM mv)


maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)
maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l)
maxViewWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!"
maxViewWithKeyFMB (I i k mv l (FMB' m) E)       kf f = maxViewWithKeyFMB m (kf . (k:))
                                                        (\m' -> f (I i k mv l (FMB' m') E))
maxViewWithKeyFMB (I _ k mv l m r)              kf f = maxViewWithKeyFMB r kf
                                                        (\r' -> f (mkVBalancedFMB k mv l m r'))
maxViewWithKeyFMB E                             _ _ = error $ moduleName++".maxViewWithKey: bug!"


maxViewWithKey :: Monad m => FM k a -> m (([k],a), FM k a)
maxViewWithKey (FM Nothing E)  = fail $ moduleName++".maxViewWithKey: empty map"
maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E)
maxViewWithKey (FM mv fmb)     = maxViewWithKeyFMB fmb id (FM mv)



maxElemFMB :: FMB k a -> a
maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v
maxElemFMB (I _ _ Nothing  _ (FMB' E) E) = error $ moduleName++".maxElem: bug!"
maxElemFMB (I _ _ _ _ (FMB' m) E)       = maxElemFMB m
maxElemFMB (I _ _ _ _ _ r)              = maxElemFMB r
maxElemFMB E                             = error $ moduleName++".maxElem: bug!"

maxElem :: FM k a -> a
maxElem (FM (Just v) E) = v
maxElem (FM Nothing  E) = error $ moduleName++".maxElem: empty map"
maxElem (FM _ fmb)      = maxElemFMB fmb

maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a)
maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v)
maxElemWithKeyFMB (I _ _ Nothing  _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!"
maxElemWithKeyFMB (I _ k _ _ (FMB' m) E)       kf = maxElemWithKeyFMB m (kf . (k:))
maxElemWithKeyFMB (I _ _ _ _ _ r)              kf = maxElemWithKeyFMB r kf
maxElemWithKeyFMB E                             _ = error $ moduleName++".maxElemWithKey: bug!"


maxElemWithKey :: FM k a -> ([k],a)
maxElemWithKey (FM (Just v) E) = ([],v)
maxElemWithKey (FM Nothing E)  = error $ moduleName++".maxElemWithKey: empty map"
maxElemWithKey (FM _ fmb)      = maxElemWithKeyFMB fmb id


deleteMax :: Ord k => FM k a -> FM k a
deleteMax = deleteMaxUsingMaxView

unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a
unsafeInsertMax = insert

unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a
unsafeFromOrdSeq = fromSeq

unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a
unsafeAppend = union

-- FIXME this doesn't respect the structural invariant... why??
{-
unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2)
unsafeAppend (FM Nothing  fmb1) (FM mv fmb2)      = FM mv       (appendFMB fmb1 fmb2)
unsafeAppend (FM (Just _) _) (FM (Just _) _)      = error $ moduleName++".unsafeAppend: bug!"
-}

filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a
filterL_FMB _ _ _ E = E
filterL_FMB f k ks (I _ key mv l (FMB' m) r)
    | key < k   = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r)
    | key > k   = filterL_FMB f k ks l
    | otherwise = case ks of
                    []       -> f k mv l
                    (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E

filterLT :: Ord k => [k] -> FM k a -> FM k a
filterLT [] _               = FM Nothing E
filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb)

filterLE :: Ord k => [k] -> FM k a -> FM k a
filterLE [] (FM mv _)       = FM mv E
filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb)



filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a
filterG_FMB _ _ _ E = E
filterG_FMB f k ks (I _ key mv l (FMB' m) r)
    | key < k   = filterG_FMB f k ks r
    | key > k   = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r
    | otherwise = case ks of
                    []       -> f k mv m r
                    (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r

filterGT :: Ord k => [k] -> FM k a -> FM k a
filterGT []     (FM _  fmb) = FM Nothing fmb
filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb)

filterGE :: Ord k => [k] -> FM k a -> FM k a
filterGE []     fm          = fm
filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb)

--FIXME do better...
partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm)

partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm)

partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)
partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm)

toOrdSeq = toOrdSeqUsingFoldrWithKey

-- instance declarations

instance Ord k  => A.AssocX (FM k) [k] where
  {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;
   insertSeq = insertSeq; union = union; unionSeq = unionSeq;
   delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;
   null = null; size = size; member = member; count = count;
   lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;
   lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;
   lookupAndDeleteAll = lookupAndDeleteAll;
   lookupWithDefault = lookupWithDefault; adjust = adjust;
   adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;
   adjustAllOrInsert = adjustAllOrInsert;
   adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;
   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
   filter = filter; partition = partition; elements = elements;
   strict = strict; strictWith = strictWith;
   structuralInvariant = structuralInvariant; instanceName _ = moduleName}

instance Ord k  => A.Assoc (FM k) [k] where
  {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;
   foldWithKey = foldWithKey; foldWithKey' = foldWithKey';
   filterWithKey = filterWithKey;
   partitionWithKey = partitionWithKey}

instance Ord k => A.FiniteMapX (FM k) [k] where
  {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;
   insertWith  = insertWith; insertWithKey = insertWithKey;
   insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;
   unionl = unionl; unionr = unionr; unionWith = unionWith;
   unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;
   difference = difference; properSubset = properSubset; subset = subset;
   properSubmapBy = properSubmapBy; submapBy = submapBy;
   sameMapBy = sameMapBy}

instance Ord k => A.FiniteMap (FM k) [k] where
  {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;
   intersectionWithKey = intersectionWithKey}

instance Ord k => A.OrdAssocX (FM k) [k] where
  {minView = minView; minElem = minElem; deleteMin = deleteMin;
   unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;
   deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;
   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
   unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;
   filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;
   filterGE = filterGE;  partitionLT_GE = partitionLT_GE;
   partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}

instance Ord k => A.OrdAssoc (FM k) [k] where
  {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;
   maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;
   foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';
   foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';
   toOrdSeq = toOrdSeq}

instance Ord k => A.OrdFiniteMapX (FM k) [k]
instance Ord k => A.OrdFiniteMap (FM k) [k]


instance Ord k => Functor (FM k) where
  fmap = map

instance (Ord k, Show k, Show a) => Show (FM k a) where
  showsPrec = showsPrecUsingToList

instance (Ord k, Read k, Read a) => Read (FM k a) where
  readsPrec = readsPrecUsingFromList

instance (Ord k, Eq a) => Eq (FM k a) where
  (==) = sameMap

instance (Ord k, Ord a) => Ord (FM k a) where
  compare = compareUsingToOrdList

--
-- Test code follows
--

keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool
keyInvariantFMB _ E = True
keyInvariantFMB p (I _ k _ l _ r)
  =    p k
    && keyInvariantFMB p l
    && keyInvariantFMB p r

actualSizeFMB :: FMB k a -> Int
actualSizeFMB E = 0
actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r

structuralInvariantFMB :: Ord k => FMB k a -> Bool
structuralInvariantFMB E = True
structuralInvariantFMB fmb@(I size k _ l (FMB' m) r)
  =    structuralInvariantFMB l
    && structuralInvariantFMB m
    && structuralInvariantFMB r
    && keyInvariantFMB (<k) l
    && keyInvariantFMB (>k) r
    && actualSizeFMB fmb == size
    && (sizel + sizer < 2
        || (sizel <= balance * sizer && sizer <= balance * sizel))
  where
      sizel = sizeFMB l
      sizer = sizeFMB r

structuralInvariant :: Ord k => FM k a -> Bool
structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb


instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where
  arbitrary = do xs <- arbitrary
                 return (Prelude.foldr (uncurry insert) empty xs)
  coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb


coarbitrary_maybe :: (Arbitrary t) => Maybe t    -> Test.QuickCheck.Gen b
                                                 -> Test.QuickCheck.Gen b
coarbitrary_maybe Nothing = variant 0
coarbitrary_maybe (Just x) = variant 1 . coarbitrary x

coarbitrary_fmb :: (Arbitrary t1, Arbitrary t) => FMB t t1 -> Gen a -> Gen a
coarbitrary_fmb E = variant 0
coarbitrary_fmb (I _ k x l (FMB' m) r) =
        variant 1 . coarbitrary k . coarbitrary_maybe x .
        coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r

instance Ord k => Monoid (FM k a) where
   mempty  = empty
   mappend = union
   mconcat = unionSeq