module Data.GMap.ListMap
(
ListMap
) where
import Prelude hiding (foldr,map,filter,lookup)
import Data.GMap
import Data.Typeable
import qualified Data.Foldable as F
import qualified Data.Monoid as M
import Data.Maybe hiding (mapMaybe)
import GHC.Base hiding (map)
import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault)
import qualified Data.List as L
data ListMap map k a
= Empt
| BraF ![k] a !(map (ListMap map k a))
| BraE ![k] !(map (ListMap map k a))
braE :: Map map k => [k] -> map (ListMap map k a) -> ListMap map k a
braE ks mp = case status mp of
None -> Empt
One _ Empt -> error "braE: Empty ListMap in tail map."
One k (BraF ks' a mp') -> BraF (ks ++ k:ks') a mp'
One k (BraE ks' mp') -> BraE (ks ++ k:ks') mp'
Many -> BraE ks mp
instance Map map k => Map (ListMap map k) [k] where
empty = emptyListMap
singleton = singletonListMap
pair = pairListMap
nonEmpty = nonEmptyListMap
status = statusListMap
addSize = addSizeListMap
lookup = lookupListMap
lookupCont = lookupContListMap
alter = alterListMap
insertWith = insertWithListMap
insertWith' = insertWithListMap'
insertMaybe = insertMaybeListMap
delete = deleteListMap
adjustWith = adjustWithListMap
adjustWith' = adjustWithListMap'
adjustMaybe = adjustMaybeListMap
venn = vennListMap
venn' = vennListMap'
vennMaybe = vennMaybeListMap
union = unionListMap
union' = unionListMap'
unionMaybe = unionMaybeListMap
intersection = intersectionListMap
intersection' = intersectionListMap'
intersectionMaybe = intersectionMaybeListMap
difference = differenceListMap
differenceMaybe = differenceMaybeListMap
isSubsetOf = isSubsetOfListMap
isSubmapOf = isSubmapOfListMap
map = mapListMap
map' = mapListMap'
mapMaybe = mapMaybeListMap
mapWithKey = mapWithKeyListMap
mapWithKey' = mapWithKeyListMap'
filter = filterListMap
foldKeys = foldKeysListMap
foldElems = foldElemsListMap
foldAssocs = foldAssocsListMap
foldKeys' = foldKeysListMap'
foldElems' = foldElemsListMap'
foldAssocs' = foldAssocsListMap'
foldElemsUInt = foldElemsUIntListMap
valid = validListMap
instance OrderedMap map k => OrderedMap (ListMap map k) [k] where
compareKey = compareKeyListMap
fromAssocsAscWith = fromAssocsAscWithListMap
fromAssocsDescWith = fromAssocsDescWithListMap
fromAssocsAscMaybe = fromAssocsAscMaybeListMap
fromAssocsDescMaybe = fromAssocsDescMaybeListMap
foldElemsAsc = foldElemsAscListMap
foldElemsDesc = foldElemsDescListMap
foldKeysAsc = foldKeysAscListMap
foldKeysDesc = foldKeysDescListMap
foldAssocsAsc = foldAssocsAscListMap
foldAssocsDesc = foldAssocsDescListMap
foldElemsAsc' = foldElemsAscListMap'
foldElemsDesc' = foldElemsDescListMap'
foldKeysAsc' = foldKeysAscListMap'
foldKeysDesc' = foldKeysDescListMap'
foldAssocsAsc' = foldAssocsAscListMap'
foldAssocsDesc' = foldAssocsDescListMap'
infixr 5 +!+
(+!+) :: [a] -> [a] -> [a]
[] +!+ ys = ys
(x:xs) +!+ ys = let xs' = xs +!+ ys in xs' `seq` x:xs'
revTo :: [a] -> [a] -> [a]
revTo [] ys = ys
revTo (x:xs) ys = revTo xs (x:ys)
takeN :: Int# -> [k] -> [k]
takeN 0# _ = []
takeN _ [] = error "Data.GMap.ListMap.takeN: List is too short."
takeN n (k:ks) = let ks_ = takeN (n -# 1#) ks in ks_ `seq` k:ks_
data Match map k a =
Mat
| Frk Int# (ListMap map k a -> ListMap map k a -> map (ListMap map k a)) [k] [k]
| Sfx Int# k [k]
| Sfy Int# k [k]
match :: Map map k => [k] -> [k] -> Match map k a
match xs0 ys0 = m 0# xs0 ys0
where m _ [] [] = Mat
m n [] (y:ys) = Sfy n y ys
m n (x:xs) [] = Sfx n x xs
m n (x:xs) (y:ys) = case pair x y of
Just f -> Frk n (\mpa mpb -> mpa `seq` mpb `seq` f mpa mpb) xs ys
Nothing -> m ((n) +# 1#) xs ys
badAssocs :: String
badAssocs = "Data.GMap.ListMap: Bad sorted association List."
emptyListMap :: ListMap map k a
emptyListMap = Empt
singletonListMap :: Map map k => [k] -> a -> ListMap map k a
singletonListMap ks a = BraF ks a empty
pairListMap :: Map map k => [k] -> [k] -> Maybe (a -> a -> ListMap map k a)
pairListMap xs0 ys0 = pr 0# xs0 ys0 where
pr _ [] [] = Nothing
pr _ [] (y:ys) = Just (\ax ay -> BraF xs0 ax (singleton y (BraF ys ay empty)))
pr _ (x:xs) [] = Just (\ax ay -> BraF ys0 ay (singleton x (BraF xs ax empty)))
pr n (x:xs) (y:ys) = case pair x y of
Just f -> Just (\ax ay -> BraE (takeN n xs0) (f (BraF xs ax empty) (BraF ys ay empty)))
Nothing -> pr ((n) +# 1#) xs ys
nonEmptyListMap :: ListMap map k a -> Maybe (ListMap map k a)
nonEmptyListMap Empt = Nothing
nonEmptyListMap lmp = Just lmp
statusListMap :: Map map k => ListMap map k a -> Status [k] a
statusListMap Empt = None
statusListMap (BraF ks a mp) = if (isEmpty mp) then (One ks a) else Many
statusListMap (BraE _ _ ) = Many
addSizeListMap :: Map map k => ListMap map k a -> Int# -> Int#
addSizeListMap Empt n = n
addSizeListMap (BraF _ _ mp) n = foldElemsUInt addSizeListMap ((n) +# 1#) mp
addSizeListMap (BraE _ mp) n = foldElemsUInt addSizeListMap n mp
lookupListMap :: Map map k => [k] -> ListMap map k a -> Maybe a
lookupListMap ks0 lmp0 = lmb ks0 lmp0 where
lmb _ Empt = Nothing
lmb ks (BraF ks' a mp) = pre ks ks' where
pre [] [] = Just a
pre [] (_:_ ) = Nothing
pre (x:xs) [] = case lookup x mp of
Just lmp -> lmb xs lmp
Nothing -> Nothing
pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing
lmb ks (BraE ks' mp) = pre ks ks' where
pre [] _ = Nothing
pre (x:xs) [] = case lookup x mp of
Just lmp -> lmb xs lmp
Nothing -> Nothing
pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing
lookupContListMap :: Map map k => (a -> Maybe b) -> [k] -> ListMap map k a -> Maybe b
lookupContListMap j ks0 lmp0 = lmb ks0 lmp0 where
lmb _ Empt = Nothing
lmb ks (BraF ks' a mp) = pre ks ks' where
pre [] [] = j a
pre [] (_:_ ) = Nothing
pre (x:xs) [] = lookupCont (lmb xs) x mp
pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing
lmb ks (BraE ks' mp) = pre ks ks' where
pre [] _ = Nothing
pre (x:xs) [] = lookupCont (lmb xs) x mp
pre (x:xs) (y:ys) = if x == y then pre xs ys else Nothing
deleteListMap :: Map map k => [k] -> ListMap map k a -> ListMap map k a
deleteListMap = adjustMaybeListMap (const Nothing)
adjustWithListMap :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a
adjustWithListMap f ks0 lmp0 = dmb ks0 lmp0 where
dmb _ Empt = Empt
dmb ks bf@(BraF ks' a mp) = pre ks ks' where
pre [] [] = BraF ks' (f a) mp
pre [] (_:_ ) = bf
pre (x:xs) [] = BraF ks' a (adjustWith (\lmp -> dmb xs lmp) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else bf
dmb ks be@(BraE ks' mp) = pre ks ks' where
pre [] _ = be
pre (x:xs) [] = braE ks' (adjustWith (\lmp -> dmb xs lmp) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else be
adjustWithListMap' :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a
adjustWithListMap' f ks0 lmp0 = dmb ks0 lmp0 where
dmb _ Empt = Empt
dmb ks bf@(BraF ks' a mp) = pre ks ks' where
pre [] [] = let newElem = f a
in newElem `seq` BraF ks' newElem mp
pre [] (_:_ ) = bf
pre (x:xs) [] = BraF ks' a (adjustWith' (\lmp -> dmb xs lmp) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else bf
dmb ks be@(BraE ks' mp) = pre ks ks' where
pre [] _ = be
pre (x:xs) [] = braE ks' (adjustWith' (\lmp -> dmb xs lmp) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else be
adjustMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a
adjustMaybeListMap f ks0 lmp0 = dmb ks0 lmp0 where
dmb _ Empt = Empt
dmb ks bf@(BraF ks' a mp) = pre ks ks' where
pre [] [] = case f a of Just a' -> BraF ks' a' mp
Nothing -> braE ks' mp
pre [] (_:_ ) = bf
pre (x:xs) [] = BraF ks' a (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else bf
dmb ks be@(BraE ks' mp) = pre ks ks' where
pre [] _ = be
pre (x:xs) [] = braE ks' (adjustMaybe (\lmp -> nonEmptyListMap (dmb xs lmp)) x mp)
pre (x:xs) (y:ys) = if x == y then pre xs ys else be
vennListMap :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)
vennListMap f lmp0 lmp1 = v lmp0 lmp1 where
appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx
appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx
appendStem _ _ Empt = Empt
replace k m mp = alter' (const (nonEmpty m)) k mp
vennInner mpx mpy = (leftDiff,inter,rightDiff)
where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)
inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi
rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)
(mpl,mpi,mpr) = venn' (venn f) mpx mpy
v Empt lmpy = (Empt,Empt,lmpy)
v lmpx Empt = (lmpx,Empt,Empt)
v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,BraF xs0 (f a b) inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (BraF xs0 a leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,BraF xs0 b rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
vennListMap' :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)
vennListMap' f lmp0 lmp1 = v lmp0 lmp1 where
appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx
appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx
appendStem _ _ Empt = Empt
replace k m mp = alter' (const (nonEmpty m)) k mp
vennInner mpx mpy = (leftDiff,inter,rightDiff)
where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)
inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi
rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)
(mpl,mpi,mpr) = venn' (venn' f) mpx mpy
v Empt lmpy = (Empt,Empt,lmpy)
v lmpx Empt = (lmpx,Empt,Empt)
v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,let c = f a b in c `seq` BraF xs0 c inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (BraF xs0 a leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,BraF xs0 b rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
vennMaybeListMap :: Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> (ListMap map k a, ListMap map k c, ListMap map k b)
vennMaybeListMap f lmp0 lmp1 = v lmp0 lmp1 where
appendStem ys y (BraF xs a mpx) = BraF (ys +!+ y:xs) a mpx
appendStem ys y (BraE xs mpx) = BraE (ys +!+ y:xs) mpx
appendStem _ _ Empt = Empt
replace k m mp = alter' (const (nonEmpty m)) k mp
vennInner mpx mpy = (leftDiff,inter,rightDiff)
where leftDiff = disjointUnion mpl (mapMaybe (\(l,_,_) -> nonEmpty l) mpi)
inter = mapMaybe (\(_,i,_) -> nonEmpty i) mpi
rightDiff = disjointUnion mpr (mapMaybe (\(_,_,r) -> nonEmpty r) mpi)
(mpl,mpi,mpr) = venn (vennMaybe f) mpx mpy
v Empt lmpy = (Empt,Empt,lmpy)
v lmpx Empt = (lmpx,Empt,Empt)
v lmpx@(BraF xs0 a mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,case f a b of
Nothing -> braE xs0 inter
Just c -> BraF xs0 c inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraF xs0 a mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (BraF xs0 a leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraF xs a mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraF xs0 a mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraF xs0 a (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,BraF xs0 b rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraF ys0 b (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraF ys b mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraF ys0 b mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
v lmpx@(BraE xs0 mpx) lmpy@(BraE ys0 mpy) = m xs0 ys0 where
m [] [] = (braE xs0 leftDiff
,braE xs0 inter
,braE xs0 rightDiff)
where (leftDiff,inter,rightDiff) = vennInner mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> (lmpx,Empt,lmpy)
Just lmpb -> case v (BraE xs mpx) lmpb of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(_,i ,r) -> (difference
(BraE xs0 mpx)
(appendStem ys0 x i)
,appendStem ys0 x i
,BraE ys0 (replace x r mpy))
m [] (y:ys) = case lookup y mpx of Nothing -> (lmpx,Empt,lmpy)
Just lmpa -> case v lmpa (BraE ys mpy) of
(_,Empt,_) -> (lmpx,Empt,lmpy)
(l,i ,_) -> (BraE xs0 (replace y l mpx)
,appendStem xs0 y i
,difference
(BraE ys0 mpy)
(appendStem xs0 y i))
m (x:xs) (y:ys) = if x == y then m xs ys else (lmpx,Empt,lmpy)
unionListMap :: Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a
unionListMap f lmp0 lmp1 = u lmp0 lmp1 where
u Empt lmp = lmp
u lmp Empt = lmp
u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> BraF xs0 (f ax ay) (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy))
Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braFx mpy)
where f' lmp = u braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx)
where f' lmp = u lmp braFy
braFy = BraF ys ay mpy
u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ax (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy))
Sfx _ x xs -> BraE ys0 (insertWith' f' x braFx mpy)
where f' lmp = u braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx)
where f' lmp = u lmp braEy
braEy = BraE ys mpy
u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ay (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy))
Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braEx mpy)
where f' lmp = u braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx)
where f' lmp = u lmp braFy
braFy = BraF ys ay mpy
u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> BraE xs0 (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))
Sfx _ x xs -> BraE ys0 (insertWith' f' x braEx mpy)
where f' lmp = u braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx)
where f' lmp = u lmp braEy
braEy = BraE ys mpy
unionListMap' :: Map map k => (a -> a -> a) -> ListMap map k a -> ListMap map k a -> ListMap map k a
unionListMap' f lmp0 lmp1 = u lmp0 lmp1 where
u Empt lmp = lmp
u lmp Empt = lmp
u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> let a = f ax ay in a `seq` BraF xs0 a (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` right `seq` f' left right)
where left = BraF xs ax mpx
right = BraF ys ay mpy
Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braFx mpy)
where f' lmp = u braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx)
where f' lmp = u lmp braFy
braFy = BraF ys ay mpy
u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ax (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (left `seq` f' left right)
where left = BraF xs ax mpx
right = BraE ys mpy
Sfx _ x xs -> BraE ys0 (insertWith' f' x braFx mpy)
where f' lmp = u braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx)
where f' lmp = u lmp braEy
braEy = BraE ys mpy
u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ay (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (right `seq` f' left right)
where left = BraE xs mpx
right = BraF ys ay mpy
Sfx _ x xs -> BraF ys0 ay (insertWith' f' x braEx mpy)
where f' lmp = u braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx)
where f' lmp = u lmp braFy
braFy = BraF ys ay mpy
u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> BraE xs0 (union' u mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))
Sfx _ x xs -> BraE ys0 (insertWith' f' x braEx mpy)
where f' lmp = u braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx)
where f' lmp = u lmp braEy
braEy = BraE ys mpy
unionMaybeListMap :: Map map k => (a -> a -> Maybe a) -> ListMap map k a -> ListMap map k a -> ListMap map k a
unionMaybeListMap f lmp0 lmp1 = u lmp0 lmp1 where
uNE lmpx lmpy = nonEmptyListMap (u lmpx lmpy)
u Empt lmp = lmp
u lmp Empt = lmp
u (BraF xs0 ax mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> case f ax ay of
Just a -> BraF xs0 a (unionMaybe' uNE mpx mpy)
Nothing -> braE xs0 (unionMaybe' uNE mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraF ys ay mpy))
Sfx _ x xs -> BraF ys0 ay (insertMaybe' f' x braFx mpy)
where f' lmp = uNE braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertMaybe' f' y braFy mpx)
where f' lmp = uNE lmp braFy
braFy = BraF ys ay mpy
u (BraF xs0 ax mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ax (unionMaybe' uNE mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraF xs ax mpx) (BraE ys mpy))
Sfx _ x xs -> braE ys0 (insertMaybe' f' x braFx mpy)
where f' lmp = uNE braFx lmp
braFx = BraF xs ax mpx
Sfy _ y ys -> BraF xs0 ax (insertMaybe' f' y braEy mpx)
where f' lmp = uNE lmp braEy
braEy = BraE ys mpy
u (BraE xs0 mpx) (BraF ys0 ay mpy) = case match xs0 ys0 of
Mat -> BraF xs0 ay (unionMaybe' uNE mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraF ys ay mpy))
Sfx _ x xs -> BraF ys0 ay (insertMaybe' f' x braEx mpy)
where f' lmp = uNE braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> braE xs0 (insertMaybe' f' y braFy mpx)
where f' lmp = uNE lmp braFy
braFy = BraF ys ay mpy
u (BraE xs0 mpx) (BraE ys0 mpy) = case match xs0 ys0 of
Mat -> braE xs0 (unionMaybe' uNE mpx mpy)
Frk n f' xs ys -> BraE (takeN n xs0) (f' (BraE xs mpx) (BraE ys mpy))
Sfx _ x xs -> braE ys0 (insertMaybe' f' x braEx mpy)
where f' lmp = uNE braEx lmp
braEx = BraE xs mpx
Sfy _ y ys -> braE xs0 (insertMaybe' f' y braEy mpx)
where f' lmp = uNE lmp braEy
braEy = BraE ys mpy
intersectionListMap :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c
intersectionListMap f lmp0 lmp1 = i lmp0 lmp1 where
iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy)
i Empt _ = Empt
i _ Empt = Empt
i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = BraF xs0 (f a b) (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
intersectionListMap' :: Map map k => (a -> b -> c) -> ListMap map k a -> ListMap map k b -> ListMap map k c
intersectionListMap' f lmp0 lmp1 = i lmp0 lmp1 where
iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy)
i Empt _ = Empt
i _ Empt = Empt
i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = let c = f a b in c `seq` BraF xs0 c (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
intersectionMaybeListMap :: Map map k => (a -> b -> Maybe c) -> ListMap map k a -> ListMap map k b -> ListMap map k c
intersectionMaybeListMap f lmp0 lmp1 = i lmp0 lmp1 where
iNE lmpx lmpy = nonEmptyListMap (i lmpx lmpy)
i Empt _ = Empt
i _ Empt = Empt
i (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = case f a b of
Just c -> BraF xs0 c (intersectionMaybe' iNE mpx mpy)
Nothing -> braE xs0 (intersectionMaybe' iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraF ys b mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
i (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (intersectionMaybe' iNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> Empt
Just lmpb -> case i (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs c mpz -> BraF (ys0 +!+ x:zs) c mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = case lookup y mpx of Nothing -> Empt
Just lmpa -> case i lmpa (BraE ys mpy) of
Empt -> Empt
BraF zs c mpz -> BraF (xs0 +!+ y:zs) c mpz
BraE zs mpz -> BraE (xs0 +!+ y:zs) mpz
m (x:xs) (y:ys) = if x == y then m xs ys else Empt
differenceListMap :: Map map k => ListMap map k a -> ListMap map k b -> ListMap map k a
differenceListMap lmp0 lmp1 = d lmp0 lmp1 where
dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy)
d Empt _ = Empt
d lmpx Empt = lmpx
d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = BraF xs0 a (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
differenceMaybeListMap :: Map map k => (a -> b -> Maybe a) -> ListMap map k a -> ListMap map k b -> ListMap map k a
differenceMaybeListMap f lmp0 lmp1 = d lmp0 lmp1 where
dNE lmpx lmpy = nonEmptyListMap (d lmpx lmpy)
d Empt _ = Empt
d lmpx Empt = lmpx
d lmpx@(BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = case f a b of
Nothing -> braE xs0 (differenceMaybe' dNE mpx mpy)
Just a' -> BraF xs0 a' (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = BraF xs0 a (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraF xs a mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = BraF xs0 a (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraE xs0 mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraF ys b mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
d lmpx@(BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = braE xs0 (differenceMaybe' dNE mpx mpy)
m (x:xs) [] = case lookup x mpy of Nothing -> lmpx
Just lmpb -> case d (BraE xs mpx) lmpb of
Empt -> Empt
BraF zs a' mpz -> BraF (ys0 +!+ x:zs) a' mpz
BraE zs mpz -> BraE (ys0 +!+ x:zs) mpz
m [] (y:ys) = braE xs0 (adjustMaybe' (\lmpa -> dNE lmpa (BraE ys mpy)) y mpx)
m (x:xs) (y:ys) = if x==y then m xs ys else lmpx
isSubsetOfListMap :: Map map k => ListMap map k a -> ListMap map k b -> Bool
isSubsetOfListMap Empt _ = True
isSubsetOfListMap _ Empt = False
isSubsetOfListMap (BraF xs0 a mpx) (BraF ys0 _ mpy) = m xs0 ys0 where
m [] [] = isSubmapOf isSubsetOfListMap mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
isSubsetOfListMap (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = False
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> isSubsetOfListMap (BraF xs a mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
isSubsetOfListMap (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where
m [] [] = isSubmapOf isSubsetOfListMap mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
isSubsetOfListMap (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = isSubmapOf isSubsetOfListMap mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> isSubsetOfListMap (BraE xs mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
isSubmapOfListMap :: Map map k => (a -> b -> Bool) -> ListMap map k a -> ListMap map k b -> Bool
isSubmapOfListMap p lmp0 lmp1 = d lmp0 lmp1 where
d Empt _ = True
d _ Empt = False
d (BraF xs0 a mpx) (BraF ys0 b mpy) = m xs0 ys0 where
m [] [] = if p a b then isSubmapOf d mpx mpy else False
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> d (BraF xs a mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
d (BraF xs0 a mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = False
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> d (BraF xs a mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
d (BraE xs0 mpx) (BraF ys0 _ mpy) = m xs0 ys0 where
m [] [] = isSubmapOf d mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> d (BraE xs mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
d (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = isSubmapOf d mpx mpy
m (x:xs) [] = case lookup x mpy of Nothing -> False
Just lmpb -> d (BraE xs mpx) lmpb
m [] (_:_ ) = False
m (x:xs) (y:ys) = if x==y then m xs ys else False
alterListMap :: Map map k => (Maybe a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a
alterListMap f xs0 lmp0 = iw xs0 lmp0 where
iwNE xs (Just lmp) = nonEmptyListMap (iw xs lmp)
iwNE xs Nothing = nonEmptyListMap (iw xs empty)
iw xs Empt = case (f Nothing) of
Just ax -> BraF xs ax empty
Nothing -> Empt
iw xs m@(BraF ys ay mp) = case match xs ys of
Mat -> case (f (Just ay)) of
Just ax -> BraF ys ax mp
Nothing -> braE ys mp
Frk n f' xs' ys' -> case (f Nothing) of
Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))
Nothing -> m
Sfy _ y' ys' -> case (f Nothing) of
Just ax -> BraF xs ax (singleton y' (BraF ys' ay mp))
Nothing -> m
Sfx _ x' xs' -> BraF ys ay (alter (iwNE xs') x' mp)
iw xs m@(BraE ys mp) = case match xs ys of
Mat -> case (f Nothing) of
Just ax -> BraF ys ax mp
Nothing -> m
Frk n f' xs' ys' -> case (f Nothing) of
Just ax -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))
Nothing -> m
Sfy _ y' ys' -> case (f Nothing) of
Just ax -> BraF xs ax (singleton y' (BraE ys' mp))
Nothing -> m
Sfx _ x' xs' -> braE ys (alter (iwNE xs') x' mp)
insertWithListMap :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a
insertWithListMap f xs0 ax lmp0 = iw xs0 lmp0 where
iw xs Empt = BraF xs ax empty
iw xs (BraF ys ay mp) = case match xs ys of
Mat -> BraF ys (f ay) mp
Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))
Sfy _ y' ys' -> BraF xs ax (singleton y' (BraF ys' ay mp))
Sfx _ x' xs' -> BraF ys ay (insertWith' (iw xs') x' (BraF xs' ax empty) mp)
iw xs (BraE ys mp) = case match xs ys of
Mat -> BraF ys ax mp
Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))
Sfy _ y' ys' -> BraF xs ax (singleton y' (BraE ys' mp))
Sfx _ x' xs' -> BraE ys (insertWith' (iw xs') x' (BraF xs' ax empty) mp)
insertWithListMap' :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a
insertWithListMap' f xs0 ax lmp0 = iw xs0 lmp0 where
iw xs Empt = ax `seq` BraF xs ax empty
iw xs (BraF ys ay mp) = case match xs ys of
Mat -> let ay' = f ay in ay' `seq` BraF ys ay' mp
Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))
Sfy _ y' ys' -> ax `seq` BraF xs ax (singleton y' (BraF ys' ay mp))
Sfx _ x' xs' -> BraF ys ay (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp)
iw xs (BraE ys mp) = case match xs ys of
Mat -> ax `seq` BraF ys ax mp
Frk n f' xs' ys' -> ax `seq` BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))
Sfy _ y' ys' -> ax `seq` BraF xs ax (singleton y' (BraE ys' mp))
Sfx _ x' xs' -> BraE ys (insertWith' (iw xs') x' (ax `seq` (BraF xs' ax empty)) mp)
insertMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> a -> ListMap map k a -> ListMap map k a
insertMaybeListMap f xs0 ax lmp0 = iw xs0 lmp0 where
iwNE xs lmp = nonEmptyListMap (iw xs lmp)
iw xs Empt = BraF xs ax empty
iw xs (BraF ys ay mp) = case match xs ys of
Mat -> case f ay of
Just ay' -> BraF ys ay' mp
Nothing -> braE ys mp
Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraF ys' ay mp))
Sfy _ y' ys' -> BraF xs ax (singleton y' (BraF ys' ay mp))
Sfx _ x' xs' -> BraF ys ay (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp)
iw xs (BraE ys mp) = case match xs ys of
Mat -> BraF ys ax mp
Frk n f' xs' ys' -> BraE (takeN n ys) (f' (BraF xs' ax empty) (BraE ys' mp))
Sfy _ y' ys' -> BraF xs ax (singleton y' (BraE ys' mp))
Sfx _ x' xs' -> braE ys (insertMaybe (iwNE xs') x' (BraF xs' ax empty) mp)
foldElemsListMap :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsListMap f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = f a (foldElems fld b mp)
fld (BraE _ mp) b = foldElems fld b mp
foldKeysListMap :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocs f' b mp)
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocs f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsListMap :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocs f' b mp)
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocs f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldElemsListMap' :: Map map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsListMap' f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = let b' = foldElems' fld b mp in b' `seq` f a b'
fld (BraE _ mp) b = foldElems' fld b mp
foldKeysListMap' :: Map map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b''
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = foldAssocs' f' b mp
fld rks (BraE ks mp) b = foldAssocs' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsListMap' :: Map map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b''
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = foldAssocs' f' b mp
fld rks (BraE ks mp) b = foldAssocs' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
clump :: (Eq a) => [([a], b)] -> [a] -> ([b], [(a, [([a], b)])])
clump as prefix =
if null nonNulls
then (L.map snd nulls, [])
else (L.map snd nulls, clumps' [(k',c' [])])
where f (currentKey,currentClump,clumps) (key,tl) =
if key == currentKey
then (currentKey, currentClump . (tl:), clumps )
else (key, (tl:), clumps . ((currentKey,currentClump []):) )
(nulls,nonNulls) = L.partition (null . fst) $ L.map (\(k,a) -> (fromJust $ L.stripPrefix prefix k,a)) as
rest = L.map (\(k:ks,a) -> (k,(ks,a))) nonNulls
(k',c',clumps') = L.foldl' f (fst $ head rest,id,id) rest
commonPrefix :: (Eq a) => [([a], b)] -> [a]
commonPrefix as = common (fst $ head as) (fst $ last as)
where common [] _ = []
common _ [] = []
common (ka:kas) (kb:kbs) =
if ka == kb
then ka : common kas kbs
else []
fromAssocsAscWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a
fromAssocsAscWithListMap _ [] = emptyListMap
fromAssocsAscWithListMap f as =
case nulls of
[] -> braE prefix (fromAssocsAsc innerAs)
_ -> BraF prefix (L.foldl1' f nulls) (fromAssocsAsc innerAs)
where (nulls,clumps) = clump as prefix
prefix = commonPrefix as
innerAs = L.map (\(k,as') -> (k,fromAssocsAscWith f as')) clumps
fromAssocsDescWithListMap :: OrderedMap map k => (a -> a -> a) -> [([k],a)] -> ListMap map k a
fromAssocsDescWithListMap _ [] = emptyListMap
fromAssocsDescWithListMap f as =
case nulls of
[] -> braE prefix (fromAssocsDesc innerAs)
_ -> BraF prefix (L.foldl1' f nulls) (fromAssocsDesc innerAs)
where (nulls,clumps) = clump as prefix
prefix = commonPrefix as
innerAs = L.map (\(k,as') -> (k,fromAssocsDescWith f as')) clumps
fromAssocsAscMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a
fromAssocsAscMaybeListMap _ [] = emptyListMap
fromAssocsAscMaybeListMap f as =
case L.foldl' insNull Nothing nulls of
Nothing -> braE prefix (fromAssocsAsc innerAs)
Just a -> BraF prefix a (fromAssocsAsc innerAs)
where insNull Nothing b = Just b
insNull (Just a) b = f a b
(nulls,clumps) = clump as prefix
prefix = commonPrefix as
innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsAscMaybe f as'; return (k,mp)) clumps
fromAssocsDescMaybeListMap :: OrderedMap map k => (a -> a -> Maybe a) -> [([k],a)] -> ListMap map k a
fromAssocsDescMaybeListMap _ [] = emptyListMap
fromAssocsDescMaybeListMap f as =
case L.foldl' insNull Nothing nulls of
Nothing -> braE prefix (fromAssocsDesc innerAs)
Just a -> BraF prefix a (fromAssocsDesc innerAs)
where insNull Nothing b = Just b
insNull (Just a) b = f a b
(nulls,clumps) = clump as prefix
prefix = commonPrefix as
innerAs = catMaybes $ L.map (\(k,as') -> do mp <- nonEmpty $ fromAssocsDescMaybe f as'; return (k,mp)) clumps
foldElemsAscListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsAscListMap f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = f a (foldElemsAsc fld b mp)
fld (BraE _ mp) b = foldElemsAsc fld b mp
foldElemsDescListMap :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsDescListMap f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = foldElemsDesc fld (f a b) mp
fld (BraE _ mp) b = foldElemsDesc fld b mp
foldKeysAscListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysAscListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = f (revTo rks ks) (foldAssocsAsc f' b mp)
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocsAsc f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldKeysDescListMap :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysDescListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = foldAssocsDesc f' (f (revTo rks ks) b) mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocsDesc f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsAscListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsAscListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = f (revTo rks ks) a (foldAssocsAsc f' b mp)
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocsAsc f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsDescListMap :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsDescListMap f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = foldAssocsDesc f' (f (revTo rks ks) a b) mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
fld rks (BraE ks mp) b = foldAssocsDesc f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldElemsAscListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsAscListMap' f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = let b' = foldElemsAsc' fld b mp in b' `seq` f a b'
fld (BraE _ mp) b = foldElemsAsc' fld b mp
foldElemsDescListMap' :: OrderedMap map k => (a -> b -> b) -> b -> ListMap map k a -> b
foldElemsDescListMap' f b0 lmp0 = fld lmp0 b0 where
fld Empt b = b
fld (BraF _ a mp) b = let b' = f a b in b' `seq` foldElemsDesc' fld b' mp
fld (BraE _ mp) b = foldElemsDesc' fld b mp
foldKeysAscListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysAscListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = b'' `seq` f (revTo rks ks) b''
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = foldAssocsAsc' f' b mp
fld rks (BraE ks mp) b = foldAssocsAsc' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldKeysDescListMap' :: OrderedMap map k => ([k] -> b -> b) -> b -> ListMap map k a -> b
foldKeysDescListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks _ mp) b = b'' `seq` foldAssocsDesc' f' b'' mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = f (revTo rks ks) b
fld rks (BraE ks mp) b = foldAssocsDesc' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsAscListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsAscListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = b'' `seq` f (revTo rks ks) a b''
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = foldAssocsAsc' f' b mp
fld rks (BraE ks mp) b = foldAssocsAsc' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldAssocsDescListMap' :: OrderedMap map k => ([k] -> a -> b -> b) -> b -> ListMap map k a -> b
foldAssocsDescListMap' f b0 lmp0 = fld [] lmp0 b0 where
fld _ Empt b = b
fld rks (BraF ks a mp) b = b'' `seq` foldAssocsDesc' f' b'' mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
b'' = f (revTo rks ks) a b
fld rks (BraE ks mp) b = foldAssocsDesc' f' b mp
where f' k lmp b' = fld (k : revTo ks rks) lmp b'
foldElemsUIntListMap :: Map map k => (a -> Int# -> Int#) -> Int# -> ListMap map k a -> Int#
foldElemsUIntListMap f n0 lmp0 = fld lmp0 n0 where
fld Empt n = n
fld (BraF _ a mp) n = foldElemsUInt fld (f a n) mp
fld (BraE _ mp) n = foldElemsUInt fld n mp
mapListMap :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b
mapListMap _ Empt = Empt
mapListMap f (BraF ks a mp) = BraF ks (f a) (map' (mapListMap f) mp)
mapListMap f (BraE ks mp) = BraE ks (map' (mapListMap f) mp)
mapListMap' :: Map map k => (a -> b) -> ListMap map k a -> ListMap map k b
mapListMap' _ Empt = Empt
mapListMap' f (BraF ks a mp) = let b = f a in b `seq` BraF ks b (map' (mapListMap' f) mp)
mapListMap' f (BraE ks mp) = BraE ks (map' (mapListMap' f) mp)
mapMaybeListMap :: Map map k => (a -> Maybe b) -> ListMap map k a -> ListMap map k b
mapMaybeListMap _ Empt = Empt
mapMaybeListMap f (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp
in case f a of Just b -> BraF ks b mp'
Nothing -> braE ks mp'
mapMaybeListMap f (BraE ks mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (mapMaybeListMap f lmp)) mp
in braE ks mp'
mapWithKeyListMap :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b
mapWithKeyListMap f mp = mwk id mp where
mwk _ Empt = Empt
mwk kcont (BraF ks a mp') = BraF ks (f (kcont ks) a) (mapWithKey' f' mp')
where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp
mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp')
where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp
mapWithKeyListMap' :: Map map k => ([k] -> a -> b) -> ListMap map k a -> ListMap map k b
mapWithKeyListMap' f mp = mwk id mp where
mwk _ Empt = Empt
mwk kcont (BraF ks a mp') = let b = f (kcont ks) a
in b `seq` BraF ks b (mapWithKey' f' mp')
where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp
mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp')
where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp
filterListMap :: Map map k => (a -> Bool) -> ListMap map k a -> ListMap map k a
filterListMap p lmp0 = flt lmp0 where
flt Empt = Empt
flt (BraF ks a mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp
in if p a then BraF ks a mp'
else braE ks mp'
flt (BraE ks mp) = let mp' = mapMaybe (\lmp -> nonEmptyListMap (flt lmp)) mp
in braE ks mp'
validListMap :: Map map k => ListMap map k a -> Maybe String
validListMap Empt = Nothing
validListMap lmp = validListMap' lmp
validListMap' :: Map map k => ListMap map k a -> Maybe String
validListMap' Empt = Just "ListMap: Non-empty map contains Empt node."
validListMap' (BraF _ _ mp) = case valid mp of
Nothing -> foldElems valAccum Nothing mp
Just s -> Just ("ListMap:" ++ s)
validListMap' (BraE _ mp) = case valid mp of
Nothing -> case status mp of
None -> Just ("ListMap: Empty branch map in BraE node.")
One _ _ -> Just ("ListMap: Singleton branch map in BraE node.")
Many -> foldElems valAccum Nothing mp
Just s -> Just ("ListMap:" ++ s)
valAccum :: Map map k => ListMap map k a -> Maybe String -> Maybe String
valAccum lmp Nothing = validListMap' lmp
valAccum _ just = just
compareKeyListMap :: OrderedMap map k => ListMap map k a -> [k] -> [k] -> Ordering
compareKeyListMap _ [] [] = EQ
compareKeyListMap _ _ [] = GT
compareKeyListMap _ [] _ = LT
compareKeyListMap mp (x:xs) (y:ys) =
case (compareKey (innerMap mp) x y) of
GT -> GT
EQ -> compareKeyListMap mp xs ys
LT -> LT
where innerMap :: ListMap map k a -> map a
innerMap _ = undefined
instance (Eq k, Eq a, Eq (map (ListMap map k a))) => Eq (ListMap map k a) where
Empt == Empt = True
BraF ks0 a0 mp0 == BraF ks1 a1 mp1 = (ks0==ks1) && (a0==a1) && (mp0==mp1)
BraE ks0 mp0 == BraE ks1 mp1 = (ks0==ks1) && (mp0==mp1)
_ == _ = False
instance (Map map k, Ord k, Ord a, Ord (map (ListMap map k a))) => Ord (ListMap map k a) where
compare Empt Empt = EQ
compare Empt _ = LT
compare _ Empt = GT
compare (BraF xs0 ax mpx) (BraF ys0 ay mpy) = m xs0 ys0 where
m [] [] = case compare ax ay of
LT -> LT
EQ -> compare mpx mpy
GT -> GT
m (_:_ ) [] = GT
m [] (_:_ ) = LT
m (x:xs) (y:ys) = case compare x y of
LT -> LT
EQ -> m xs ys
GT -> GT
compare (BraF xs0 ax mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] _ = LT
m (x:xs) [] = let sx = singleton x (BraF xs ax mpx) in sx `seq` compare sx mpy
m (x:xs) (y:ys) = case compare x y of
LT -> LT
EQ -> m xs ys
GT -> GT
compare (BraE xs0 mpx) (BraF ys0 ay mpy) = m xs0 ys0 where
m _ [] = GT
m [] (y:ys) = let sy = singleton y (BraF ys ay mpy) in sy `seq` compare mpx sy
m (x:xs) (y:ys) = case compare x y of
LT -> LT
EQ -> m xs ys
GT -> GT
compare (BraE xs0 mpx) (BraE ys0 mpy) = m xs0 ys0 where
m [] [] = compare mpx mpy
m (x:xs) [] = let sx = singleton x (BraE xs mpx) in sx `seq` compare sx mpy
m [] (y:ys) = let sy = singleton y (BraE ys mpy) in sy `seq` compare mpx sy
m (x:xs) (y:ys) = case compare x y of
LT -> LT
EQ -> m xs ys
GT -> GT
instance (Map map k, Show k, Show a) => Show (ListMap map k a) where
showsPrec d mp = showParen (d > 10) $
showString "fromAssocs " . shows (assocs mp)
instance (Map map k, R.Read k, R.Read a) => R.Read (ListMap map k a) where
readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP
xs <- R.readPrec
return (fromAssocs xs)
readListPrec = R.readListPrecDefault
instance (Typeable1 map,Typeable k) => Typeable1 (ListMap map k) where
typeOf1 mp = mkTyConApp (mkTyCon "Data.GMap.ListMap.ListMap") [typeOf1 m, typeOf k]
where BraF [k] _ m = mp
instance (Typeable1 (ListMap map k), Typeable a) => Typeable (ListMap map k a) where
typeOf = typeOfDefault
instance Map map k => Functor (ListMap map k) where
fmap = mapListMap
instance (Map map k, M.Monoid a) => M.Monoid (ListMap map k a) where
mempty = emptyListMap
mappend map0 map1 = unionListMap M.mappend map0 map1
mconcat maps = L.foldr (unionListMap M.mappend) emptyListMap maps
instance Map map k => F.Foldable (ListMap map k) where
fold mp = foldElemsListMap M.mappend M.mempty mp
foldMap f mp = foldElemsListMap (\a b -> M.mappend (f a) b) M.mempty mp
foldr f b0 mp = foldElemsListMap f b0 mp
foldl f b0 mp = foldElemsListMap (flip f) b0 mp