diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/runhaskell +import Distribution.Simple +main = defaultMain diff --git a/gmap.cabal b/gmap.cabal new file mode 100644 --- /dev/null +++ b/gmap.cabal @@ -0,0 +1,35 @@ +name: gmap +version: 0.1 +category: Data Structures +license: BSD3 +description: + Provides typeclass for and several implementations of composable maps and generic tries. + OrdMap is roughly equivalent to Data.Map . + ListMap, EitherMap, MaybeMap, TupleMap and EnumMap allow you to break down the corresponding types. + InjectKeys is the easiest way to define tries on your own types, see EitherMap for a simple example. + ChoiceMap and TupleMap correspond to sum and product types, respectively. + The type-level syntax for creating maps is currently unwieldy. This will improve significantly in the next version. +author: Jamie Brandon, Adrian Hey +maintainer: jamiiecb (google mail) +synopsis: Composable maps and generic tries. +build-depends: base >= 3.0, QuickCheck, array, COrdering, AvlTree >= 4.2, random +build-type: Simple +exposed-modules: + Data.GMap + Data.GMap.AssocList + Data.GMap.OrdMap + Data.GMap.IntMap + Data.GMap.ListMap + Data.GMap.EitherMap + Data.GMap.UnitMap + Data.GMap.MaybeMap + Data.GMap.CacheKeys + Data.GMap.ChoiceMap + Data.GMap.EnumMap + Data.GMap.InjectKeys + Data.GMap.TupleMap + Test.GMap + Test.GMap.Utils +hs-source-dirs: src +-- include-dirs: include +ghc-options: -O2 -Wall diff --git a/src/Data/GMap.hs b/src/Data/GMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap.hs @@ -0,0 +1,700 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall #-} + +module Data.GMap ( +Map +,empty +,singleton +,pair +,fromAssocsWith +,fromAssocsMaybe +,status +,nonEmpty +,addSize +,lookup +,lookupCont +,alter +,insertWith +,insertWith' +,insertMaybe +,delete +,adjustWith +,adjustWith' +,adjustMaybe +,venn +,venn' +,vennMaybe +,union +,union' +,unionMaybe +,disjointUnion +,intersection +,intersection' +,intersectionMaybe +,difference +,differenceMaybe +,isSubsetOf +,isSubmapOf +,Data.GMap.map +,map' +,mapMaybe +,mapWithKey +,mapWithKey' +,Data.GMap.filter +,foldElems +,foldKeys +,foldAssocs +,foldElems' +,foldKeys' +,foldAssocs' +,foldElemsUInt +,valid +,disjointUnionError +,Status(None,One,Many) +,vennMaybe' +,alter' +,adjustMaybe' +,insertMaybe' +,unionMaybe' +,intersectionMaybe' +,differenceMaybe' +,mapMaybe' +,isEmpty +,isSingleton +,insert +,insert' +,size +,insertAssocs +,insertAssocsWith +,insertAssocsMaybe +,fromAssocs +,lookupM +,keys +,elems +,assocs +,OrderedMap +,compareKey +,fromAssocsAscWith +,fromAssocsAscMaybe +,fromAssocsDescWith +,fromAssocsDescMaybe +,foldElemsAsc +,foldElemsDesc +,foldKeysAsc +,foldKeysDesc +,foldAssocsAsc +,foldAssocsDesc +,foldElemsAsc' +,foldElemsDesc' +,foldKeysAsc' +,foldKeysDesc' +,foldAssocsAsc' +,foldAssocsDesc' +,fromAssocsAsc +,fromAssocsDesc +,insertAssocsAsc +,insertAssocsDesc +,insertAssocsAscWith +,insertAssocsDescWith +,insertAssocsAscMaybe +,insertAssocsDescMaybe +,elemsAsc +,elemsDesc +,assocsAsc +,assocsDesc +,keysAsc +,keysDesc +,isProperSubsetOf +,isProperSubmapOfBy +-- Partitions are not implemented yet +-- ,partition +-- ,partitionMaybe +-- ,partitionAscList +-- ,partitionDescList +-- ,partitionAscListMaybe +-- ,partitionDescListMaybe +,sortAscWith +,sortDescWith +,nubAscWith +,nubDescWith +) +where + +-- import Data.Foldable +-- import Data.Traversable +import GHC.Base +import qualified Data.List as L +import Prelude hiding (map,lookup) + +import Control.Monad +import Data.Maybe(maybe) + +forceMaybe :: Maybe a -> Maybe a +forceMaybe Nothing = Nothing +forceMaybe (Just a) = a `seq` Just a + +on :: (c -> d) -> (a -> b -> c) -> a -> b -> d +on f g a b = f $ g a b + +-- | Type of composable maps. +-- For an example of a composed map see Data.GMap.ListMap +class (Eq k) => Map map k | map -> k where + + -- | The empty map. + empty :: map a + + -- | Create a map with a single association. + singleton :: k -> a -> map a + singleton k a = insert k a empty + + -- | Compare two keys and if they are /different/ return a function that will create + -- a map with two associations (when supplied with the corresponding associated values). + -- If the keys are the same then this function returns 'Nothing'. + pair :: k -> k -> Maybe (a -> a -> map a) + pair k1 k2 = if k1 == k2 then Nothing else Just (\a1 a2 -> fromAssocs [(k1,a1),(k2,a2)]) + + -- | Create a map from an unordered list of associations + -- Combine repeated keys with the provided function. + fromAssocsWith :: (a -> a -> a) -> [(k,a)] -> map a + fromAssocsWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as + + --- | Create a map from an unordered list of associations + -- Combine repeated keys with the provided function. If the result is Nothing the key is discarded. + fromAssocsMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a + fromAssocsMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as + + -- | See the 'Status' type. + -- This function provides a way to find out if a map is empty, a singleton, + -- or contains more than one association. + -- It is useful if empty or singleton maps require special treatment. + status :: map a -> Status k a + + -- | Reject empty maps (return Nothing). + -- Typically used for dealing with nested maps. + -- eg to delete a key from a nested map: + -- 'adjustMaybe (nonEmpty $ delete k2) k1' + nonEmpty :: map a -> Maybe (map a) + nonEmpty mp = case (status mp) of + None -> Nothing + _ -> Just mp + + -- | Add number of key\/value pairs in the map to the supplied Int + addSize :: map a -> Int# -> Int# + + -- | Return the value associated with the supplied key (if any). + lookup :: k -> map a -> Maybe a + + -- | Find the value associated with the supplied key (if any) and return the result + -- of applying the supplied continuation function to that value. Useful for nested lookup. + lookupCont :: (a -> Maybe b) -> k -> map a -> Maybe b + lookupCont f k mp = f =<< lookup k mp + + -- | This is a combined insert\/modify\/delete operation. The argument to the supplied function + -- is ('Just' a) if there is a value (a) associated with the supplied key, otherwise 'Nothing'. + -- If the return value is ('Just' a'), a' becomes the new value associated with the supplied key. + -- If the return value is 'Nothing', the association for the supplied key (if any) is deleted. + alter :: (Maybe a -> Maybe a) -> k -> map a -> map a + + -- | Insert a new association in the map if there is currently no value associated with the key. + -- If there is a value associated with the key then replace it with the result of + -- applying the supplied function to that value. + insertWith :: (a -> a) -> k -> a -> map a -> map a + insertWith f k a = alter (Just . maybe a f) k + + -- | Same as 'insertWith', but applies the supplied function strictly if the search succeeds. + -- Note that the third argument is not strictly evaluated either way (TODO change this) + insertWith' :: (a -> a) -> k -> a -> map a -> map a + insertWith' f k a = alter' (Just . maybe a f) k + + -- | Similar to 'insert', but the association is deleted if the supplied function returns 'Nothing'. + -- (The supplied function is always applied strictly.) + insertMaybe :: (a -> Maybe a) -> k -> a -> map a -> map a + insertMaybe f k a = alter ins k + where ins Nothing = Just a + ins (Just a') = f a' + + -- | Delete the association for the supplied key (if any). + delete :: k -> map a -> map a + delete = alter (const Nothing) + + -- | Find the value associated with the supplied key (if any) and apply the supplied function + -- to that value. + adjustWith :: (a -> a) -> k -> map a -> map a + adjustWith f = alter (liftM f) + + -- | Same as 'adjust' but applies the supplied function strictly. + adjustWith' :: (a -> a) -> k -> map a -> map a + adjustWith' f = alter' (fmap f) + + -- | Find the value associated with the supplied key (if any) and apply the supplied function + -- to that value. Delete the association if the result is 'Nothing'. Replace the old value with + -- the new value if the result is ('Just' something). + adjustMaybe :: (a -> Maybe a) -> k -> map a -> map a + adjustMaybe f = alter (f =<<) + + -- | Returns the left difference, intersection and right difference of the supplied maps + venn :: (a -> b -> c) -> map a -> map b -> (map a, map c, map b) + venn f = vennMaybe (Just `on` f) + + -- | Same as 'venn', but the new values in the intersection are evaluated strictly + venn' :: (a -> b -> c) -> map a -> map b -> (map a, map c, map b) + venn' f = vennMaybe ((forceMaybe . Just) `on` f) + + -- | Same as 'venn', except that values for which the argument function returns nothing + -- are dropped from the intersection + vennMaybe :: (a -> b -> Maybe c) -> map a -> map b -> (map a, map c, map b) + + -- | Evaluate the union of two maps. If the maps contain common keys then combine the + -- values associated with those keys using the supplied function. The value arguments + -- to this function are supplied in the same order as the map arguments. + union :: (a -> a -> a) -> map a -> map a -> map a + union f = unionMaybe (Just `on` f) + + -- | Same as 'unionWith', but the new associated values are evaluated strictly. + union' :: (a -> a -> a) -> map a -> map a -> map a + union' f = unionMaybe ((forceMaybe . Just) `on` f) + + -- | Evaluate the union of two maps, but delete combined associations from the result map + -- if the combining function returns 'Nothing'. + unionMaybe :: (a -> a -> Maybe a) -> map a -> map a -> map a + unionMaybe f mpa mpb = disjointUnion leftDiff (disjointUnion inter rightDiff) + where (leftDiff,inter,rightDiff) = vennMaybe f mpa mpb + + -- | Evaluate the union of two key-disjoint maps. If the arguments are not disjoint the + -- behaviour is undefined. This is potentially faster than 'union'. + disjointUnion :: map a -> map a -> map a + disjointUnion = union' (\ _ _ -> error ("Data.GMap.disjointUnion: Duplicate key found in map.")) + + -- | Evaluate the intersection of two maps, combining common associations using the supplied function. + intersection :: (a -> b -> c) -> map a -> map b -> map c + intersection f = intersectionMaybe (Just `on` f) + + -- | Same as 'intersection', but the new associated values are evaluated strictly. + intersection' :: (a -> b -> c) -> map a -> map b -> map c + intersection' f = intersectionMaybe ((forceMaybe . Just) `on` f) + + -- | Evaluate the intersection of two maps, but delete combined associations from the result map + -- if the combining function returns 'Nothing'. + intersectionMaybe :: (a -> b -> Maybe c) -> map a -> map b -> map c + intersectionMaybe f mpa mpb = inter + where (_,inter,_) = vennMaybe f mpa mpb + + -- | Evaluate the difference between two maps. For any key occuring in the second map, + -- the corresponding association (if any) is deleted from the first map. + -- The associated values in the second map are irrelevant. + difference :: map a -> map b -> map a + difference = differenceMaybe (\ _ _ -> Nothing) + + -- | Difference with a combining function. If the combining function returns + -- @Just a@ then the corresponding association is not deleted from the result map + -- (it is retained with @a@ as the associated value). + differenceMaybe :: (a -> b -> Maybe a) -> map a -> map b -> map a + differenceMaybe f mpa mpb = disjointUnion leftDiff inter + where (leftDiff,inter,_) = vennMaybe f mpa mpb + + -- | Returns true if the keys in the first map are a subset of the keys in the second map. + -- (This includes the case where the key sets are identical). Note that this function does + -- not examine the associated values (which are irrelevant). See 'isSubmapOf' if you + -- do want associated values examined. + isSubsetOf :: map a -> map b -> Bool + + -- | Returns true if the keys in the first map are a subset of the keys in the second map + -- and the corresponding function always returns true when applied to the values associated + -- with matching keys. + isSubmapOf :: (a -> b -> Bool) -> map a -> map b -> Bool + + -- | Apply the supplied function to every associated value in the map. + map :: (a -> b) -> map a -> map b + map f = mapMaybe (Just . f) + + -- | Same as 'Data.GMap.map', but the function is applied strictly. + map' :: (a -> b) -> map a -> map b + map' f = mapMaybe' (Just . f) + + -- | Apply the supplied function to every associated value in the map. + -- If the result is 'Nothing' then the delete the corresponding association. + mapMaybe :: (a -> Maybe b) -> map a -> map b + + -- | Apply the supplied function to every association in the map, and use the result + -- as the new associated value for the corresponding key. + mapWithKey :: (k -> a -> b) -> map a -> map b + + -- | Same as 'mapWithKey', but the function is applied strictly. + mapWithKey' :: (k -> a -> b) -> map a -> map b + + -- | Delete associations for which the supplied predicate returns 'False' when applied to + -- the associated value. + filter :: (a -> Bool) -> map a -> map a + + -- | Fold right over the list of elements in an unspecified order. + foldElems :: (a -> b -> b) -> b -> map a -> b + foldElems f = foldAssocs (const f) + + -- | Fold right over the list of keys in an unspecified order. + foldKeys :: (k -> b -> b) -> b -> map a -> b + foldKeys f = foldAssocs (\ k _ -> f k) + + -- | Fold right over the list of associations in an unspecified order. + foldAssocs :: (k -> a -> b -> b) -> b -> map a -> b + + -- | A strict version of 'foldElems' which should be used for + -- accumulating functions which are strict in their second argument. + foldElems' :: (a -> b -> b) -> b -> map a -> b + foldElems' f = foldAssocs' (const f) + + -- | A strict version of 'foldKeys' which should be used for + -- accumulating functions which are strict in their second argument. + foldKeys' :: (k -> b -> b) -> b -> map a -> b + foldKeys' f = foldAssocs' (\ k _ -> f k) + + -- | A strict version of 'foldAssocs' which should be used for + -- accumulating functions which are strict in their third argument. + foldAssocs' :: (k -> a -> b -> b) -> b -> map a -> b + + -- | Fold over elements in un-specified order using /unboxed/ Int accumulator (with GHC). + -- Defaults to boxed Int for other Haskells. Typically used for counting functions. + -- Implementations are free to traverse the map in any order. + -- The folded function is always applied strictly. + foldElemsUInt :: (a -> Int# -> Int#)-> Int# -> map a -> Int# + + -- | Test whatever underlying data structure is used to implement an + -- instance of this class is valid. Used for debugging. + -- 'Nothing' indicates the data structure is valid. + valid :: map a -> Maybe String + +-- | Raised by disjointUnion if the arguments are not disjoint. Note that instances of Map are *not* required +-- to test that arguments are disjoint. +disjointUnionError = error "Data.GMap.disjointUnion: Arguments not disjoint" + +-- | This is the return type for the 'status' method of the 'Map' class +data Status k a = None | One k a | Many deriving Eq + +-- | Same as 'vennMaybe' except that the new associated values are strictly evaluated. +vennMaybe' :: Map map k => (a -> b -> Maybe c) -> map a -> map b -> (map a, map c, map b) +vennMaybe' f = vennMaybe (forceMaybe `on` f) + +-- | Like 'alter' except that the new associated value is strictly evaluated +alter' :: Map map k => (Maybe a -> Maybe a) -> k -> map a -> map a +alter' f = alter (forceMaybe . f) + +-- | Like 'adjustMaybe' except that the new associated value is strictly evaluated +adjustMaybe' :: Map map k => (a -> Maybe a) -> k -> map a -> map a +adjustMaybe' f = adjustMaybe (forceMaybe . f) + +-- | Like 'insertMaybe' except that if the key is already present the new associated +-- value is evaluated strictly. If the key is not present then the supplied value is +-- *not* evaluated strictly. (TODO Change this) +insertMaybe' :: Map map k => (a -> Maybe a) -> k -> a -> map a -> map a +insertMaybe' f = insertMaybe (forceMaybe . f) + +-- | Like 'unionMaybe' except that the new associated values are strictly evaluated +unionMaybe' :: Map map k => (a -> a -> Maybe a) -> map a -> map a -> map a +unionMaybe' f = unionMaybe (forceMaybe `on` f) + +-- | Like 'intersectionMaybe' except that the new associated values are strictly evaluated +intersectionMaybe' :: Map map k => (a -> b -> Maybe c) -> map a -> map b -> map c +intersectionMaybe' f = intersectionMaybe (forceMaybe `on` f) + +-- | Like 'differenceMaybe' except that the new associated values are strictly evaluated +differenceMaybe' :: Map map k => (a -> b -> Maybe a) -> map a -> map b -> map a +differenceMaybe' f = differenceMaybe (forceMaybe `on` f) + +-- | Like 'mapMaybe' except that the new associated values are strictly evaluated +mapMaybe' :: Map map k => (a -> Maybe b) -> map a -> map b +mapMaybe' f = mapMaybe (forceMaybe . f) + +isEmpty :: Map map l => map a -> Bool +isEmpty mp = case (status mp) of + None -> True + _ -> False + +isSingleton :: Map map l => map a -> Bool +isSingleton mp = case (status mp) of + One _ _ -> True + _ -> False + +-- | Write a new association in the map, overwriting any value currently associated with the key. +insert :: Map map k => k -> a -> map a -> map a +insert k a mp = insertWith (const a) k a mp + +-- | Write a new association in the map, overwriting any value currently associated with the key. +-- The new value is evaluated strictly. +insert' :: Map map k => k -> a -> map a -> map a +insert' k a mp = insertWith' (const a) k a mp + +-- | Count the number of associations in a map. +size :: Map map k => map a -> Int +size mp = I# (addSize mp 0#) +{-# INLINE size #-} + +-- | Insert an unordered list of key\/value pairs into a map. +-- Repeated keys will be overwritten by the last occurence of the key. +insertAssocs :: Map map k => [(k,a)] -> map a -> map a +insertAssocs = insertAssocsWith (flip const) + +insertAssocsWith :: Map map k => (a -> a -> a) -> [(k,a)] -> map a -> map a +insertAssocsWith f as mp = union f mp (fromAssocsWith f as) + +insertAssocsMaybe :: Map map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a +insertAssocsMaybe f as mp = unionMaybe f mp (fromAssocsMaybe f as) + +fromAssocs :: Map map k => [(k,a)] -> map a +fromAssocs = fromAssocsWith (flip const) + +-- | Monadic lookup. +lookupM :: (Map map k, Monad m) => k -> map a -> m a +lookupM k mp = case lookup k mp of + Just a -> return a + Nothing -> fail "Data.Trie.General.lookupM: Key not found." +{-# SPECIALIZE lookupM :: Map map k => k -> map a -> Maybe a #-} + +keys :: Map map k => map a -> [k] +keys = foldKeys (:) [] + +elems :: Map map k => map a -> [a] +elems = foldElems (:) [] + +assocs :: Map map k => map a -> [(k,a)] +assocs = foldAssocs (\ k a xs -> (k,a):xs) [] + +-- | Maps which maintain some order on their keys, determined by compareKey. +class Map map k => OrderedMap map k where + + -- | Every function in this class must respect the ordering given by compareKey. + -- The first argument is required for its type only and should not be evaluated. + compareKey :: map a -> k -> k -> Ordering + + -- | Create a map from an ascending list of key\/value pairs + -- Combine repeated keys with the provided function. + fromAssocsAscWith :: (a -> a -> a) -> [(k,a)] -> map a + fromAssocsAscWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as + + --- | Create a map from an ascending list of key\/value pairs + -- Combine repeated keys with the provided function. If the result is Nothing the key is discarded. + fromAssocsAscMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a + fromAssocsAscMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as + + -- | Create a map from a descending list of key\/value pairs + -- Combine repeated keys with the provided function. + fromAssocsDescWith :: (a -> a -> a) -> [(k,a)] -> map a + fromAssocsDescWith f as = L.foldl' (\mp (k,a) -> insertWith (flip f a) k a mp) empty as + + --- | Create a map from a descending list of key\/value pairs + -- Combine repeated keys with the provided function. If the result is Nothing the key is discarded. + fromAssocsDescMaybe :: (a -> a -> Maybe a) -> [(k,a)] -> map a + fromAssocsDescMaybe f as = L.foldl' (\mp (k,a) -> insertMaybe (flip f a) k a mp) empty as + + -- | Right associative fold over the list of elements in ascending order of keys. + -- See 'foldElemsAsc'' for a strict version of this function. + foldElemsAsc :: (a -> b -> b) -> b -> map a -> b + foldElemsAsc f = foldAssocsAsc (const f) + + -- | Right associative fold over the list of elements in descending order of keys. + -- See 'foldElemsDesc'' for a strict version of this function. + foldElemsDesc :: (a -> b -> b) -> b -> map a -> b + foldElemsDesc f = foldAssocsDesc (const f) + + -- | Right associative fold over the list of keys in ascending order. + -- See 'foldKeysAsc'' for a strict version of this function. + foldKeysAsc :: (k -> b -> b) -> b -> map a -> b + foldKeysAsc f = foldAssocsAsc (\ k _ -> f k) + + -- | Right associative fold over the list of keys in descending order. + -- See 'foldKeysDesc'' for a strict version of this function. + foldKeysDesc :: (k -> b -> b) -> b -> map a -> b + foldKeysDesc f = foldAssocsDesc (\ k _ -> f k) + + -- | Right associative fold over the list of associations in ascending order of keys. + -- See 'foldAssocsAsc'' for a strict version of this function. + foldAssocsAsc :: (k -> a -> b -> b) -> b -> map a -> b + + -- | Right associative fold over the list of associations in descending order of keys. + -- See 'foldAssocsDesc'' for a strict version of this function. + foldAssocsDesc :: (k -> a -> b -> b) -> b -> map a -> b + + -- | A strict version of 'foldElemsAsc' which should be used for + -- accumulating functions which are strict in their second argument. + foldElemsAsc' :: (a -> b -> b) -> b -> map a -> b + foldElemsAsc' f z as = foldElemsDesc f' id as z -- Note reversed order + where f' a c z' = c $! f a z' + + -- | A strict version of 'foldElemsDesc' which should be used for + -- accumulating functions which are strict in their second argument. + foldElemsDesc' :: (a -> b -> b) -> b -> map a -> b + foldElemsDesc' f z as = foldElemsAsc f' id as z -- Note reversed order + where f' a c z' = c $! f a z' + + -- | A strict version of 'foldKeysAsc' which should be used for + -- accumulating functions which are strict in their second argument. + foldKeysAsc' :: (k -> b -> b) -> b -> map a -> b + foldKeysAsc' f z ks = foldKeysDesc f' id ks z -- Note reversed order + where f' k c z' = c $! f k z' + + -- | A strict version of 'foldKeysDesc' which should be used for + -- accumulating functions which are strict in their second argument. + foldKeysDesc' :: (k -> b -> b) -> b -> map a -> b + foldKeysDesc' f z ks = foldKeysAsc f' id ks z -- Note reversed order + where f' k c z' = c $! f k z' + + -- | A strict version of 'foldAssocsAsc' which should be used for + -- accumulating functions which are strict in their third argument. + foldAssocsAsc' :: (k -> a -> b -> b) -> b -> map a -> b + foldAssocsAsc' f z xs = foldAssocsDesc f' id xs z -- Note reversed order + where f' k a c z' = c $! f k a z' + + -- | A strict version of 'foldAssocsDesc' which should be used for + -- accumulating functions which are strict in their third argument. + foldAssocsDesc' :: (k -> a -> b -> b) -> b -> map a -> b + foldAssocsDesc' f z xs = foldAssocsAsc f' id xs z -- Note reversed order + where f' k a c z' = c $! f k a z' + +------------------------------------------------------------------------ + +fromAssocsAsc :: OrderedMap map k => [(k,a)] -> map a +fromAssocsAsc = fromAssocsAscWith (flip const) + +fromAssocsDesc :: OrderedMap map k => [(k,a)] -> map a +fromAssocsDesc = fromAssocsDescWith (flip const) + +-- | Insert an ascending list of associations into a map +-- Duplicate keys are replaced by the rightmost value +insertAssocsAsc :: OrderedMap map k => [(k,a)] -> map a -> map a +insertAssocsAsc as = insertAssocsAscWith (flip const) as + +-- | Insert a descending list of associations into a map +-- Duplicate keys are replaced by the rightmost value +insertAssocsDesc :: OrderedMap map k => [(k,a)] -> map a -> map a +insertAssocsDesc as = insertAssocsDescWith (flip const) as + +-- | Insert an ascending list of associations into a map +-- Duplicate keys are combined with the supplied function +insertAssocsAscWith :: OrderedMap map k => (a -> a -> a) -> [(k,a)] -> map a -> map a +insertAssocsAscWith f as mp = union f mp (fromAssocsAscWith f as) + +-- | Insert a descending list of associations into a map +-- Duplicate keys are combined with the supplied function +insertAssocsDescWith :: OrderedMap map k => (a -> a -> a) -> [(k,a)] -> map a -> map a +insertAssocsDescWith f as mp = union f mp (fromAssocsDescWith f as) + +-- | Same as 'insertAssocsAscWith' except that if Nothing is returned then the key is discarded +insertAssocsAscMaybe :: OrderedMap map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a +insertAssocsAscMaybe f as mp = unionMaybe f mp (fromAssocsAscMaybe f as) + +-- | Same as 'insertAssocsDescWith' except that if Nothing is returned then the key is discarded +insertAssocsDescMaybe :: OrderedMap map k => (a -> a -> Maybe a) -> [(k,a)] -> map a -> map a +insertAssocsDescMaybe f as mp = unionMaybe f mp (fromAssocsDescMaybe f as) + +-- | List the elements in the map in ascending order of keys. +elemsAsc :: OrderedMap map k => map a -> [a] +elemsAsc = foldElemsAsc (:) [] +{-# INLINE elemsAsc #-} + +-- | List the elements in the map in descending order of keys. +elemsDesc :: OrderedMap map k => map a -> [a] +elemsDesc = foldElemsDesc (:) [] +{-# INLINE elemsDesc #-} + +-- | List all associations in the map in ascending order of keys. +assocsAsc :: OrderedMap map k => map a -> [(k,a)] +assocsAsc = foldAssocsAsc (\k a kas -> (k,a):kas) [] +{-# INLINE assocsAsc #-} + +-- | List all associations in the map in descending order of keys. +assocsDesc :: OrderedMap map k => map a -> [(k,a)] +assocsDesc = foldAssocsDesc (\k a kas -> (k,a):kas) [] +{-# INLINE assocsDesc #-} + +-- | List all keys in the map in ascending order. +keysAsc :: OrderedMap map k => map a -> [k] +keysAsc = foldKeysAsc (:) [] +{-# INLINE keysAsc #-} + +-- | List all keys in the map in descending order. +keysDesc :: OrderedMap map k => map a -> [k] +keysDesc = foldKeysDesc (:) [] +{-# INLINE keysDesc #-} + +-- | Similar to 'isSubsetOf', but also requires that the size of the second map is +-- greater than the first (so does not include the case where the key sets are identical). +isProperSubsetOf :: Map map k => map a -> map b -> Bool +isProperSubsetOf mpa mpb = (size mpa < size mpb) && (isSubsetOf mpa mpb) +{-# INLINE isProperSubsetOf #-} + +-- | Similar to 'isSubmapOf', but also requires that the size of the second map is +-- greater than the first (so does not include the case where the key sets are identical). +isProperSubmapOfBy :: Map map k => (a -> b -> Bool) -> map a -> map b -> Bool +isProperSubmapOfBy f mpa mpb = (size mpa < size mpb) && (isSubmapOf f mpa mpb) +{-# INLINE isProperSubmapOfBy #-} + +-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The +-- result is a map of new keys to a corresponding /non-empty/ map of old keys (type k0) to values. +-- Unimplemented !!! +partition :: (Map map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 (map0 a) +partition p map0 = undefined +{-# INLINE partition #-} + +-- | Similar to 'partition', but associations with values yielding 'Nothing' are discarded. +-- Unimplemented !!! +partitionMaybe :: (Map map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 (map0 a) +partitionMaybe p map0 = undefined +{-# INLINE partitionMaybe #-} + +-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The +-- result is a map of new keys to a corresponding /non-empty/ list of old key\/value association pairs. +-- Each list is in ascending order of old keys (type k0). +-- Unimplemented !!! +partitionAscList :: (OrderedMap map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 [(k0,a)] +partitionAscList p map0 = foldAssocsDesc' ins empty map0 -- We use Desc!! (strict) + where ins k0 a map1 = insertWith' ((k0,a):) (p a) [(k0,a)] map1 -- Note use of insert' + +-- | Applies the supplied function to every value in a map to create a new key (type @k1@). The +-- result is a map of new keys to a corresponding /non-empty/ list of old key\/value association pairs. +-- Each list is in descending order of old keys (type k0). +-- Unimplemented !!! +partitionDescList :: (OrderedMap map0 k0, Map map1 k1) => (a -> k1) -> map0 a -> map1 [(k0,a)] +partitionDescList p map0 = foldAssocsAsc' ins empty map0 -- We use Asc!! (strict) + where ins k0 a map1 = insertWith' ((k0,a):) (p a) [(k0,a)] map1 -- Note use of insert' + +-- | Similar to 'partitionAscList', but associations with values yielding 'Nothing' are discarded. +-- Unimplemented !!! +partitionAscListMaybe :: (OrderedMap map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 [(k0,a)] +partitionAscListMaybe p map0 = foldAssocsDesc' ins empty map0 -- We use Desc!! (strict) + where ins k0 a map1 = case p a of + Nothing -> map1 + Just k1 -> insertWith' ((k0,a):) k1 [(k0,a)] map1 -- Note use of insert' + +-- | Similar to 'partitionDescList', but associations with values yielding 'Nothing' are discarded. +-- Unimplemented !!! +partitionDescListMaybe :: (OrderedMap map0 k0, Map map1 k1) => (a -> Maybe k1) -> map0 a -> map1 [(k0,a)] +partitionDescListMaybe p map0 = foldAssocsAsc' ins empty map0 -- We use Asc!! (strict) + where ins k0 a map1 = case p a of + Nothing -> map1 + Just k1 -> insertWith' ((k0,a):) k1 [(k0,a)] map1 -- Note use of insert' + +like :: a -> a -> a +like a _ = a + +-- | Use a map of the supplied type to sort a list of keys into ascending order +-- Slower than nubAscWith, but retains duplicate keys +sortAscWith :: OrderedMap map k => map Int -> [k] -> [k] +sortAscWith mp ks = concat [replicate n k | (k,n) <- as] + where as = assocsAsc $ fromAssocsWith (+) (zip ks $ repeat 1) `like` mp + +-- | Use a map of the supplied type to sort a list of keys into descending order +-- Slower than nubDescWith, but retains duplicate keys +sortDescWith :: OrderedMap map k => map Int -> [k] -> [k] +sortDescWith mp ks = concat [replicate n k | (k,n) <- as] + where as = assocsDesc $ fromAssocsWith (+) (zip ks $ repeat 1) `like` mp + +-- | Use a map of the supplied type to sort a list of keys into ascending order (eliminating duplicates). +nubAscWith :: OrderedMap map k => map () -> [k] -> [k] +nubAscWith mp ks = keysAsc $ fromAssocs (zip ks $ repeat ()) `like` mp + +-- | Use a map of the supplied type to sort a list of keys into descending order (eliminating duplicates). +nubDescWith :: OrderedMap map k => map () -> [k] -> [k] +nubDescWith mp ks = keysDesc $ fromAssocs (zip ks $ repeat ()) `like` mp + +----------------------------------------------------------------------------------------------------------------------------------- + +-- | Instances of OrdMap must satisfy 'compareKey == Ord.compare' +-- class (OrderedMap map k, Ord k) => OrdMap map k + diff --git a/src/Data/GMap/AssocList.hs b/src/Data/GMap/AssocList.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/AssocList.hs @@ -0,0 +1,209 @@ +{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.AssocList where + +import Data.GMap +import qualified Data.List as L +import Data.Maybe(catMaybes,isNothing) +import Data.Ord +import GHC.Base + +-- Unsorted assoc list with no duplicate keys +newtype AList k a = AL [(k,a)] + +keyEq a b = (fst a) == (fst b) +keysOf = L.map fst +elemsAL = L.map snd +withKey k a = (k,a) + +deleteByKey k = L.deleteBy keyEq (k,undefined) + +-- Strictly evaluluate structure and keys but not elements. +force [] = [] +force l@((k,_):rest) = k `seq` force rest `seq` l + +seqMaybe Nothing b = b +seqMaybe (Just a) b = a `seq` b + +al = AL . force + +unboxInt (I# i) = i + +instance Eq k => Map (AList k) k where + + empty = al [] + + singleton k a = al [(k,a)] + + pair k1 k2 = + if k1 == k2 + then Nothing + else Just $ \ a1 a2 -> al [(k1,a1),(k2,a2)] + + status (AL []) = None + status (AL [(k,a)]) = One k a + status _ = Many + + addSize (AL as) = (+#) (unboxInt (L.length as)) + + lookup k (AL as) = L.lookup k as + + alter f k (AL as) = + let ma = L.lookup k as + in case (ma, f ma) of + (Nothing, Nothing) -> al as + (Nothing, Just a) -> al $ (k,a):as + (Just _, Nothing) -> al $ deleteByKey k as + (Just _, Just a) -> al $ ((k,a):) $ deleteByKey k as + + vennMaybe f (AL as) (AL bs) = + let leftDiff = [ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ] + rightDiff = [ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ] + inter = + let ks = L.intersect (keysOf as) (keysOf bs) + assoc k = do + a <- L.lookup k as + b <- L.lookup k bs + value <- f a b + return (k,value) + in catMaybes (L.map assoc ks) + in (al leftDiff,al inter,al rightDiff) + + disjointUnion (AL as) (AL bs) = al (as ++ bs) + + isSubsetOf (AL as) (AL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as) + + isSubmapOf f (AL as) (AL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as + + map f (AL as) = al $ L.map (\(k,a) -> (k,f a)) as + map' f (AL as) = al $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as + + mapMaybe f (AL as) = al $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as + + mapWithKey f (AL as) = al $ L.map (\ (k,a) -> (k,f k a)) as + mapWithKey' f (AL as) = al $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as + + filter f (AL as) = al $ L.filter (f . snd) as + + foldElems f b (AL as) = L.foldr f b $ elemsAL as + foldKeys f b (AL as) = L.foldr f b $ keysOf as + foldAssocs f b (AL as) = L.foldr (\(k,a) acc -> f k a acc) b as + + foldElems' f b (AL as) = L.foldl' (flip f) b $ elemsAL as + foldKeys' f b (AL as) = L.foldl' (flip f) b $ keysOf as + foldAssocs' f b (AL as) = L.foldl' (\acc (k,a) -> f k a acc) b as + + foldElemsUInt f i (AL as) = fold i as + where fold i' [] = i' + fold i' ((_,a):as') = fold (f a i') as' + + valid (AL as) = + if keysOf as == (L.nub $ keysOf as) + then Nothing + else Just "Duplicate keys" + +-- Sorted assoc list with no duplicate keys +-- The map argument is used to determine the ordering used +newtype SList (map :: * -> *) k a = SL [(k,a)] + +sl :: OrderedMap mp k => [(k,a)] -> SList mp k a +sl kas = + let mp :: SList mp k a -> (mp a) + mp = undefined + result = SL $ force $ L.sortBy (\ (k1,_) (k2,_) -> compareKey (mp result) k1 k2) kas + in result + +instance (Eq k, Ord k, OrderedMap mp k) => Map (SList mp k) k where + empty = SL [] + + singleton k a = SL [(k,a)] + + pair k1 k2 = + if k1 == k2 + then Nothing + else Just $ \ a1 a2 -> sl [(k1,a1),(k2,a2)] + + status (SL []) = None + status (SL [(k,a)]) = One k a + status _ = Many + + addSize (SL as) = (+#) (unboxInt (L.length as)) + + lookup k (SL as) = L.lookup k as + + alter f k (SL as) = + let ma = L.lookup k as + in case (ma, f ma) of + (Nothing, Nothing) -> SL as + (Nothing, Just a) -> sl $ (k,a):as + (Just _, Nothing) -> SL $ deleteByKey k as + (Just _, Just a) -> sl $ ((k,a):) $ deleteByKey k as + + vennMaybe f (SL as) (SL bs) = + let leftDiff = [ (k,a) | (k,a) <- as , isNothing (L.lookup k bs) ] + rightDiff = [ (k,b) | (k,b) <- bs , isNothing (L.lookup k as) ] + inter = + let ks = L.intersect (keysOf as) (keysOf bs) + assoc k = do + a <- L.lookup k as + b <- L.lookup k bs + value <- f a b + return (k,value) + in catMaybes (L.map assoc ks) + in (sl leftDiff,sl inter,sl rightDiff) + + disjointUnion (SL as) (SL bs) = sl (as ++ bs) + + isSubsetOf (SL as) (SL bs) = L.all (flip L.elem (keysOf bs)) (keysOf as) + + isSubmapOf f (SL as) (SL bs) = L.all (\ (k,a) -> (Just True) == (fmap (f a) $ L.lookup k bs)) as + + map f (SL as) = sl $ L.map (\(k,a) -> (k,f a)) as + map' f (SL as) = sl $ L.map (\(k,a) -> let a' = f a in a' `seq` (k,a')) as + + mapMaybe f (SL as) = sl $ catMaybes $ L.map (\(k,a) -> fmap (withKey k) $ f a ) as + + mapWithKey f (SL as) = sl $ L.map (\ (k,a) -> (k,f k a)) as + mapWithKey' f (SL as) = sl $ L.map (\(k,a) -> let a' = f k a in a' `seq` (k,a')) as + + filter f (SL as) = SL $ L.filter (f . snd) as + + foldElems f b (SL as) = L.foldr f b $ elemsAL as + foldKeys f b (SL as) = L.foldr f b $ keysOf as + foldAssocs f b (SL as) = L.foldr (\(k,a) acc -> f k a acc) b as + + foldElems' f b (SL as) = L.foldl' (flip f) b $ reverse $ elemsAL as + foldKeys' f b (SL as) = L.foldl' (flip f) b $ reverse $ keysOf as + foldAssocs' f b (SL as) = L.foldl' (\acc (k,a) -> f k a acc) b $ reverse as + + foldElemsUInt f i (SL as) = fold i as + where fold i' [] = i' + fold i' ((_,a):as') = fold (f a i') as' + + valid (SL as) + | keysOf as /= (L.nub $ keysOf as) = Just "Duplicate keys" + | keysOf as /= (L.sort $ keysOf as) = Just "Unsorted" + | otherwise = Nothing + +instance (Eq k, Ord k, OrderedMap mp k) => OrderedMap (SList mp k) k where + + compareKey sl = compareKey (mp sl) + where mp :: SList mp k a -> (mp a) + mp = undefined + + foldAssocsAsc f b (SL as) = L.foldr (uncurry f) b as + foldAssocsDesc f b (SL as) = L.foldr (uncurry f) b $ reverse as + + foldAssocsAsc' f b (SL as) = L.foldl' (flip $ uncurry f) b $ reverse as + foldAssocsDesc' f b (SL as) = L.foldl' (flip $ uncurry f) b as + +-- A map type to tell SList to behave use standard Orderings +data ImaginaryOrdMap k a +instance Eq k => Map (ImaginaryOrdMap k) k +instance (Eq k, Ord k) => OrderedMap (ImaginaryOrdMap k) k where + compareKey _ = compare + +type OList k = SList (ImaginaryOrdMap k) k + + +-- instance (Eq k, Ord k) => OrdMap (SList k) k diff --git a/src/Data/GMap/CacheKeys.hs b/src/Data/GMap/CacheKeys.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/CacheKeys.hs @@ -0,0 +1,292 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -fno-warn-orphans -fno-warn-unused-imports -fallow-undecidable-instances -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.CacheKeys +(-- * CacheKeys type + CacheKeys +,cacheKeys +,uncacheKeys +) where + +import Prelude hiding (foldr,map,filter,lookup) +import Data.GMap + +import qualified Data.Monoid as M (Monoid(..)) +import qualified Data.Foldable as F (Foldable(..)) +import Data.Typeable +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L + +import GHC.Base hiding (map) +import qualified Text.Read as R + +-- | A map transformer that causes keys to be cached alongside elements +data CacheKeys mp k a = CacheKeys !(mp (k,a)) + +instance (Map mp k) => Map (CacheKeys mp k) k where + empty = emptyCacheKeys + singleton = singletonCacheKeys + pair = pairCacheKeys + nonEmpty = nonEmptyCacheKeys + status = statusCacheKeys + addSize = addSizeCacheKeys + lookup = lookupCacheKeys + lookupCont = lookupContCacheKeys + alter = alterCacheKeys + insertWith = insertWithCacheKeys + insertWith' = insertWithCacheKeys' + insertMaybe = insertMaybeCacheKeys + fromAssocsWith = fromAssocsWithCacheKeys + fromAssocsMaybe = fromAssocsMaybeCacheKeys + delete = deleteCacheKeys + adjustWith = adjustWithCacheKeys + adjustWith' = adjustWithCacheKeys' + adjustMaybe = adjustMaybeCacheKeys + venn = vennCacheKeys + venn' = vennCacheKeys' + vennMaybe = vennMaybeCacheKeys + union = unionCacheKeys + union' = unionCacheKeys' + unionMaybe = unionMaybeCacheKeys + disjointUnion = disjointUnionCacheKeys + intersection = intersectionCacheKeys + intersection' = intersectionCacheKeys' + intersectionMaybe = intersectionMaybeCacheKeys + difference = differenceCacheKeys + differenceMaybe = differenceMaybeCacheKeys + isSubsetOf = isSubsetOfCacheKeys + isSubmapOf = isSubmapOfCacheKeys + map = mapCacheKeys + map' = mapCacheKeys' + mapMaybe = mapMaybeCacheKeys + mapWithKey = mapWithKeyCacheKeys + mapWithKey' = mapWithKeyCacheKeys' + filter = filterCacheKeys + foldKeys = foldKeysCacheKeys + foldElems = foldElemsCacheKeys + foldAssocs = foldAssocsCacheKeys + foldKeys' = foldKeysCacheKeys' + foldElems' = foldElemsCacheKeys' + foldAssocs' = foldAssocsCacheKeys' + foldElemsUInt = foldElemsUIntCacheKeys + valid = validCacheKeys + +instance (OrderedMap mp k) => OrderedMap (CacheKeys mp k) k where + compareKey = compareKeyCacheKeys + fromAssocsAscWith = fromAssocsAscWithCacheKeys + fromAssocsDescWith = fromAssocsDescWithCacheKeys + fromAssocsAscMaybe = fromAssocsAscMaybeCacheKeys + fromAssocsDescMaybe = fromAssocsDescMaybeCacheKeys + foldElemsAsc = foldElemsAscCacheKeys + foldElemsDesc = foldElemsDescCacheKeys + foldKeysAsc = foldKeysAscCacheKeys + foldKeysDesc = foldKeysDescCacheKeys + foldAssocsAsc = foldAssocsAscCacheKeys + foldAssocsDesc = foldAssocsDescCacheKeys + foldElemsAsc' = foldElemsAscCacheKeys' + foldElemsDesc' = foldElemsDescCacheKeys' + foldKeysAsc' = foldKeysAscCacheKeys' + foldKeysDesc' = foldKeysDescCacheKeys' + foldAssocsAsc' = foldAssocsAscCacheKeys' + foldAssocsDesc' = foldAssocsDescCacheKeys' + +cacheKeys :: Map mp k => mp a -> CacheKeys mp k a +cacheKeys mp = CacheKeys (mapWithKey' (,) mp) + +uncacheKeys :: Map mp k => CacheKeys mp k a -> mp a +uncacheKeys (CacheKeys mp) = map' snd mp + +on :: (c -> d) -> (a -> b -> c) -> a -> b -> d +on f g a b = f $ g a b + +emptyCacheKeys = CacheKeys empty + +singletonCacheKeys k a = CacheKeys (singleton k (k,a)) + +pairCacheKeys k1 k2 = (cacheKeys `on`) `fmap` (pair k1 k2) + +nonEmptyCacheKeys (CacheKeys kmp) = CacheKeys `fmap` (nonEmpty kmp) + +statusCacheKeys (CacheKeys kmp) = + case (status kmp) of + None -> None + One k (_,a) -> One k a + Many -> Many + +addSizeCacheKeys (CacheKeys kmp) = addSize kmp + +lookupCacheKeys k (CacheKeys kmp) = snd `fmap` (lookup k kmp) + +lookupContCacheKeys f k (CacheKeys kmp) = lookupCont (f . snd) k kmp + +withKey f (k,a) = let a' = f a in a' `seq` (k,a') +withKeyMaybe f (k,a) = do + a' <- f a + return (a' `seq` (k,a')) +withMaybeKeyMaybe f k mka = (\a' -> (k,a')) `fmap` (f (snd `fmap` mka)) + +alterCacheKeys f k (CacheKeys kmp) = CacheKeys (alter (withMaybeKeyMaybe f k) k kmp) + +insertWithCacheKeys f k a (CacheKeys kmp) = CacheKeys (insertWith (withKey f) k (k,a) kmp) +insertWithCacheKeys' f k a (CacheKeys kmp) = CacheKeys (insertWith' (withKey f) k (a `seq` (k,a)) kmp) +insertMaybeCacheKeys f k a (CacheKeys kmp) = CacheKeys (insertMaybe (withKeyMaybe f) k (k,a) kmp) + +deleteCacheKeys k (CacheKeys kmp) = CacheKeys (delete k kmp) + +adjustWithCacheKeys f k (CacheKeys kmp) = CacheKeys (adjustWith (withKey f) k kmp) +adjustWithCacheKeys' f k (CacheKeys kmp) = CacheKeys (adjustWith' (withKey f) k kmp) +adjustMaybeCacheKeys f k (CacheKeys kmp) = CacheKeys (adjustMaybe (withKeyMaybe f) k kmp) + +withKey2 f (k,a1) (_,a2) = let a' = f a1 a2 in a' `seq` (k,f a1 a2) +withKeyMaybe2 f (k,a1) (_,a2) = (\ a -> a `seq` (k,a)) `fmap` (f a1 a2) + +vennCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff) + where (leftDiff,inter,rightDiff) = venn (withKey2 f) kmp1 kmp2 + +vennCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff) + where (leftDiff,inter,rightDiff) = venn' (withKey2 f) kmp1 kmp2 + +vennMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = (CacheKeys leftDiff, CacheKeys inter, CacheKeys rightDiff) + where (leftDiff,inter,rightDiff) = vennMaybe (withKeyMaybe2 f) kmp1 kmp2 + +unionCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union (withKey2 f) kmp1 kmp2) +unionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (union' (withKey2 f) kmp1 kmp2) +unionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (unionMaybe (withKeyMaybe2 f) kmp1 kmp2) +disjointUnionCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (disjointUnion kmp1 kmp2) + +intersectionCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection (withKey2 f) kmp1 kmp2) +intersectionCacheKeys' f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersection' (withKey2 f) kmp1 kmp2) +intersectionMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (intersectionMaybe (withKeyMaybe2 f) kmp1 kmp2) + +differenceCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (difference kmp1 kmp2) +differenceMaybeCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = CacheKeys (differenceMaybe (withKeyMaybe2 f) kmp1 kmp2) + +onAssoc f (_,a) = f a +onAssoc2 f (_,a) (_,b) = f a b + +isSubsetOfCacheKeys (CacheKeys kmp1) (CacheKeys kmp2) = isSubsetOf kmp1 kmp2 +isSubmapOfCacheKeys f (CacheKeys kmp1) (CacheKeys kmp2) = isSubmapOf (onAssoc2 f) kmp1 kmp2 + +mapCacheKeys f (CacheKeys kmp) = CacheKeys (map (withKey f) kmp) +mapCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (withKey f) kmp) +mapMaybeCacheKeys f (CacheKeys kmp) = CacheKeys (mapMaybe (withKeyMaybe f) kmp) +mapWithKeyCacheKeys f (CacheKeys kmp) = CacheKeys (map (\(k,a) -> (k,f k a)) kmp) +mapWithKeyCacheKeys' f (CacheKeys kmp) = CacheKeys (map' (\(k,a) -> let a' = f k a in a' `seq` (k,a')) kmp) + +filterCacheKeys f (CacheKeys kmp) = CacheKeys (filter (onAssoc f) kmp) + +foldElemsUIntCacheKeys f b (CacheKeys kmp) = foldElemsUInt (onAssoc f) b kmp + +validCacheKeys (CacheKeys kmp) = valid kmp + +compareKeyCacheKeys cachemp k1 k2 = compareKey (innermp cachemp) k1 k2 + where innermp :: CacheKeys mp k a -> mp a + innermp _ = undefined + +fromAssocsWithCacheKeys f kas = CacheKeys (fromAssocsWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas]) +fromAssocsMaybeCacheKeys f kas = CacheKeys (fromAssocsMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas]) +fromAssocsAscWithCacheKeys f kas = CacheKeys (fromAssocsAscWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas]) +fromAssocsDescWithCacheKeys f kas = CacheKeys (fromAssocsDescWith (withKey2 f) [(k,(k,a)) | (k,a) <- kas]) +fromAssocsAscMaybeCacheKeys f kas = CacheKeys (fromAssocsAscMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas]) +fromAssocsDescMaybeCacheKeys f kas = CacheKeys (fromAssocsDescMaybe (withKeyMaybe2 f) [(k,(k,a)) | (k,a) <- kas]) + +foldKeysCacheKeys f b (CacheKeys kmp) = foldKeys f b kmp +foldKeysCacheKeys' f b (CacheKeys kmp) = foldKeys' f b kmp +foldKeysAscCacheKeys f b (CacheKeys kmp) = foldKeysAsc f b kmp +foldKeysDescCacheKeys f b (CacheKeys kmp) = foldKeysDesc f b kmp +foldKeysAscCacheKeys' f b (CacheKeys kmp) = foldKeysAsc' f b kmp +foldKeysDescCacheKeys' f b (CacheKeys kmp) = foldKeysDesc' f b kmp + +foldElemsCacheKeys f b (CacheKeys kmp) = foldElems (onAssoc f) b kmp +foldElemsCacheKeys' f b (CacheKeys kmp) = foldElems' (onAssoc f) b kmp +foldElemsAscCacheKeys f b (CacheKeys kmp) = foldElemsAsc (onAssoc f) b kmp +foldElemsDescCacheKeys f b (CacheKeys kmp) = foldElemsDesc (onAssoc f) b kmp +foldElemsAscCacheKeys' f b (CacheKeys kmp) = foldElemsAsc' (onAssoc f) b kmp +foldElemsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (onAssoc f) b kmp + +foldAssocsCacheKeys f b (CacheKeys kmp) = foldElems (uncurry f) b kmp +foldAssocsCacheKeys' f b (CacheKeys kmp) = foldElems' (uncurry f) b kmp +foldAssocsAscCacheKeys f b (CacheKeys kmp) = foldElemsAsc (uncurry f) b kmp +foldAssocsDescCacheKeys f b (CacheKeys kmp) = foldElemsDesc (uncurry f) b kmp +foldAssocsAscCacheKeys' f b (CacheKeys kmp) = foldElemsAsc' (uncurry f) b kmp +foldAssocsDescCacheKeys' f b (CacheKeys kmp) = foldElemsDesc' (uncurry f) b kmp + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance (Eq (mp (k,a))) => Eq (CacheKeys mp k a) where + (CacheKeys kmp1) == (CacheKeys kmp2) = (kmp1 == kmp2) + +--------- +-- Ord -- +--------- +instance (Ord (mp (k,a))) => Ord (CacheKeys mp k a) where + compare (CacheKeys kmp1) (CacheKeys kmp2) = compare kmp1 kmp2 + +---------- +-- Show -- +---------- +instance (Show k, Show a, Map mp k) => Show (CacheKeys mp k a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocs " . shows (assocs mp) + +---------- +-- Read -- +---------- +instance (Read k, Read a, Map mp k) => R.Read (CacheKeys mp k a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP + xs <- R.readPrec + return (fromAssocs xs) + readListPrec = R.readListPrecDefault + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance (Typeable1 mp) => Typeable1 (CacheKeys mp k) where + typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.CacheKeys.CacheKeys") [typeOf1 innermp] + where CacheKeys innermp = m -- This is just to get the type for innermp!! +-------------- +instance (Typeable1 (CacheKeys mp k), Typeable a) => Typeable (CacheKeys mp k a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance (Map mp k) => Functor (CacheKeys mp k) where +-- fmap :: (a -> b) -> EitherMap mapL mapR a -> EitherMap mapL mapR b + fmap = mapCacheKeys -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Map mp k, M.Monoid a) => M.Monoid (CacheKeys mp k a) where +-- mempty :: EitherMap mapL mapR a + mempty = emptyCacheKeys +-- mappend :: EitherMap mapL mapR a -> EitherMap mapL mapR a -> EitherMap mapL mapR a + mappend map0 map1 = unionCacheKeys M.mappend map0 map1 +-- mconcat :: [EitherMap mapL mapR a] -> EitherMap mapL mapR a + mconcat maps = L.foldr (unionCacheKeys M.mappend) emptyCacheKeys maps + +------------------- +-- Data.Foldable -- +------------------- +instance (Map mp k) => F.Foldable (CacheKeys mp k) where +-- fold :: Monoid m => CacheKeys mapL mapR m -> m + fold mp = foldElemsCacheKeys M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> CacheKeys mapL mapR a -> m + foldMap f mp = foldElemsCacheKeys (\a b -> M.mappend (f a) b) M.mempty mp +-- fold :: (a -> b -> b) -> b -> CacheKeys mapL mapR a -> b + foldr f b0 mp = foldElemsCacheKeys f b0 mp +-- foldl :: (a -> b -> a) -> a -> CacheKeys mapL mapR b -> a + foldl f b0 mp = foldElemsCacheKeys (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- fold1 :: (a -> a -> a) -> CacheKeys mapL mapR a -> a + fold1 = undefined +-- foldl1 :: (a -> a -> a) -> CacheKeys mapL mapR a -> a + foldl1 = undefined +-} + diff --git a/src/Data/GMap/ChoiceMap.hs b/src/Data/GMap/ChoiceMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/ChoiceMap.hs @@ -0,0 +1,601 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -fallow-undecidable-instances -Wall #-} + +module Data.GMap.ChoiceMap +(Choice2(C1of2,C2of2) +,Choice2Map +,Choice3(C1of3,C2of3,C3of3) +,Choice3Map +,Choice4(C1of4,C2of4,C3of4,C4of4) +,Choice4Map +,Choice5(C1of5,C2of5,C3of5,C4of5,C5of5) +,Choice5Map +) where + +import Prelude hiding (foldr,map,filter,lookup) +import Data.GMap +import Data.GMap.InjectKeys + +import qualified Data.Monoid as M (Monoid(..)) +import qualified Data.Foldable as F (Foldable(..)) +import Data.Typeable +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L + +import GHC.Base hiding (map) +import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault) + +data Choice2 a b = C1of2 a | C2of2 b deriving (Eq,Ord,Read,Show) + +-- | The 'Map' type for keys of form @('Map' mapL kL, 'Map' mapR kR) => 'Choice2' kL kR@. +data Choice2Map mapL mapR kL kR a = Choice2Map !(mapL a) !(mapR a) + +-- Needs -fallow-undecidable-instances due to coverage condition +instance (Map mapL kL, Map mapR kR) => Map (Choice2Map mapL mapR kL kR) (Choice2 kL kR) where + empty = emptyChoice2Map + singleton = singletonChoice2Map + pair = pairChoice2Map + nonEmpty = nonEmptyChoice2Map + status = statusChoice2Map + addSize = addSizeChoice2Map + lookup = lookupChoice2Map + --lookupCont = lookupContChoice2Map + alter = alterChoice2Map + insertWith = insertWithChoice2Map + insertWith' = insertWithChoice2Map' + insertMaybe = insertMaybeChoice2Map + fromAssocsWith = fromAssocsWithChoice2Map + fromAssocsMaybe = fromAssocsMaybeChoice2Map + delete = deleteChoice2Map + adjustWith = adjustWithChoice2Map + adjustWith' = adjustWithChoice2Map' + adjustMaybe = adjustMaybeChoice2Map + venn = vennChoice2Map + venn' = vennChoice2Map' + vennMaybe = vennMaybeChoice2Map + disjointUnion = disjointUnionChoice2Map + union = unionChoice2Map + union' = unionChoice2Map' + unionMaybe = unionMaybeChoice2Map + intersection = intersectionChoice2Map + intersection' = intersectionChoice2Map' + intersectionMaybe = intersectionMaybeChoice2Map + difference = differenceChoice2Map + differenceMaybe = differenceMaybeChoice2Map + isSubsetOf = isSubsetOfChoice2Map + isSubmapOf = isSubmapOfChoice2Map + map = mapChoice2Map + map' = mapChoice2Map' + mapMaybe = mapMaybeChoice2Map + mapWithKey = mapWithKeyChoice2Map + mapWithKey' = mapWithKeyChoice2Map' + filter = filterChoice2Map + foldKeys = foldKeysChoice2Map + foldElems = foldElemsChoice2Map + foldAssocs = foldAssocsChoice2Map + foldKeys' = foldKeysChoice2Map' + foldElems' = foldElemsChoice2Map' + foldAssocs' = foldAssocsChoice2Map' + foldElemsUInt = foldElemsUIntChoice2Map + valid = validChoice2Map + +instance (OrderedMap mapL kL, OrderedMap mapR kR) => OrderedMap (Choice2Map mapL mapR kL kR) (Choice2 kL kR) where + compareKey = compareKeyChoice2Map + fromAssocsAscWith = fromAssocsAscWithChoice2Map + fromAssocsDescWith = fromAssocsDescWithChoice2Map + fromAssocsAscMaybe = fromAssocsAscMaybeChoice2Map + fromAssocsDescMaybe = fromAssocsDescMaybeChoice2Map + foldElemsAsc = foldElemsAscChoice2Map + foldElemsDesc = foldElemsDescChoice2Map + foldKeysAsc = foldKeysAscChoice2Map + foldKeysDesc = foldKeysDescChoice2Map + foldAssocsAsc = foldAssocsAscChoice2Map + foldAssocsDesc = foldAssocsDescChoice2Map + foldElemsAsc' = foldElemsAscChoice2Map' + foldElemsDesc' = foldElemsDescChoice2Map' + foldKeysAsc' = foldKeysAscChoice2Map' + foldKeysDesc' = foldKeysDescChoice2Map' + foldAssocsAsc' = foldAssocsAscChoice2Map' + foldAssocsDesc' = foldAssocsDescChoice2Map' + +-- | See 'Map' class method 'empty'. +emptyChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a +emptyChoice2Map = Choice2Map empty empty + +-- | See 'Map' class method 'singleton'. +singletonChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a +singletonChoice2Map (C1of2 kL) a = Choice2Map (singleton kL a) empty +singletonChoice2Map (C2of2 kR) a = Choice2Map empty (singleton kR a) + +-- | See 'Map' class method 'pair'. +pairChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2 kL kR -> Maybe (a -> a -> Choice2Map mapL mapR kL kR a) +pairChoice2Map (C1of2 k0) (C1of2 k1) = case pair k0 k1 of + Nothing -> Nothing + Just f -> Just (\a0 a1 -> Choice2Map (f a0 a1) empty) +pairChoice2Map (C1of2 kL) (C2of2 kR) = Just (\aL aR -> Choice2Map (singleton kL aL) (singleton kR aR)) +pairChoice2Map (C2of2 kR) (C1of2 kL) = Just (\aR aL -> Choice2Map (singleton kL aL) (singleton kR aR)) +pairChoice2Map (C2of2 k0) (C2of2 k1) = case pair k0 k1 of + Nothing -> Nothing + Just f -> Just (\a0 a1 -> Choice2Map empty (f a0 a1)) + +-- | See 'Map' class method 'nonEmpty'. +nonEmptyChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Maybe (Choice2Map mapL mapR kL kR a) +nonEmptyChoice2Map egt = if isEmpty egt then Nothing else Just egt + +-- | See 'Map' class method 'status'. +statusChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Status (Choice2 kL kR) a +statusChoice2Map (Choice2Map mapL mapR) = s (status mapL) (status mapR) where + s None None = None + s None (One kR aR) = One (C2of2 kR) aR + s (One kL aL) None = One (C1of2 kL) aL + s _ _ = Many + +-- | See 'Map' class method 'addSize'. +addSizeChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Int# -> Int# +addSizeChoice2Map (Choice2Map mapL mapR) n = addSize mapL (addSize mapR n) + +-- | See 'Map' class method 'lookup'. +lookupChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Maybe a +lookupChoice2Map (C1of2 kL) (Choice2Map mapL _ ) = lookup kL mapL +lookupChoice2Map (C2of2 kR) (Choice2Map _ mapR) = lookup kR mapR + +-- | See 'Map' class method 'alter'. +alterChoice2Map :: (Map mapL kL, Map mapR kR) => (Maybe a -> Maybe a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +alterChoice2Map f (C1of2 kL) (Choice2Map mapL mapR) = Choice2Map (alter f kL mapL) mapR +alterChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (alter f kR mapR) + +-- | See 'Map' class method 'insert'. +insertWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +insertWithChoice2Map f (C1of2 kL) a (Choice2Map mapL mapR) = Choice2Map (insertWith f kL a mapL) mapR +insertWithChoice2Map f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertWith f kR a mapR) + +-- | See 'Map' class method 'insert''. +insertWithChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +insertWithChoice2Map' f (C1of2 kL) a (Choice2Map mapL mapR) = Choice2Map (insertWith' f kL a mapL) mapR +insertWithChoice2Map' f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertWith' f kR a mapR) + +-- | See 'Map' class method 'insertMaybe'. +insertMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe a) -> Choice2 kL kR -> a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +insertMaybeChoice2Map f (C1of2 kL) a (Choice2Map mapL mapR) = Choice2Map (insertMaybe f kL a mapL) mapR +insertMaybeChoice2Map f (C2of2 kR) a (Choice2Map mapL mapR) = Choice2Map mapL (insertMaybe f kR a mapR) + +isC1of2 :: Choice2 a b -> Bool +isC1of2 (C1of2 _) = True +isC1of2 (C2of2 _) = False + +isC2of2 :: Choice2 a b -> Bool +isC2of2 (C1of2 _) = False +isC2of2 (C2of2 _) = True + +fromAssocsWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsWithChoice2Map f as = Choice2Map (fromAssocsWith f ls) (fromAssocsWith f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (lefts,rights) = L.partition (isC1of2 . fst) as + +fromAssocsMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsMaybeChoice2Map f as = Choice2Map (fromAssocsMaybe f ls) (fromAssocsMaybe f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (lefts,rights) = L.partition (isC1of2 . fst) as + +fromAssocsAscWithChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsAscWithChoice2Map f as = Choice2Map (fromAssocsAscWith f ls) (fromAssocsAscWith f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (lefts,rights) = L.span (isC1of2 . fst) as + +fromAssocsAscMaybeChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsAscMaybeChoice2Map f as = Choice2Map (fromAssocsAscMaybe f ls) (fromAssocsAscMaybe f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (lefts,rights) = L.span (isC1of2 . fst) as + +fromAssocsDescWithChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsDescWithChoice2Map f as = Choice2Map (fromAssocsDescWith f ls) (fromAssocsDescWith f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (rights,lefts) = L.span (isC2of2 . fst) as + +fromAssocsDescMaybeChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> a -> Maybe a) -> [(Choice2 kL kR,a)] -> Choice2Map mapL mapR kL kR a +fromAssocsDescMaybeChoice2Map f as = Choice2Map (fromAssocsDescMaybe f ls) (fromAssocsDescMaybe f rs) + where ls = L.map (\((C1of2 k), a) -> (k,a)) lefts + rs = L.map (\((C2of2 k), a) -> (k,a)) rights + (rights,lefts) = L.span (isC2of2 . fst) as + +-- | See 'Map' class method 'delete'. +deleteChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +deleteChoice2Map (C1of2 kL) (Choice2Map mapL mapR) = Choice2Map (delete kL mapL) mapR +deleteChoice2Map (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (delete kR mapR) + +-- | See 'Map' class method 'adjustWith'. +adjustWithChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +adjustWithChoice2Map f (C1of2 kL) (Choice2Map mapL mapR) = Choice2Map (adjustWith f kL mapL) mapR +adjustWithChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustWith f kR mapR) + +-- | See 'Map' class method 'adjustWith'. +adjustWithChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +adjustWithChoice2Map' f (C1of2 kL) (Choice2Map mapL mapR) = Choice2Map (adjustWith' f kL mapL) mapR +adjustWithChoice2Map' f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustWith' f kR mapR) + +-- | See 'Map' class method 'adjustMaybe'. +adjustMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe a) -> Choice2 kL kR -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +adjustMaybeChoice2Map f (C1of2 kL) (Choice2Map mapL mapR) = Choice2Map (adjustMaybe f kL mapL) mapR +adjustMaybeChoice2Map f (C2of2 kR) (Choice2Map mapL mapR) = Choice2Map mapL (adjustMaybe f kR mapR) + +-- | See 'Map' class method 'venn'. +vennChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b) +vennChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR) + where (leftDiffL, interL, rightDiffL) = venn f mapL0 mapL1 + (leftDiffR, interR, rightDiffR) = venn f mapR0 mapR1 + +-- | See 'Map' class method 'venn''. +vennChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b) +vennChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR) + where (leftDiffL, interL, rightDiffL) = venn' f mapL0 mapL1 + (leftDiffR, interR, rightDiffR) = venn' f mapR0 mapR1 + +-- | See 'Map' class method 'vennMaybe'. +vennMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> (Choice2Map mapL mapR kL kR a, Choice2Map mapL mapR kL kR c, Choice2Map mapL mapR kL kR b) +vennMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + (Choice2Map leftDiffL leftDiffR, Choice2Map interL interR, Choice2Map rightDiffL rightDiffR) + where (leftDiffL, interL, rightDiffL) = vennMaybe f mapL0 mapL1 + (leftDiffR, interR, rightDiffR) = vennMaybe f mapR0 mapR1 + +-- | See 'Map' class method 'disjointUnion'. +disjointUnionChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +disjointUnionChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (disjointUnion mapL0 mapL1) (disjointUnion mapR0 mapR1) + +-- | See 'Map' class method 'union'. +unionChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +unionChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (union f mapL0 mapL1) (union f mapR0 mapR1) + +-- | See 'Map' class method 'union''. +unionChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +unionChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (union' f mapL0 mapL1) (union' f mapR0 mapR1) + +-- | See 'Map' class method 'unionMaybe'. +unionMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> a -> Maybe a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +unionMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (unionMaybe f mapL0 mapL1) (unionMaybe f mapR0 mapR1) + +-- | See 'Map' class method 'intersection'. +intersectionChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c +intersectionChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (intersection f mapL0 mapL1) (intersection f mapR0 mapR1) + +-- | See 'Map' class method 'intersection''. +intersectionChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c +intersectionChoice2Map' f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (intersection' f mapL0 mapL1) (intersection' f mapR0 mapR1) + +-- | See 'Map' class method 'intersectionMaybe'. +intersectionMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe c) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR c +intersectionMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (intersectionMaybe f mapL0 mapL1) (intersectionMaybe f mapR0 mapR1) + +-- | See 'Map' class method 'difference'. +differenceChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR a +differenceChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (difference mapL0 mapL1) (difference mapR0 mapR1) + +-- | See 'Map' class method 'differenceMaybe'. +differenceMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Maybe a) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Choice2Map mapL mapR kL kR a +differenceMaybeChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + Choice2Map (differenceMaybe f mapL0 mapL1) (differenceMaybe f mapR0 mapR1) + +-- | See 'Map' class method 'isSubsetOf'. +isSubsetOfChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Bool +isSubsetOfChoice2Map (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + isSubsetOf mapL0 mapL1 && isSubsetOf mapR0 mapR1 + +-- | See 'Map' class method 'isSubmapOf'. +isSubmapOfChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> Bool) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b -> Bool +isSubmapOfChoice2Map f (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = + isSubmapOf f mapL0 mapL1 && isSubmapOf f mapR0 mapR1 + +-- | See 'Map' class method 'map'. +mapChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b +mapChoice2Map f (Choice2Map mapL mapR) = Choice2Map (map f mapL) (map f mapR) + +-- | See 'Map' class method 'map''. +mapChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b +mapChoice2Map' f (Choice2Map mapL mapR) = Choice2Map (map' f mapL) (map' f mapR) + +-- | See 'Map' class method 'mapMaybe'. +mapMaybeChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Maybe b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b +mapMaybeChoice2Map f (Choice2Map mapL mapR) = Choice2Map (mapMaybe f mapL) (mapMaybe f mapR) + +-- | See 'Map' class method 'mapWithKey'. +mapWithKeyChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b +mapWithKeyChoice2Map f (Choice2Map mapL mapR) = + Choice2Map (mapWithKey (\kL a -> f (C1of2 kL) a) mapL) (mapWithKey (\kR a -> f (C2of2 kR) a) mapR) + +-- | See 'Map' class method 'mapWithKey''. +mapWithKeyChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b +mapWithKeyChoice2Map' f (Choice2Map mapL mapR) = + Choice2Map (mapWithKey' (\kL a -> f (C1of2 kL) a) mapL) (mapWithKey' (\kR a -> f (C2of2 kR) a) mapR) + +-- | See 'Map' class method 'filter'. +filterChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Bool) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a +filterChoice2Map p (Choice2Map mapL mapR) = Choice2Map (filter p mapL) (filter p mapR) + +-- | See 'Map' class method 'foldElems'. +foldElemsChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsChoice2Map f b (Choice2Map mapL mapR) = + foldElems f (foldElems f b mapR) mapL + +-- | See 'Map' class method 'foldKeys'. +foldKeysChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysChoice2Map f b0 (Choice2Map mapL mapR) = + foldKeys (\kL b -> f (C1of2 kL) b) (foldKeys (\kR b -> f (C2of2 kR) b) b0 mapR) mapL + +-- | See 'Map' class method 'foldAssocs'. +foldAssocsChoice2Map :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsChoice2Map f b0 (Choice2Map mapL mapR) = + foldAssocs (\kL a b -> f (C1of2 kL) a b) (foldAssocs (\kR a b -> f (C2of2 kR) a b) b0 mapR) mapL + +-- | See 'Map' class method 'foldElems''. +foldElemsChoice2Map' :: (Map mapL kL, Map mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsChoice2Map' f b (Choice2Map mapL mapR) = + (\z -> foldElems' f z mapL) $! foldElems' f b mapR + +-- | See 'Map' class method 'foldKeys''. +foldKeysChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldKeys' (\kL b -> f (C1of2 kL) b) z mapL) $! foldKeys' (\kR b -> f (C2of2 kR) b) b0 mapR + +-- | See 'Map' class method 'foldAssocs''. +foldAssocsChoice2Map' :: (Map mapL kL, Map mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldAssocs' (\kL a b -> f (C1of2 kL) a b) z mapL) $! foldAssocs' (\kR a b -> f (C2of2 kR) a b) b0 mapR + + ------------------------ + +-- | See 'Map' class method 'foldElemsAsc'. +foldElemsAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsAscChoice2Map f b (Choice2Map mapL mapR) = + foldElemsAsc f (foldElemsAsc f b mapR) mapL + +-- | See 'Map' class method 'foldElemsDesc'. +foldElemsDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsDescChoice2Map f b (Choice2Map mapL mapR) = + foldElemsDesc f (foldElemsDesc f b mapL) mapR + +-- | See 'Map' class method 'foldKeysAsc'. +foldKeysAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysAscChoice2Map f b0 (Choice2Map mapL mapR) = + foldKeysAsc (\kL b -> f (C1of2 kL) b) (foldKeysAsc (\kR b -> f (C2of2 kR) b) b0 mapR) mapL + +-- | See 'Map' class method 'foldKeysDesc'. +foldKeysDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysDescChoice2Map f b0 (Choice2Map mapL mapR) = + foldKeysDesc (\kR b -> f (C2of2 kR) b) (foldKeysDesc (\kL b -> f (C1of2 kL) b) b0 mapL) mapR + +-- | See 'Map' class method 'foldAssocsAsc'. +foldAssocsAscChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsAscChoice2Map f b0 (Choice2Map mapL mapR) = + foldAssocsAsc (\kL a b -> f (C1of2 kL) a b) (foldAssocsAsc (\kR a b -> f (C2of2 kR) a b) b0 mapR) mapL + +-- | See 'Map' class method 'foldAssocsDesc'. +foldAssocsDescChoice2Map :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsDescChoice2Map f b0 (Choice2Map mapL mapR) = + foldAssocsDesc (\kR a b -> f (C2of2 kR) a b) (foldAssocsDesc (\kL a b -> f (C1of2 kL) a b) b0 mapL) mapR + +-- | See 'Map' class method 'foldElemsAsc''. +foldElemsAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsAscChoice2Map' f b (Choice2Map mapL mapR) = + (\z -> foldElemsAsc' f z mapL) $! foldElemsAsc' f b mapR + +-- | See 'Map' class method 'foldElemsDesc''. +foldElemsDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldElemsDescChoice2Map' f b (Choice2Map mapL mapR) = + (\z -> foldElemsDesc' f z mapR) $! foldElemsDesc' f b mapL + +-- | See 'Map' class method 'foldKeysAsc''. +foldKeysAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysAscChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldKeysAsc' (\kL b -> f (C1of2 kL) b) z mapL) $! foldKeysAsc' (\kR b -> f (C2of2 kR) b) b0 mapR + +-- | See 'Map' class method 'foldKeysDesc''. +foldKeysDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldKeysDescChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldKeysDesc' (\kR b -> f (C2of2 kR) b) z mapR) $! foldKeysDesc' (\kL b -> f (C1of2 kL) b) b0 mapL + +-- | See 'Map' class method 'foldAssocsAsc''. +foldAssocsAscChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsAscChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldAssocsAsc' (\kL a b -> f (C1of2 kL) a b) z mapL) $! foldAssocsAsc' (\kR a b -> f (C2of2 kR) a b) b0 mapR + +-- | See 'Map' class method 'foldAssocsDesc''. +foldAssocsDescChoice2Map' :: (OrderedMap mapL kL, OrderedMap mapR kR) => (Choice2 kL kR -> a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b +foldAssocsDescChoice2Map' f b0 (Choice2Map mapL mapR) = + (\z -> foldAssocsDesc' (\kR a b -> f (C2of2 kR) a b) z mapR) $! foldAssocsDesc' (\kL a b -> f (C1of2 kL) a b) b0 mapL + +-- | See 'Map' class method 'foldElemsUInt'. +foldElemsUIntChoice2Map :: (Map mapL kL, Map mapR kR) => (a -> Int# -> Int#) -> Int# -> Choice2Map mapL mapR kL kR a -> Int# +foldElemsUIntChoice2Map f n (Choice2Map mapL mapR) = foldElemsUInt f (foldElemsUInt f n mapR) mapL + +-- | See 'Map' class method 'valid'. +validChoice2Map :: (Map mapL kL, Map mapR kR) => Choice2Map mapL mapR kL kR a -> Maybe String +validChoice2Map (Choice2Map mapL mapR) = case valid mapL of + Nothing -> valid mapR + j -> j + +-- | See 'Map' class method 'compareKeys' +compareKeyChoice2Map :: (OrderedMap mapL kl, OrderedMap mapR kr) => + Choice2Map mapL mapR kL kR a -> Choice2 kl kr -> Choice2 kl kr -> Ordering +compareKeyChoice2Map mp (C1of2 k1) (C1of2 k2) = compareKey (leftMap mp) k1 k2 + where leftMap :: Choice2Map mapL mapR kL kR a -> mapL a + leftMap = undefined +compareKeyChoice2Map _ (C1of2 _) (C2of2 _) = LT +compareKeyChoice2Map _ (C2of2 _) (C1of2 _) = GT +compareKeyChoice2Map mp (C2of2 k1) (C2of2 k2) = compareKey (rightMap mp) k1 k2 + where rightMap :: Choice2Map mapL mapR kL kR a -> mapR a + rightMap = undefined +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance (Eq (mapL a), Eq (mapR a)) => Eq (Choice2Map mapL mapR kL kR a) where + Choice2Map mapL0 mapR0 == Choice2Map mapL1 mapR1 = (mapL0 == mapL1) && (mapR0 == mapR1) + +--------- +-- Ord -- +--------- +instance (Map mapL kL, Map mapR kR, Ord (mapL a), Ord (mapR a)) => Ord (Choice2Map mapL mapR kL kR a) where + compare (Choice2Map mapL0 mapR0) (Choice2Map mapL1 mapR1) = c (isEmpty mapL0) (isEmpty mapL1) where + c True True = compare mapR0 mapR1 + c True False = if isEmpty mapR0 then LT else GT + c False True = if isEmpty mapR1 then GT else LT + c False False = case compare mapL0 mapL1 of + LT -> LT + EQ -> compare mapR0 mapR1 + GT -> GT + +---------- +-- Show -- +---------- +instance (Map mapL kL, Map mapR kR, Show kL, Show kR, Show a) => Show (Choice2Map mapL mapR kL kR a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocs " . shows (assocs mp) + +---------- +-- Read -- +---------- +instance (Map mapL kL, Map mapR kR, R.Read kL, R.Read kR, R.Read a) => R.Read (Choice2Map mapL mapR kL kR a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP + xs <- R.readPrec + return (fromAssocs xs) + readListPrec = R.readListPrecDefault + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance (Typeable1 mapL, Typeable1 mapR) => Typeable1 (Choice2Map mapL mapR kL kR) where + typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.ChoiceMap.Choice2Map") [typeOf1 mapL, typeOf1 mapR] + where Choice2Map mapL mapR = m -- This is just to get types for mapL & mapR !! +-------------- +instance (Typeable1 (Choice2Map mapL mapR kL kR), Typeable a) => Typeable (Choice2Map mapL mapR kL kR a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance (Map mapL kL, Map mapR kR) => Functor (Choice2Map mapL mapR kL kR) where +-- fmap :: (a -> b) -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR b + fmap = mapChoice2Map -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Map mapL kL, Map mapR kR, M.Monoid a) => M.Monoid (Choice2Map mapL mapR kL kR a) where +-- mempty :: Choice2Map mapL mapR kL kR a + mempty = emptyChoice2Map +-- mappend :: Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a -> Choice2Map mapL mapR kL kR a + mappend map0 map1 = unionChoice2Map M.mappend map0 map1 +-- mconcat :: [Choice2Map mapL mapR kL kR a] -> Choice2Map mapL mapR kL kR a + mconcat maps = L.foldr (unionChoice2Map M.mappend) emptyChoice2Map maps + +------------------- +-- Data.Foldable -- +------------------- +instance (Map mapL kL, Map mapR kR) => F.Foldable (Choice2Map mapL mapR kL kR) where +-- fold :: Monoid m => Choice2Map mapL mapR m -> m + fold mp = foldElemsChoice2Map M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> Choice2Map mapL mapR kL kR a -> m + foldMap f mp = foldElemsChoice2Map (\a b -> M.mappend (f a) b) M.mempty mp +-- fold :: (a -> b -> b) -> b -> Choice2Map mapL mapR kL kR a -> b + foldr f b0 mp = foldElemsChoice2Map f b0 mp +-- foldl :: (a -> b -> a) -> a -> Choice2Map mapL mapR kL kR b -> a + foldl f b0 mp = foldElemsChoice2Map (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- fold1 :: (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> a + fold1 = undefined +-- foldl1 :: (a -> a -> a) -> Choice2Map mapL mapR kL kR a -> a + foldl1 = undefined +-} + +------------------------------------------------------------------------------- + +data Choice3 a b c = C1of3 a | C2of3 b | C3of3 c deriving (Eq,Ord,Read,Show) + +data InjectChoice3 a b c + +instance Injection (InjectChoice3 a b c) (Choice3 a b c) (Choice2 a (Choice2 b c)) where + inject _ choice = case choice of + C1of3 a -> C1of2 a + C2of3 b -> C2of2 (C1of2 b) + C3of3 c -> C2of2 (C2of2 c) + outject _ choice = case choice of + C1of2 a -> C1of3 a + C2of2 (C1of2 b) -> C2of3 b + C2of2 (C2of2 c) -> C3of3 c + +type Choice3Map mapa mapb mapc a b c = + InjectKeys (InjectChoice3 a b c) (Choice3 a b c) (Choice2 a (Choice2 b c)) + (Choice2Map mapa + (Choice2Map mapb mapc b c) + a (Choice2 b c)) + + + +data Choice4 a b c d = C1of4 a | C2of4 b | C3of4 c | C4of4 d deriving (Eq,Ord,Read,Show) + +data InjectChoice4 a b c d + +instance Injection (InjectChoice4 a b c d) (Choice4 a b c d) (Choice2 (Choice2 a b) (Choice2 c d)) where + inject _ choice = case choice of + C1of4 a -> C1of2 (C1of2 a) + C2of4 b -> C1of2 (C2of2 b) + C3of4 c -> C2of2 (C1of2 c) + C4of4 d -> C2of2 (C2of2 d) + outject _ choice = case choice of + C1of2 (C1of2 a) -> C1of4 a + C1of2 (C2of2 b) -> C2of4 b + C2of2 (C1of2 c) -> C3of4 c + C2of2 (C2of2 d) -> C4of4 d + +type Choice4Map mapa mapb mapc mapd a b c d = + InjectKeys (InjectChoice4 a b c d) (Choice4 a b c d) (Choice2 (Choice2 a b) (Choice2 c d)) + (Choice2Map + (Choice2Map mapa mapb a b) + (Choice2Map mapc mapd c d) + (Choice2 a b) (Choice2 c d)) + + + +data Choice5 a b c d e = C1of5 a | C2of5 b | C3of5 c | C4of5 d | C5of5 e deriving (Eq,Ord,Read,Show) + +data InjectChoice5 a b c d e + +instance Injection (InjectChoice5 a b c d e) (Choice5 a b c d e) (Choice2 (Choice2 a b) (Choice2 c (Choice2 d e))) where + inject _ choice = case choice of + C1of5 a -> C1of2 (C1of2 a) + C2of5 b -> C1of2 (C2of2 b) + C3of5 c -> C2of2 (C1of2 c) + C4of5 d -> C2of2 (C2of2 (C1of2 d)) + C5of5 e -> C2of2 (C2of2 (C2of2 e)) + outject _ choice = case choice of + C1of2 (C1of2 a) -> C1of5 a + C1of2 (C2of2 b) -> C2of5 b + C2of2 (C1of2 c) -> C3of5 c + C2of2 (C2of2 (C1of2 d)) -> C4of5 d + C2of2 (C2of2 (C2of2 e)) -> C5of5 e + +type Choice5Map mapa mapb mapc mapd mape a b c d e = + InjectKeys (InjectChoice5 a b c d e) (Choice5 a b c d e) (Choice2 (Choice2 a b) (Choice2 c (Choice2 d e))) + (Choice2Map + (Choice2Map mapa mapb a b) + (Choice2Map mapc + (Choice2Map mapd mape d e) + c (Choice2 d e)) + (Choice2 a b) (Choice2 c (Choice2 d e))) diff --git a/src/Data/GMap/EitherMap.hs b/src/Data/GMap/EitherMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/EitherMap.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.EitherMap +( + EitherMap +) where + +import Data.GMap() + +import Data.GMap.ChoiceMap +import Data.GMap.InjectKeys + +-------------------------------------------------------------------------------------------- +-- Map Type for Either -- +-------------------------------------------------------------------------------------------- + +data InjectEither l r + +instance Injection (InjectEither l r) (Either l r) (Choice2 l r) where + inject _ (Left l) = C1of2 l + inject _ (Right r) = C2of2 r + outject _ (C1of2 l) = Left l + outject _ (C2of2 r) = Right r + +type EitherMap mapL mapR l r = InjectKeys (InjectEither l r) (Either l r) (Choice2 l r) (Choice2Map mapL mapR l r) diff --git a/src/Data/GMap/EnumMap.hs b/src/Data/GMap/EnumMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/EnumMap.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.EnumMap +(-- * EnumMap type + EnumMap +) where + +import Data.GMap() + +import Data.GMap.IntMap +import Data.GMap.InjectKeys + +-------------------------------------------------------------------------------------------- +-- Map Type for 'Enum'erable keys -- +-------------------------------------------------------------------------------------------- + +data InjectEnum k + +instance Enum k => Injection (InjectEnum k) k Int where + inject _ = fromEnum + outject _ = toEnum + +type EnumMap k = InjectKeys (InjectEnum k) k Int IntMap diff --git a/src/Data/GMap/InjectKeys.hs b/src/Data/GMap/InjectKeys.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/InjectKeys.hs @@ -0,0 +1,299 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures -fno-monomorphism-restriction #-} + +module Data.GMap.InjectKeys +(-- * InjectKeys type + InjectKeys +,Injection +,inject +,outject +) 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 +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +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 + +-------------------------------------------------------------------------------------------- +-- Used when keys can be transformed into the key type of an existing maps +-- eg. to store Enums in an IntMap +-------------------------------------------------------------------------------------------- + +data InjectKeys t k1 k2 map a = InjectKeys !(map a) + +-- | 't' is a phantom type which determines the encoding and decoding functions used. +-- 't' is passed as an undefined value. +-- 'inject' must be injective (ie (inject a) == (inject b) implies a == b) and reversible by 'outject' +class Injection t k1 k2 | t -> k1, t -> k2 where + inject :: t -> k1 -> k2 + outject :: t -> k2 -> k1 + +transformOf :: InjectKeys t k1 k2 map a -> t +transformOf = undefined + +-- Dont export these, used to force correct types +injectFor :: Injection t k1 k2 => InjectKeys t k1 k2 map a -> k1 -> k2 +injectFor mp k1 = inject (transformOf mp) k1 + +outjectFor :: Injection t k1 k2 => InjectKeys t k1 k2 map a -> k2 -> k1 +outjectFor mp k2 = outject (transformOf mp) k2 + +-- | InjectKeys is an instance of Map. +instance (Eq k1, Injection t k1 k2, Map map k2) => Map (InjectKeys t k1 k2 map) k1 where + empty = emptyInjectKeys + singleton = singletonInjectKeys + pair = pairInjectKeys + nonEmpty = nonEmptyInjectKeys + status = statusInjectKeys + addSize = addSizeInjectKeys + lookup = lookupInjectKeys + lookupCont = lookupContInjectKeys + alter = alterInjectKeys + insertWith = insertWithInjectKeys + insertWith' = insertWithInjectKeys' + insertMaybe = insertMaybeInjectKeys +-- fromAssocsWith = fromAssocsWithInjectKeys +-- fromAssocsMaybe = fromAssocsMaybeInjectKeys + delete = deleteInjectKeys + adjustWith = adjustWithInjectKeys + adjustWith' = adjustWithInjectKeys' + adjustMaybe = adjustMaybeInjectKeys + venn = vennInjectKeys + venn' = vennInjectKeys' + vennMaybe = vennMaybeInjectKeys + disjointUnion = disjointUnionInjectKeys + union = unionInjectKeys + union' = unionInjectKeys' + unionMaybe = unionMaybeInjectKeys + intersection = intersectionInjectKeys + intersection' = intersectionInjectKeys' + intersectionMaybe = intersectionMaybeInjectKeys + difference = differenceInjectKeys + differenceMaybe = differenceMaybeInjectKeys + isSubsetOf = isSubsetOfInjectKeys + isSubmapOf = isSubmapOfInjectKeys + map = mapInjectKeys + map' = mapInjectKeys' + mapMaybe = mapMaybeInjectKeys + mapWithKey = mapWithInjectionKeys + mapWithKey' = mapWithInjectionKeys' + filter = filterInjectKeys + foldKeys = foldKeysInjectKeys + foldElems = foldElemsInjectKeys + foldAssocs = foldAssocsInjectKeys + foldKeys' = foldKeysInjectKeys' + foldElems' = foldElemsInjectKeys' + foldAssocs' = foldAssocsInjectKeys' + foldElemsUInt = foldElemsUIntInjectKeys + valid = validInjectKeys + +instance (Eq k1, Injection t k1 k2, OrderedMap map k2) => OrderedMap (InjectKeys t k1 k2 map) k1 where + compareKey = compareInjectionKeys + fromAssocsAscWith = fromAssocsAscWithInjectKeys + fromAssocsDescWith = fromAssocsDescWithInjectKeys + fromAssocsAscMaybe = fromAssocsAscMaybeInjectKeys + fromAssocsDescMaybe = fromAssocsDescMaybeInjectKeys + foldElemsAsc = foldElemsAscInjectKeys + foldElemsDesc = foldElemsDescInjectKeys + foldKeysAsc = foldKeysAscInjectKeys + foldKeysDesc = foldKeysDescInjectKeys + foldAssocsAsc = foldAssocsAscInjectKeys + foldAssocsDesc = foldAssocsDescInjectKeys + foldElemsAsc' = foldElemsAscInjectKeys' + foldElemsDesc' = foldElemsDescInjectKeys' + foldKeysAsc' = foldKeysAscInjectKeys' + foldKeysDesc' = foldKeysDescInjectKeys' + foldAssocsAsc' = foldAssocsAscInjectKeys' + foldAssocsDesc' = foldAssocsDescInjectKeys' + +emptyInjectKeys = InjectKeys empty + +singletonInjectKeys k a = let tk = InjectKeys (singleton (injectFor tk k) a) in tk + +fromAssocsAscWithInjectKeys f kas = let tk = InjectKeys (fromAssocsAscWith f [(injectFor tk k,a) | (k,a) <- kas]) in tk +fromAssocsDescWithInjectKeys f kas = let tk = InjectKeys (fromAssocsDescWith f [(injectFor tk k,a) | (k,a) <- kas]) in tk +fromAssocsAscMaybeInjectKeys f kas = let tk = InjectKeys (fromAssocsAscMaybe f [(injectFor tk k,a) | (k,a) <- kas]) in tk +fromAssocsDescMaybeInjectKeys f kas = let tk = InjectKeys (fromAssocsDescMaybe f [(injectFor tk k,a) | (k,a) <- kas]) in tk + +pairInjectKeys k1 k2 = + let tk = (fromJust pairf) undefined undefined -- Roundabout way of getting hold of the transform type + pairf = + case pair (injectFor tk k1) (injectFor tk k2) of + Nothing -> Nothing + Just f -> Just (\a1 a2 -> InjectKeys (f a1 a2)) + in pairf + +nonEmptyInjectKeys (InjectKeys mp) = fmap InjectKeys (nonEmpty mp) + +statusInjectKeys tk@(InjectKeys mp) = + case status mp of + None -> None + One k a -> One (outjectFor tk k) a + Many -> Many + +addSizeInjectKeys (InjectKeys mp) = addSize mp + +lookupInjectKeys k tk@(InjectKeys mp) = lookup (injectFor tk k) mp + +lookupContInjectKeys f k tk@(InjectKeys mp) = lookupCont f (injectFor tk k) mp + +alterInjectKeys f k tk@(InjectKeys mp) = InjectKeys (alter f (injectFor tk k) mp) + +insertWithInjectKeys f k a tk@(InjectKeys mp) = InjectKeys (insertWith f (injectFor tk k) a mp) +insertWithInjectKeys' f k a tk@(InjectKeys mp) = InjectKeys (insertWith' f (injectFor tk k) a mp) + +insertMaybeInjectKeys f k a tk@(InjectKeys mp) = InjectKeys (insertMaybe f (injectFor tk k) a mp) + +deleteInjectKeys k tk@(InjectKeys mp) = InjectKeys (delete (injectFor tk k) mp) + +adjustWithInjectKeys f k tk@(InjectKeys mp) = InjectKeys (adjustWith f (injectFor tk k) mp) +adjustWithInjectKeys' f k tk@(InjectKeys mp) = InjectKeys (adjustWith' f (injectFor tk k) mp) + +adjustMaybeInjectKeys f k tk@(InjectKeys mp) = InjectKeys (adjustMaybe f (injectFor tk k) mp) + +vennInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff) + where (leftDiff, inter, rightDiff) = venn f mp1 mp2 +vennInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff) + where (leftDiff, inter, rightDiff) = venn' f mp1 mp2 +vennMaybeInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = (InjectKeys leftDiff, InjectKeys inter, InjectKeys rightDiff) + where (leftDiff, inter, rightDiff) = vennMaybe f mp1 mp2 + +disjointUnionInjectKeys (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (disjointUnion mp1 mp2) +unionInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (union f mp1 mp2) +unionInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (union' f mp1 mp2) + +unionMaybeInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (unionMaybe f mp1 mp2) + +intersectionInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersection f mp1 mp2) +intersectionInjectKeys' f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersection' f mp1 mp2) + +intersectionMaybeInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (intersectionMaybe f mp1 mp2) + +differenceInjectKeys (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (difference mp1 mp2) + +differenceMaybeInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = InjectKeys (differenceMaybe f mp1 mp2) + +isSubsetOfInjectKeys (InjectKeys mp1) (InjectKeys mp2) = isSubsetOf mp1 mp2 +isSubmapOfInjectKeys f (InjectKeys mp1) (InjectKeys mp2) = isSubmapOf f mp1 mp2 + +mapInjectKeys f (InjectKeys mp) = InjectKeys (map f mp) +mapInjectKeys' f (InjectKeys mp) = InjectKeys (map' f mp) + +mapMaybeInjectKeys f (InjectKeys mp) = InjectKeys (mapMaybe f mp) + +mapWithInjectionKeys f tk@(InjectKeys mp) = InjectKeys (mapWithKey (\k a -> f (outjectFor tk k) a) mp) +mapWithInjectionKeys' f tk@(InjectKeys mp) = InjectKeys (mapWithKey' (\k a -> f (outjectFor tk k) a) mp) + +filterInjectKeys f (InjectKeys mp) = InjectKeys (filter f mp) + +foldElemsInjectKeys f b (InjectKeys mp) = foldElems f b mp +foldKeysInjectKeys f b tk@(InjectKeys mp) = foldKeys (\ k b' -> f (outjectFor tk k) b') b mp +foldAssocsInjectKeys f b tk@(InjectKeys mp) = foldAssocs (\ k a b' -> f (outjectFor tk k) a b') b mp +foldElemsInjectKeys' f b (InjectKeys mp) = foldElems' f b mp +foldKeysInjectKeys' f b tk@(InjectKeys mp) = foldKeys' (\ k b' -> f (outjectFor tk k) b') b mp +foldAssocsInjectKeys' f b tk@(InjectKeys mp) = foldAssocs' (\ k a b' -> f (outjectFor tk k) a b') b mp +foldElemsAscInjectKeys f b (InjectKeys mp) = foldElemsAsc f b mp +foldElemsDescInjectKeys f b (InjectKeys mp) = foldElemsDesc f b mp +foldKeysAscInjectKeys f b tk@(InjectKeys mp) = foldKeysAsc (\ k b' -> f (outjectFor tk k) b') b mp +foldKeysDescInjectKeys f b tk@(InjectKeys mp) = foldKeysDesc (\ k b' -> f (outjectFor tk k) b') b mp +foldAssocsAscInjectKeys f b tk@(InjectKeys mp) = foldAssocsAsc (\ k a b' -> f (outjectFor tk k) a b') b mp +foldAssocsDescInjectKeys f b tk@(InjectKeys mp) = foldAssocsDesc (\ k a b' -> f (outjectFor tk k) a b') b mp +foldElemsAscInjectKeys' f b (InjectKeys mp) = foldElemsAsc' f b mp +foldElemsDescInjectKeys' f b (InjectKeys mp) = foldElemsDesc' f b mp +foldKeysAscInjectKeys' f b tk@(InjectKeys mp) = foldKeysAsc' (\ k b' -> f (outjectFor tk k) b') b mp +foldKeysDescInjectKeys' f b tk@(InjectKeys mp) = foldKeysDesc' (\ k b' -> f (outjectFor tk k) b') b mp +foldAssocsAscInjectKeys' f b tk@(InjectKeys mp) = foldAssocsAsc' (\ k a b' -> f (outjectFor tk k) a b') b mp +foldAssocsDescInjectKeys' f b tk@(InjectKeys mp) = foldAssocsDesc' (\ k a b' -> f (outjectFor tk k) a b') b mp +foldElemsUIntInjectKeys f b (InjectKeys mp) = foldElemsUInt f b mp + +validInjectKeys (InjectKeys mp) = valid mp + +compareInjectionKeys tk k1 k2 = compareKey (innerMap tk) (injectFor tk k1) (injectFor tk k2) + where innerMap :: InjectKeys t k1 k2 map a -> map a + innerMap = undefined + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance (Eq (map a)) => Eq (InjectKeys t k1 k2 map a) where + (InjectKeys kmp1) == (InjectKeys kmp2) = (kmp1 == kmp2) + +--------- +-- Ord -- +--------- +instance (Ord (map a)) => Ord (InjectKeys t k1 k2 map a) where + compare (InjectKeys kmp1) (InjectKeys kmp2) = compare kmp1 kmp2 + +-- Show and read instances require transforming keys. Not hard but no time right now. +-- ---------- +-- -- Show -- +-- ---------- +-- instance (Show (map a)) => Show (InjectKeys t k1 k2 map a) where +-- showsPrec d (InjectKeys mp) = showsPrec d mp +-- +-- ---------- +-- -- Read -- +-- ---------- +-- instance (Read (map a)) => R.Read (InjectKeys t k1 k2 map a) where +-- readPrec = InjectKeys `fmap` R.readPrec +-- readListPrec = (L.map InjectKeys ) `fmap` R.readListPrec + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance (Typeable1 map) => Typeable1 (InjectKeys t k1 k2 map) where + typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.InjectKeys.InjectKeys") [typeOf1 innermp] + where InjectKeys innermp = m -- This is just to get the type for innermp!! +-------------- +instance (Typeable1 (InjectKeys t k1 k2 map), Typeable a) => Typeable (InjectKeys t k1 k2 map a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance (Map map k2) => Functor (InjectKeys t k1 k2 map) where +-- fmap :: (a -> b) -> EitherMap mapL mapR a -> EitherMap mapL mapR b + fmap = mapInjectKeys -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Map map k2, M.Monoid a) => M.Monoid (InjectKeys t k1 k2 map a) where +-- mempty :: EitherMap mapL mapR a + mempty = emptyInjectKeys +-- mappend :: EitherMap mapL mapR a -> EitherMap mapL mapR a -> EitherMap mapL mapR a + mappend map0 map1 = unionInjectKeys M.mappend map0 map1 +-- mconcat :: [EitherMap mapL mapR a] -> EitherMap mapL mapR a + mconcat maps = L.foldr (unionInjectKeys M.mappend) emptyInjectKeys maps + +------------------- +-- Data.Foldable -- +------------------- +instance (Map map k2) => F.Foldable (InjectKeys t k1 k2 map) where +-- fold :: Monoid m => InjectKeys mapL mapR m -> m + fold mp = foldElemsInjectKeys M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> InjectKeys mapL mapR a -> m + foldMap f mp = foldElemsInjectKeys (\a b -> M.mappend (f a) b) M.mempty mp +-- fold :: (a -> b -> b) -> b -> InjectKeys mapL mapR a -> b + foldr f b0 mp = foldElemsInjectKeys f b0 mp +-- foldl :: (a -> b -> a) -> a -> InjectKeys mapL mapR b -> a + foldl f b0 mp = foldElemsInjectKeys (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- fold1 :: (a -> a -> a) -> InjectKeys mapL mapR a -> a + fold1 = undefined +-- foldl1 :: (a -> a -> a) -> InjectKeys mapL mapR a -> a + foldl1 = undefined +-} diff --git a/src/Data/GMap/IntMap.hs b/src/Data/GMap/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/IntMap.hs @@ -0,0 +1,4010 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -Wall #-} + +module Data.GMap.IntMap +(-- * IntMap type + IntMap +) where + +import Prelude hiding (foldr,map,filter,lookup) +import Data.GMap + +import qualified Data.Monoid as M (Monoid(..)) +import qualified Data.Foldable as F (Foldable(..)) +import Data.Bits(shiftR,(.&.)) +import Data.Typeable +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L +import qualified Data.Maybe as MB +import Control.Monad(foldM) + +import GHC.Base hiding (map) +import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault) + +-- | Type synonym used to distinguish a key Int# from other Int#. +-- (BTW, the Haddock lies. This synonym is not exported. +-- This is only used in the haddock to distinguish Ints that are Keys from Ints used for other purposes.) +type Key = Int# + +-- This is basically the same as AVL (from Data.Tree.AVL package) but with an +-- extra Int field (which is unboxed for ghc). +-- | The GT type for 'Int' keys. +data IntMap a = E -- ^ Empty IntMap + | N {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=-1 (right height > left height) + | Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF= 0 + | P {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=+1 (left height > right height) + +instance Map IntMap Int where +-- fromAssocsWith +-- fromAssocsMaybe + empty = emptyIntMap + nonEmpty = nonEmptyIntMap + status = statusIntMap + addSize = addSizeIntMap + union = unionIntMap + union' = unionIntMap' + unionMaybe = unionMaybeIntMap + disjointUnion = disjointUnionIntMap + intersection = intersectionIntMap + intersection' = intersectionIntMap' + intersectionMaybe = intersectionMaybeIntMap + difference = differenceIntMap + differenceMaybe = differenceMaybeIntMap + isSubsetOf = isSubsetOfIntMap + isSubmapOf = isSubmapOfIntMap + map = mapIntMap + map' = mapIntMap' + mapMaybe = mapMaybeIntMap + mapWithKey f imp = mapWithKeyIntMap (\i a -> f (I# (i)) a) imp + mapWithKey' f imp = mapWithKeyIntMap' (\i a -> f (I# (i)) a) imp + filter = filterIntMap + foldKeys f imp b0 = foldKeysAscIntMap (\i b -> f (I# (i)) b) imp b0 + foldAssocs f imp b0 = foldAssocsAscIntMap (\i a b -> f (I# (i)) a b) imp b0 + foldElems = foldElemsAscIntMap + foldElems' = foldElemsAscIntMap' + foldKeys' f imp b0 = foldKeysAscIntMap' (\i b -> f (I# (i)) b) imp b0 + foldAssocs' f imp b0 = foldAssocsAscIntMap' (\i a b -> f (I# (i)) a b) imp b0 + foldElemsUInt = foldElemsUIntIntMap + valid = validIntMap + singleton (I# (i)) a = singletonIntMap i a + pair (I# (i0)) (I# (i1)) = pairIntMap i0 i1 + lookup (I# (i)) imp = lookupIntMap i imp + lookupCont f (I# (i)) imp = lookupContIntMap f i imp + alter f (I# (i)) imp = alterIntMap f i imp + insertWith f (I# (i)) a imp = insertWithIntMap f i a imp + insertWith' f (I# (i)) a imp = insertWithIntMap' f i a imp + insertMaybe f (I# (i)) a imp = insertMaybeIntMap f i a imp + delete (I# (i)) imp = deleteIntMap i imp + adjustWith f (I# (i)) imp = adjustWithIntMap f i imp + adjustWith' f (I# (i)) imp = adjustWithIntMap' f i imp + adjustMaybe f (I# (i)) imp = adjustMaybeIntMap f i imp + venn = vennIntMap + venn' = vennIntMap' + vennMaybe = vennMaybeIntMap + +instance OrderedMap IntMap Int where + compareKey = compareKeyIntMap + fromAssocsAscWith = fromAssocsAscWithIntMap + fromAssocsDescWith = fromAssocsDescWithIntMap + fromAssocsAscMaybe = fromAssocsAscMaybeIntMap + fromAssocsDescMaybe = fromAssocsDescMaybeIntMap + foldKeysAsc f imp b0 = foldKeysAscIntMap (\i b -> f (I# (i)) b) imp b0 + foldKeysDesc f imp b0 = foldKeysDescIntMap (\i b -> f (I# (i)) b) imp b0 + foldAssocsAsc f imp b0 = foldAssocsAscIntMap (\i a b -> f (I# (i)) a b) imp b0 + foldAssocsDesc f imp b0 = foldAssocsDescIntMap (\i a b -> f (I# (i)) a b) imp b0 + foldElemsAsc = foldElemsAscIntMap + foldElemsDesc = foldElemsDescIntMap + foldElemsAsc' = foldElemsAscIntMap' + foldElemsDesc' = foldElemsDescIntMap' + foldKeysAsc' f imp b0 = foldKeysAscIntMap' (\i b -> f (I# (i)) b) imp b0 + foldKeysDesc' f imp b0 = foldKeysDescIntMap' (\i b -> f (I# (i)) b) imp b0 + foldAssocsAsc' f imp b0 = foldAssocsAscIntMap' (\i a b -> f (I# (i)) a b) imp b0 + foldAssocsDesc' f imp b0 = foldAssocsDescIntMap' (\i a b -> f (I# (i)) a b) imp b0 + +-- Local module error prefix +mErr :: String +mErr = "Data.Trie.General.IntMap.Set-" + +-- | See 'Map' class method 'empty'. +emptyIntMap :: IntMap a +emptyIntMap = E +{-# INLINE emptyIntMap #-} + +-- | See 'Map' class method 'singleton'. +singletonIntMap :: Key -> a -> IntMap a +singletonIntMap i a = Z i E a E +{-# INLINE singletonIntMap #-} + +-- !!! This might cause problems where the list and the map cant both fit into memory at the same time. Dont use length. +fromAssocsAscIntMap :: [(Int,a)] -> IntMap a +fromAssocsAscIntMap ias = fromAssocsAscLIntMap (length ias) ias +{-# INLINE fromAssocsAscIntMap #-} + +fromAssocsDescIntMap :: [(Int,a)] -> IntMap a +fromAssocsDescIntMap ias = fromAssocsDescLIntMap (length ias) ias +{-# INLINE fromAssocsDescIntMap #-} + +fromAssocsAscLIntMap :: Int -> [(Int,a)] -> IntMap a +fromAssocsAscLIntMap n ias = case suba (rep n) ias of + (# imp,[] #) -> imp + (# _,_ #) -> error (mErr ++ "fromAssocsAscLIntMap: List too long.") + where + suba ET as = (# E,as #) + suba (NT l r) as = suba_ N l r as + suba (ZT l r) as = suba_ Z l r as + suba (PT l r) as = suba_ P l r as + {-# INLINE suba_ #-} + suba_ c l r as = case suba l as of + (# l_,as_ #) -> case as_ of + (((I# (ka),a):as__)) -> case suba r as__ of + (# r_,as___ #) -> let t = c ka l_ a r_ + in t `seq` (# t,as___ #) + [] -> error (mErr ++ "fromAssocsAscLIntMap: List too short.") + +fromAssocsDescLIntMap :: Int -> [(Int,a)] -> IntMap a +fromAssocsDescLIntMap n ias = case subd (rep n) ias of + (# imp,[] #) -> imp + (# _,_ #) -> error (mErr ++ "fromAssocsDescLIntMap: List too long.") + where + subd ET as = (# E,as #) + subd (NT l r) as = subd_ N l r as + subd (ZT l r) as = subd_ Z l r as + subd (PT l r) as = subd_ P l r as + {-# INLINE subd_ #-} + subd_ c l r as = case subd r as of + (# r_,as_ #) -> case as_ of + (((I# (ka),a):as__)) -> case subd l as__ of + (# l_,as___ #) -> let t = c ka l_ a r_ + in t `seq` (# t,as___ #) + [] -> error (mErr ++ "fromAssocsDescLIntMap: List too short.") + +-- Group an ordered list of assocs by key +clump :: Eq k => [(k,a)] -> [(k,[a])] +clump [] = [] +clump kas = list' [(k',as' [])] + where (k',as',list') = L.foldl' combine (fst $ head kas,id,id) kas + -- 'as' and 'list' are list building continuations - so order of 'kas' is preserved + combine (k1,as,list) (k2,a) = + if k1 == k2 + then (k1, as . (a:), list ) + else (k2, (a:), list . ((k1,as []):) ) + +fromAssocsAscWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a +fromAssocsAscWithIntMap f kas = fromAssocsAscIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas] + +fromAssocsDescWithIntMap :: (a -> a -> a) -> [(Int,a)] -> IntMap a +fromAssocsDescWithIntMap f kas = fromAssocsDescIntMap [ (k,L.foldl1' f as) | (k,as) <- clump kas] + +fromAssocsAscMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a +fromAssocsAscMaybeIntMap f kas = fromAssocsAscIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas] + where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) + +fromAssocsDescMaybeIntMap :: (a -> a -> Maybe a) -> [(Int,a)] -> IntMap a +fromAssocsDescMaybeIntMap f kas = fromAssocsDescIntMap $ MB.catMaybes [ fld k as | (k,as) <- clump kas] + where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) + +-- | See 'Map' class method 'pair'. +pairIntMap :: Key -> Key -> Maybe (a -> a -> IntMap a) +pairIntMap i0 i1 = case compareInt# i0 i1 of + LT -> Just (\a0 a1 -> P i1 (Z i0 E a0 E) a1 E) + EQ -> Nothing + GT -> Just (\a0 a1 -> P i0 (Z i1 E a1 E) a0 E) + +-- | See 'Map' class method 'nonEmpty'. +nonEmptyIntMap :: IntMap a -> Maybe (IntMap a) +nonEmptyIntMap E = Nothing +nonEmptyIntMap imp = Just imp + +-- | See 'Map' class method 'status'. +statusIntMap :: IntMap a -> Status Int a +statusIntMap E = None +statusIntMap (Z i E a _) = One (I# (i)) a +statusIntMap _ = Many + +{----------------------------------------- +Notes for fast size calculation. + case (h,avl) + (0,_ ) -> 0 -- Must be E + (1,_ ) -> 1 -- Must be (Z E _ E ) + (2,N _ _ _) -> 2 -- Must be (N E _ (Z E _ E)) + (2,Z _ _ _) -> 3 -- Must be (Z (Z E _ E) _ (Z E _ E)) + (2,P _ _ _) -> 2 -- Must be (P (Z E _ E) _ E ) + (3,N _ _ r) -> 2 + size 2 r -- Must be (N (Z E _ E) _ r ) + (3,P l _ _) -> 2 + size 2 l -- Must be (P l _ (Z E _ E)) +------------------------------------------} + +-- | See 'Map' class method 'addSize'. +addSizeIntMap :: IntMap a -> Int# -> Int# +addSizeIntMap E n = n +addSizeIntMap (N _ l _ r) n = case addHeight 2# l of + 2# -> ((n)+#2#) + h -> fasN n h l r +addSizeIntMap (Z _ l _ r) n = case addHeight 1# l of + 1# -> ((n)+#1#) + 2# -> ((n)+#3#) + h -> fasZ n h l r +addSizeIntMap (P _ l _ r) n = case addHeight 2# r of + 2# -> ((n)+#2#) + h -> fasP n h l r + +-- Local utilities used by addSizeIntMap, Only work if h >=3 !! +fasN,fasZ,fasP :: Int# -> Int# -> IntMap e -> IntMap e -> Int# +fasN n 3# _ r = fas ((n)+#2#) 2# r +fasN n h l r = fas (fas ((n)+#1#) ((h)-#2#) l) ((h)-#1#) r -- h>=4 +fasZ n h l r = fas (fas ((n)+#1#) ((h)-#1#) l) ((h)-#1#) r +fasP n 3# l _ = fas ((n)+#2#) 2# l +fasP n h l r = fas (fas ((n)+#1#) ((h)-#2#) r) ((h)-#1#) l -- h>=4 + +-- Local Utility used by fasN,fasZ,fasP, Only works if h >= 2 !! +fas :: Int# -> Int# -> IntMap e -> Int# +fas _ 2# E = error "fas: Bug0" +fas n 2# (N _ _ _ _) = ((n)+#2#) +fas n 2# (Z _ _ _ _) = ((n)+#3#) +fas n 2# (P _ _ _ _) = ((n)+#2#) +-- So h must be >= 3 if we get here +fas n h (N _ l _ r) = fasN n h l r +fas n h (Z _ l _ r) = fasZ n h l r +fas n h (P _ l _ r) = fasP n h l r +fas _ _ E = error "fas: Bug1" +----------------------------------------------------------------------- +------------------------ addSizeIntMap Ends Here ----------------------- +----------------------------------------------------------------------- + + +-- | Adds the height of a tree to the first argument. +-- +-- Complexity: O(log n) +addHeight :: Int# -> IntMap e -> Int# +addHeight h E = h +addHeight h (N _ l _ _) = addHeight ((h)+#2#) l +addHeight h (Z _ l _ _) = addHeight ((h)+#1#) l +addHeight h (P _ _ _ r) = addHeight ((h)+#2#) r + +-- | See 'Map' class method 'lookup'. +lookupIntMap :: Key -> IntMap a -> Maybe a +lookupIntMap i0 t = rd t where + rd E = Nothing + rd (N i l a r) = rd_ i l a r + rd (Z i l a r) = rd_ i l a r + rd (P i l a r) = rd_ i l a r + rd_ i l a r = case compareInt# i0 i of + LT -> rd l + EQ -> Just a + GT -> rd r + +-- | See 'Map' class method 'lookupCont'. +lookupContIntMap :: (a -> Maybe b) -> Key -> IntMap a -> Maybe b +lookupContIntMap f i0 t = rd t where + rd E = Nothing + rd (N i l a r) = rd_ i l a r + rd (Z i l a r) = rd_ i l a r + rd (P i l a r) = rd_ i l a r + rd_ i l a r = case compareInt# i0 i of + LT -> rd l + EQ -> f a + GT -> rd r + +-- | Determine if the supplied key is present in the IntMap. +hasKeyIntMap :: IntMap a -> Key -> Bool +hasKeyIntMap t i0 = rd t where + rd E = False + rd (N i l _ r) = rd_ i l r + rd (Z i l _ r) = rd_ i l r + rd (P i l _ r) = rd_ i l r + rd_ i l r = case compareInt# i0 i of + LT -> rd l + EQ -> True + GT -> rd r + +-- | Overwrite an existing association pair. This function does not force evaluation of the new associated +-- value. An error is raised if the IntMap does not already contain an entry for the Key. +-- +-- Complexity: O(log n) +assertWriteIntMap :: Key -> a -> IntMap a -> IntMap a +assertWriteIntMap i0 a0 = w where + w E = error "assertWrite: Key not found." + w (N i l a r) = case compareInt# i0 i of + LT -> let l' = w l in l' `seq` N i l' a r + EQ -> N i0 l a0 r + GT -> let r' = w r in r' `seq` N i l a r' + w (Z i l a r) = case compareInt# i0 i of + LT -> let l' = w l in l' `seq` Z i l' a r + EQ -> Z i0 l a0 r + GT -> let r' = w r in r' `seq` Z i l a r' + w (P i l a r) = case compareInt# i0 i of + LT -> let l' = w l in l' `seq` P i l' a r + EQ -> P i0 l a0 r + GT -> let r' = w r in r' `seq` P i l a r' + +-- | See 'Map' class method 'alter'. +alterIntMap :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a +alterIntMap f i t = case lookupIntMap i t of + Nothing -> case f Nothing of + Nothing -> t + Just a -> ins i a t + ja -> case f ja of + Nothing -> del i t + Just a' -> assertWriteIntMap i a' t + +-- | See 'Map' class method 'insertMaybe'. +insertMaybeIntMap :: (a -> Maybe a) -> Key -> a -> IntMap a -> IntMap a +insertMaybeIntMap f i0 a0 t = case lookupIntMap i0 t of + Nothing -> ins i0 a0 t + Just a' -> case f a' of + Nothing -> del i0 t + Just a'' -> assertWriteIntMap i0 a'' t + +-- | See 'Map' class method 'delete'. +deleteIntMap :: Key -> IntMap a -> IntMap a +deleteIntMap i t = if t `hasKeyIntMap` i then del i t else t + +-- | See 'Map' class method 'adjust'. +adjustWithIntMap :: (a -> a) -> Key -> IntMap a -> IntMap a +adjustWithIntMap f i t = case lookupIntMap i t of + Nothing -> t + Just a -> assertWriteIntMap i (f a) t + +-- | See 'Map' class method 'adjust''. +adjustWithIntMap' :: (a -> a) -> Key -> IntMap a -> IntMap a +adjustWithIntMap' f i t = case lookupIntMap i t of + Nothing -> t + Just a -> let a' = f a in a' `seq` assertWriteIntMap i a' t + +-- | See 'Map' class method 'adjustMaybe'. +adjustMaybeIntMap :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a +adjustMaybeIntMap f i t = case lookupIntMap i t of + Nothing -> t + Just a -> case f a of + Nothing -> del i t + Just a' -> assertWriteIntMap i a' t + +-- | See 'Map' class method 'isSubsetOf'. +isSubsetOfIntMap :: IntMap a -> IntMap b -> Bool +isSubsetOfIntMap = s where + -- s :: IntMap a -> IntMap b -> Bool + s E _ = True + s _ E = False + s (N ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb + s (N ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb + s (N ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb + s (Z ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb + s (Z ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb + s (Z ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb + s (P ka la _ ra) (N kb lb _ rb) = s' ka la ra kb lb rb + s (P ka la _ ra) (Z kb lb _ rb) = s' ka la ra kb lb rb + s (P ka la _ ra) (P kb lb _ rb) = s' ka la ra kb lb rb + s' ka la ra kb lb rb = + case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case forkL ka lb of + (# False,_ ,_,_ ,_ #) -> False + (# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb of -- (llb < ka < kb) & (ka < lrb < kb) + (# rla,_,rra,_ #) -> (s rla lrb) && (s rra rb) -- (ka < rla < kb) & (ka < kb < rra) + -- ka = kb + EQ -> (s la lb) && (s ra rb) + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case forkL ka rb of + (# False,_ ,_,_ ,_ #) -> False + (# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb of -- (kb < rlb < ka) & (kb < ka < rrb) + (# lla,_,lra,_ #) -> (s lra rlb) && (s lla lb) -- (lla < kb < ka) & (kb < lra < ka) + -- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b) + -- forkL :: Key -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True! + forkL ka tb = forkL_ tb 0# where + forkL_ E h = (# False,E,h,E,h #) + forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#) + forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#) + forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#) + forkL__ k l hl b r hr = case compareInt# ka k of + LT -> case forkL_ l hl of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of + (# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #) + EQ -> (# True,l,hl,r,hr #) + GT -> case forkL_ r hr of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of + (# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #) + -- forkR discards an element from set a if it is equal to the element from set b + -- forkR :: IntMap a -> Key -> (# IntMap a,Int#,IntMap a,Int# #) + forkR ta kb = forkR_ ta 0# where + forkR_ E h = (# E,h,E,h #) -- Relative heights!! + forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#) + forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#) + forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#) + forkR__ k l hl a r hr = case compareInt# k kb of + LT -> case forkR_ r hr of + (# t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of + (# t0_,ht0_ #) -> (# t0_,ht0_,t1,ht1 #) + EQ -> (# l,hl,r,hr #) -- e is discarded from set a + GT -> case forkR_ l hl of + (# t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of + (# t1_,ht1_ #) -> (# t0,ht0,t1_,ht1_ #) +----------------------------------------------------------------------- +----------------------- isSubsetOfIntMap Ends Here --------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'isSubmapOf'. +isSubmapOfIntMap :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool +isSubmapOfIntMap p = s where + -- s :: IntMap a -> IntMap b -> Bool + s E _ = True + s _ E = False + s (N ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb + s (N ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb + s (N ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb + s (Z ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb + s (Z ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb + s (Z ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb + s (P ka la a ra) (N kb lb b rb) = s' ka la a ra kb lb b rb + s (P ka la a ra) (Z kb lb b rb) = s' ka la a ra kb lb b rb + s (P ka la a ra) (P kb lb b rb) = s' ka la a ra kb lb b rb + s' ka la a ra kb lb b rb = + case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case forkL ka a lb of + (# False,_ ,_,_ ,_ #) -> False + (# True ,llb,_,lrb,_ #) -> (s la llb) && case forkR ra kb b of -- (llb < ka < kb) & (ka < lrb < kb) + (# False,_ ,_,_ ,_ #) -> False + (# True ,rla,_,rra,_ #) -> (s rla lrb) && (s rra rb) -- (ka < rla < kb) & (ka < kb < rra) + -- ka = kb + EQ -> (p a b) && (s la lb) && (s ra rb) + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case forkL ka a rb of + (# False,_ ,_,_ ,_ #) -> False + (# True ,rlb,_,rrb,_ #) -> (s ra rrb) && case forkR la kb b of -- (kb < rlb < ka) & (kb < ka < rrb) + (# False,_ ,_,_ ,_ #) -> False + (# True, lla,_,lra,_ #) -> (s lra rlb) && (s lla lb) -- (lla < kb < ka) & (kb < lra < ka) + -- forkL returns False if tb does not contain ka (which implies set a cannot be a subset of set b) + -- forkL :: Key -> a -> IntMap b -> (# Bool,IntMap b,Int#,IntMap b,Int# #) -- Vals b..4 only valid if Bool is True! + forkL ka a tb = forkL_ tb 0# where + forkL_ E h = (# False,E,h,E,h #) + forkL_ (N k l b r) h = forkL__ k l ((h)-#2#) b r ((h)-#1#) + forkL_ (Z k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#1#) + forkL_ (P k l b r) h = forkL__ k l ((h)-#1#) b r ((h)-#2#) + forkL__ k l hl b r hr = case compareInt# ka k of + LT -> case forkL_ l hl of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 b r hr of + (# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #) + EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #) + GT -> case forkL_ r hr of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl b t0 ht0 of + (# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #) + -- forkR discards an element from set a if it is equal to the element from set b + -- forkR :: IntMap a -> Key -> b -> (# Bool,IntMap a,Int#,IntMap a,Int# #) + forkR ta kb b = forkR_ ta 0# where + forkR_ E h = (# True,E,h,E,h #) -- Relative heights!! + forkR_ (N k l a r) h = forkR__ k l ((h)-#2#) a r ((h)-#1#) + forkR_ (Z k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#1#) + forkR_ (P k l a r) h = forkR__ k l ((h)-#1#) a r ((h)-#2#) + forkR__ k l hl a r hr = case compareInt# k kb of + LT -> case forkR_ r hr of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k l hl a t0 ht0 of + (# t0_,ht0_ #) -> (# True,t0_,ht0_,t1,ht1 #) + EQ -> let bool = p a b in bool `seq` (# bool,l,hl,r,hr #) -- e is discarded from set a + GT -> case forkR_ l hl of + (# False,t0,ht0,t1,ht1 #) -> (# False,t0,ht0,t1,ht1 #) + (# True ,t0,ht0,t1,ht1 #) -> case spliceH k t1 ht1 a r hr of + (# t1_,ht1_ #) -> (# True,t0,ht0,t1_,ht1_ #) +----------------------------------------------------------------------- +----------------------- isSubmapOfIntMap Ends Here --------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'map'. +mapIntMap :: (a -> b) -> IntMap a -> IntMap b +mapIntMap f = mapit where + mapit E = E + mapit (N i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` N i l_ (f a) r_ + mapit (Z i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` Z i l_ (f a) r_ + mapit (P i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` P i l_ (f a) r_ + +-- | See 'Map' class method 'map''. +mapIntMap' :: (a -> b) -> IntMap a -> IntMap b +mapIntMap' f = mapit where + mapit E = E + mapit (N i l a r) = let l_ = mapit l + r_ = mapit r + b = f a + in b `seq` l_ `seq` r_ `seq` N i l_ b r_ + mapit (Z i l a r) = let l_ = mapit l + r_ = mapit r + b = f a + in b `seq` l_ `seq` r_ `seq` Z i l_ b r_ + mapit (P i l a r) = let l_ = mapit l + r_ = mapit r + b = f a + in b `seq` l_ `seq` r_ `seq` P i l_ b r_ + +-- | See 'Map' class method 'mapMaybe'. +mapMaybeIntMap :: (a -> Maybe b) -> IntMap a -> IntMap b +mapMaybeIntMap f t0 = case mapMaybe_ 0# t0 of (# t_,_ #) -> t_ -- Work with relative heights!! + where mapMaybe_ h t = case t of + E -> (# E,h #) + N i l a r -> m i l ((h)-#2#) a r ((h)-#1#) + Z i l a r -> m i l ((h)-#1#) a r ((h)-#1#) + P i l a r -> m i l ((h)-#1#) a r ((h)-#2#) + where m i l hl a r hr = case mapMaybe_ hl l of + (# l_,hl_ #) -> case mapMaybe_ hr r of + (# r_,hr_ #) -> case f a of + Just b -> spliceH i l_ hl_ b r_ hr_ + Nothing -> joinH l_ hl_ r_ hr_ + +-- | See 'Map' class method 'mapWithKey'. +mapWithKeyIntMap :: (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKeyIntMap f = mapit where + mapit E = E + mapit (N i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` N i l_ (f i a) r_ + mapit (Z i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` Z i l_ (f i a) r_ + mapit (P i l a r) = let l_ = mapit l + r_ = mapit r + in l_ `seq` r_ `seq` P i l_ (f i a) r_ + +-- | See 'Map' class method 'mapWithKey''. +mapWithKeyIntMap' :: (Key -> a -> b) -> IntMap a -> IntMap b +mapWithKeyIntMap' f = mapit where + mapit E = E + mapit (N i l a r) = let l_ = mapit l + r_ = mapit r + b = f i a + in b `seq` l_ `seq` r_ `seq` N i l_ b r_ + mapit (Z i l a r) = let l_ = mapit l + r_ = mapit r + b = f i a + in b `seq` l_ `seq` r_ `seq` Z i l_ b r_ + mapit (P i l a r) = let l_ = mapit l + r_ = mapit r + b = f i a + in b `seq` l_ `seq` r_ `seq` P i l_ b r_ + +-- | See 'Map' class method 'filter'. +filterIntMap :: (a -> Bool) -> IntMap a -> IntMap a +filterIntMap p t0 = case filter_ 0# t0 of (# _,t_,_ #) -> t_ -- Work with relative heights!! + where filter_ h t = case t of + E -> (# False,E,h #) + N i l e r -> f i l ((h)-#2#) e r ((h)-#1#) + Z i l e r -> f i l ((h)-#1#) e r ((h)-#1#) + P i l e r -> f i l ((h)-#1#) e r ((h)-#2#) + where f i l hl e r hr = case filter_ hl l of + (# bl,l_,hl_ #) -> case filter_ hr r of + (# br,r_,hr_ #) -> if p e + then if bl || br + then case spliceH i l_ hl_ e r_ hr_ of + (# t_,h_ #) -> (# True,t_,h_ #) + else (# False,t,h #) + else case joinH l_ hl_ r_ hr_ of + (# t_,h_ #) -> (# True,t_,h_ #) + +-- | See 'Map' class method 'foldElemsAsc'. +foldElemsAscIntMap :: (a -> b -> b) -> b -> IntMap a -> b +foldElemsAscIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N _ l a r) b = foldV l a r b + foldU (Z _ l a r) b = foldV l a r b + foldU (P _ l a r) b = foldV l a r b + foldV l a r b = foldU l (f a (foldU r b)) + +-- | See 'Map' class method 'foldElemsDesc'. +foldElemsDescIntMap :: (a -> b -> b) -> b -> IntMap a -> b +foldElemsDescIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N _ l a r) b = foldV l a r b + foldU (Z _ l a r) b = foldV l a r b + foldU (P _ l a r) b = foldV l a r b + foldV l a r b = foldU r (f a (foldU l b)) + +-- | See 'Map' class method 'foldKeysAsc'. +foldKeysAscIntMap :: (Key -> b -> b) -> b -> IntMap a -> b +foldKeysAscIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l _ r) b = foldV k l r b + foldU (Z k l _ r) b = foldV k l r b + foldU (P k l _ r) b = foldV k l r b + foldV k l r b = foldU l (f k (foldU r b)) + +-- | See 'Map' class method 'foldKeysDesc'. +foldKeysDescIntMap :: (Key -> b -> b) -> b -> IntMap a -> b +foldKeysDescIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l _ r) b = foldV k l r b + foldU (Z k l _ r) b = foldV k l r b + foldU (P k l _ r) b = foldV k l r b + foldV k l r b = foldU r (f k (foldU l b)) + +-- | See 'Map' class method 'foldAssocsAsc'. +foldAssocsAscIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldAssocsAscIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l a r) b = foldV k l a r b + foldU (Z k l a r) b = foldV k l a r b + foldU (P k l a r) b = foldV k l a r b + foldV k l a r b = foldU l (f k a (foldU r b)) + +-- | See 'Map' class method 'foldAssocsDesc'. +foldAssocsDescIntMap :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldAssocsDescIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l a r) b = foldV k l a r b + foldU (Z k l a r) b = foldV k l a r b + foldU (P k l a r) b = foldV k l a r b + foldV k l a r b = foldU r (f k a (foldU l b)) + +-- | See 'Map' class method 'foldElemsAsc''. +foldElemsAscIntMap' :: (a -> b -> b) -> b -> IntMap a -> b +foldElemsAscIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N _ l a r) b = foldV l a r b + foldU (Z _ l a r) b = foldV l a r b + foldU (P _ l a r) b = foldV l a r b + foldV l a r b = let b' = foldU r b + b'' = f a b' + in b' `seq` b'' `seq` foldU l b'' + +-- | See 'Map' class method 'foldElemsDesc''. +foldElemsDescIntMap' :: (a -> b -> b) -> b -> IntMap a -> b +foldElemsDescIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N _ l a r) b = foldV l a r b + foldU (Z _ l a r) b = foldV l a r b + foldU (P _ l a r) b = foldV l a r b + foldV l a r b = let b' = foldU l b + b'' = f a b' + in b' `seq` b'' `seq` foldU r b'' + +-- | See 'Map' class method 'foldKeysAsc''. +foldKeysAscIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b +foldKeysAscIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l _ r) b = foldV k l r b + foldU (Z k l _ r) b = foldV k l r b + foldU (P k l _ r) b = foldV k l r b + foldV k l r b = let b' = foldU r b + b'' = f k b' + in b' `seq` b'' `seq` foldU l b'' + +-- | See 'Map' class method 'foldKeysDesc''. +foldKeysDescIntMap' :: (Key -> b -> b) -> b -> IntMap a -> b +foldKeysDescIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l _ r) b = foldV k l r b + foldU (Z k l _ r) b = foldV k l r b + foldU (P k l _ r) b = foldV k l r b + foldV k l r b = let b' = foldU l b + b'' = f k b' + in b' `seq` b'' `seq` foldU r b'' + +-- | See 'Map' class method 'foldAssocsAsc''. +foldAssocsAscIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldAssocsAscIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l a r) b = foldV k l a r b + foldU (Z k l a r) b = foldV k l a r b + foldU (P k l a r) b = foldV k l a r b + foldV k l a r b = let b' = foldU r b + b'' = f k a b' + in b' `seq` b'' `seq` foldU l b'' + +-- | See 'Map' class method 'foldAssocsDesc''. +foldAssocsDescIntMap' :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldAssocsDescIntMap' f bb mp = foldU mp bb where + foldU E b = b + foldU (N k l a r) b = foldV k l a r b + foldU (Z k l a r) b = foldV k l a r b + foldU (P k l a r) b = foldV k l a r b + foldV k l a r b = let b' = foldU l b + b'' = f k a b' + in b' `seq` b'' `seq` foldU r b'' + +-- | See 'Map' class method 'foldElemsUInt'. +foldElemsUIntIntMap :: (a -> Int# -> Int#) -> Int# -> IntMap a -> Int# +foldElemsUIntIntMap f bb mp = foldU mp bb where + foldU E b = b + foldU (N _ l a r) b = foldV l a r b + foldU (Z _ l a r) b = foldV l a r b + foldU (P _ l a r) b = foldV l a r b + foldV l a r b = foldU l (f a (foldU r b)) + +-- | See 'Map' class method 'valid'. +validIntMap :: IntMap a -> Maybe String +validIntMap imp = if (isBalanced imp) then if (isSorted imp) then Nothing + else Just "IntMap: Tree is not sorted." + else Just "IntMap: Tree is not balanced." + +-- | Verify that an IntMap (tree) is height balanced and that the BF of each node is correct. +-- +-- Complexity: O(n) +isBalanced :: IntMap a -> Bool +isBalanced t = not (cH t ==# -1#) + +-- Local utility, returns height if balanced, -1 if not +cH :: IntMap a -> Int# +cH E = 0# +cH (N _ l _ r) = cH_ 1# l r -- (hr-hl) = 1 +cH (Z _ l _ r) = cH_ 0# l r -- (hr-hl) = 0 +cH (P _ l _ r) = cH_ 1# r l -- (hl-hr) = 1 +cH_ :: Int# -> IntMap a -> IntMap a -> Int# +cH_ delta l r = let hl = cH l + in if hl ==# -1# then hl + else let hr = cH r + in if hr ==# -1# then hr + else if ((hr)-#(hl)) ==# delta then ((hr)+#1#) + else -1# + +-- | Verify that an IntMap (tree) is sorted. +-- +-- Complexity: O(n) +isSorted :: IntMap a -> Bool +isSorted E = True +isSorted (N i l _ r) = isSorted_ i l r +isSorted (Z i l _ r) = isSorted_ i l r +isSorted (P i l _ r) = isSorted_ i l r +isSorted_ :: Int# -> IntMap a -> IntMap a -> Bool +isSorted_ i l r = (isSortedU l i) && (isSortedL i r) +-- Verify tree is sorted and rightmost element is less than an upper limit (ul) +isSortedU :: IntMap a -> Int# -> Bool +isSortedU E _ = True +isSortedU (N i l _ r) ul = isSortedU_ i l r ul +isSortedU (Z i l _ r) ul = isSortedU_ i l r ul +isSortedU (P i l _ r) ul = isSortedU_ i l r ul +isSortedU_ :: Int# -> IntMap a -> IntMap a -> Int# -> Bool +isSortedU_ i l r ul = case compareInt# i ul of + LT -> (isSortedU l i) && (isSortedLU i r ul) + _ -> False +-- Verify tree is sorted and leftmost element is greater than a lower limit (ll) +isSortedL :: Int# -> IntMap a -> Bool +isSortedL _ E = True +isSortedL ll (N i l _ r) = isSortedL_ ll i l r +isSortedL ll (Z i l _ r) = isSortedL_ ll i l r +isSortedL ll (P i l _ r) = isSortedL_ ll i l r +isSortedL_ :: Int# -> Int# -> IntMap a -> IntMap a -> Bool +isSortedL_ ll i l r = case compareInt# i ll of + GT -> (isSortedLU ll l i) && (isSortedL i r) + _ -> False +-- Verify tree is sorted and leftmost element is greater than a lower limit (ll) +-- and rightmost element is less than an upper limit (ul) +isSortedLU :: Int# -> IntMap a -> Int# -> Bool +isSortedLU _ E _ = True +isSortedLU ll (N i l _ r) ul = isSortedLU_ ll i l r ul +isSortedLU ll (Z i l _ r) ul = isSortedLU_ ll i l r ul +isSortedLU ll (P i l _ r) ul = isSortedLU_ ll i l r ul +isSortedLU_ :: Int# -> Int# -> IntMap a -> IntMap a -> Int# -> Bool +isSortedLU_ ll i l r ul = case compareInt# i ll of + GT -> case compareInt# i ul of + LT -> (isSortedLU ll l i) && (isSortedLU i r ul) + _ -> False + _ -> False +-- isSorted ends -- +------------------- + +-- | See 'Map' class method compareKey +compareKeyIntMap :: IntMap a -> Int -> Int -> Ordering +compareKeyIntMap _ = compare + +urk :: String +urk = "Urk .. Bug in IntMap!" + +-- | See 'Map' class method 'insert'. +insertWithIntMap :: (a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithIntMap _ k0 a0 E = Z k0 E a0 E +insertWithIntMap f k0 a0 (N k l a r) = putN f k0 a0 k l a r +insertWithIntMap f k0 a0 (Z k l a r) = putZ f k0 a0 k l a r +insertWithIntMap f k0 a0 (P k l a r) = putP f k0 a0 k l a r + +-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and +-- returns the updated (relative) tree height. +pushH :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #) +pushH _ k0 a0 h E = (# Z k0 E a0 E, ((h)+#1#) #) +pushH f k0 a0 h (N k l a r) = let t_ = putN f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change +pushH f k0 a0 h (Z k l a r) = let t_ = putZ f k0 a0 k l a r in + case t_ of + E -> error urk -- impossible + Z _ _ _ _ -> (# t_, h #) + _ -> (# t_,((h)+#1#) #) +pushH f k0 a0 h (P k l a r) = let t_ = putP f k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change + +----------------------------- LEVEL 1 --------------------------------- +-- putN, putZ, putP -- +----------------------------------------------------------------------- + +-- Put in (N k l a r), BF=-1 , (never returns P) +putN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putN f k0 a0 k l a r = case compareInt# k0 k of + LT -> putNL f k0 a0 k l a r + EQ -> let a' = f a in N k0 l a' r + GT -> putNR f k0 a0 k l a r + +-- Put in (Z k l a r), BF= 0 +putZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putZ f k0 a0 k l a r = case compareInt# k0 k of + LT -> putZL f k0 a0 k l a r + EQ -> let a' = f a in Z k0 l a' r + GT -> putZR f k0 a0 k l a r + +-- Put in (P k l a r), BF=+1 , (never returns N) +putP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putP f k0 a0 k l a r = case compareInt# k0 k of + LT -> putPL f k0 a0 k l a r + EQ -> let a' = f a in P k0 l a' r + GT -> putPR f k0 a0 k l a r + +----------------------------- LEVEL 2 --------------------------------- +-- putNL, putZL, putPL -- +-- putNR, putZR, putPR -- +----------------------------------------------------------------------- + +-- (putNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P) +{-# INLINE putNL #-} +putNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putNL _ k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0 +putNL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +putNL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +putNL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + +-- (putZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N) +{-# INLINE putZL #-} +putZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putZL _ k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1 +putZL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +putZL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +putZL f k0 a0 k (Z lk ll la lr) a r = let l' = putZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + +-- (putZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P) +{-# INLINE putZR #-} +putZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putZR _ k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1 +putZR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +putZR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +putZR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + +-- (putPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N) +{-# INLINE putPR #-} +putPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putPR _ k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 +putPR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +putPR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +putPR f k0 a0 k l a (Z rk rl ra rr) = let r' = putZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + +-- (putNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P) +{-# INLINE putNR #-} +putNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1 +putNR f k0 a0 k l a (N rk rl ra rr) = let r' = putN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +putNR f k0 a0 k l a (P rk rl ra rr) = let r' = putP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +putNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL + LT -> putNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P) + EQ -> let ra' = f ra in N k l a (Z k0 rl ra' rr) -- new ra + GT -> putNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P) + +-- (putPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N) +{-# INLINE putPL #-} +putPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1 +putPL f k0 a0 k (N lk ll la lr) a r = let l' = putN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +putPL f k0 a0 k (P lk ll la lr) a r = let l' = putP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +putPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR + LT -> putPLL f k0 a0 k lk ll la lr a r -- LL (never returns N) + EQ -> let la' = f la in P k (Z k0 ll la' lr) a r -- new la + GT -> putPLR f k0 a0 k lk ll la lr a r -- LR (never returns N) + +----------------------------- LEVEL 3 --------------------------------- +-- putNRR, putPLL -- +-- putNRL, putPLR -- +----------------------------------------------------------------------- + +-- (putNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE putNRR #-} +putNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putNRR _ k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!! +putNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = putN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +putNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = putP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +putNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = putZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + +-- (putPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE putPLL #-} +putPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +putPLL _ k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!! +putPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = putN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +putPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = putP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +putPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = putZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + +-- (putNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE putNRL #-} +putNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +putNRL _ k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !! +putNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = putN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +putNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = putP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +putNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = putZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + +-- (putPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE putPLR #-} +putPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +putPLR _ k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !! +putPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = putN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +putPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = putP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +putPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = putZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +--------------------- insertWithIntMap/pushH Ends Here --------------------- +----------------------------------------------------------------------- + +----------------------------------------------------------------------- +--------------------- insertWithIntMap/pushH Ends Here --------------------- +----------------------------------------------------------------------- + +-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and +-- returns the updated (relative) tree height. +pushH' -- cpp madness + :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #) +pushH' _ k0 a0 h E = -- cpp madness + (# Z k0 E a0 E, ((h)+#1#) #) +pushH' f k0 a0 h (N k l a r) = let t_ = pputN f k0 a0 k l a r in t_ `seq` + (# t_,h #) -- Height can't change +pushH' f k0 a0 h (Z k l a r) = let t_ = pputZ f k0 a0 k l a r in + case t_ of + E -> error urk -- impossible + Z _ _ _ _ -> (# t_, h #) + _ -> (# t_,((h)+#1#) #) +pushH' f k0 a0 h (P k l a r) = let t_ = pputP f k0 a0 k l a r in t_ `seq` + (# t_,h #) -- Height can't change + +----------------------------- LEVEL 1 --------------------------------- +-- pputN, pputZ, pputP -- +----------------------------------------------------------------------- + +-- Put in (N k l a r), BF=-1 , (never returns P) +pputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputN f k0 a0 k l a r = case compareInt# k0 k of + LT -> pputNL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` N k0 l a' r + GT -> pputNR f k0 a0 k l a r + +-- Put in (Z k l a r), BF= 0 +pputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputZ f k0 a0 k l a r = case compareInt# k0 k of + LT -> pputZL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` Z k0 l a' r + GT -> pputZR f k0 a0 k l a r + +-- Put in (P k l a r), BF=+1 , (never returns N) +pputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputP f k0 a0 k l a r = case compareInt# k0 k of + LT -> pputPL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` P k0 l a' r + GT -> pputPR f k0 a0 k l a r + +----------------------------- LEVEL 2 --------------------------------- +-- pputNL, pputZL, pputPL -- +-- pputNR, pputZR, pputPR -- +----------------------------------------------------------------------- + +-- (pputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P) +{-# INLINE pputNL #-} +pputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputNL _ k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0 +pputNL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +pputNL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +pputNL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + +-- (pputZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N) +{-# INLINE pputZL #-} +pputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputZL _ k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1 +pputZL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +pputZL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +pputZL f k0 a0 k (Z lk ll la lr) a r = let l' = pputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + +-- (pputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P) +{-# INLINE pputZR #-} +pputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputZR _ k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1 +pputZR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +pputZR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +pputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + +-- (pputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N) +{-# INLINE pputPR #-} +pputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputPR _ k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 +pputPR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +pputPR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +pputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = pputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + +-- (pputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P) +{-# INLINE pputNR #-} +pputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1 +pputNR f k0 a0 k l a (N rk rl ra rr) = let r' = pputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +pputNR f k0 a0 k l a (P rk rl ra rr) = let r' = pputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +pputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL + LT -> pputNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P) + EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr) -- new ra + GT -> pputNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P) + +-- (pputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N) +{-# INLINE pputPL #-} +pputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1 +pputPL f k0 a0 k (N lk ll la lr) a r = let l' = pputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +pputPL f k0 a0 k (P lk ll la lr) a r = let l' = pputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +pputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR + LT -> pputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N) + EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la + GT -> pputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N) + +----------------------------- LEVEL 3 --------------------------------- +-- pputNRR, pputPLL -- +-- pputNRL, pputPLR -- +----------------------------------------------------------------------- + +-- (pputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE pputNRR #-} +pputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputNRR _ k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!! +pputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = pputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +pputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = pputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +pputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = pputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + +-- (pputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE pputPLL #-} +pputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +pputPLL _ k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!! +pputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = pputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +pputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = pputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +pputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = pputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + +-- (pputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE pputNRL #-} +pputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +pputNRL _ k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !! +pputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = pputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +pputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = pputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +pputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = pputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + +-- (pputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE pputPLR #-} +pputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +pputPLR _ k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !! +pputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = pputN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +pputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = pputP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +pputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = pputZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +-------------------- insertWithIntMap'/pushH' Ends Here -------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'insert'. +insertWithIntMap' -- cpp madness + :: (a -> a) -> Key -> a -> IntMap a -> IntMap a +insertWithIntMap' _ k0 a0 E = a0 `seq` Z k0 E a0 E +insertWithIntMap' f k0 a0 (N k l a r) = ppputN f k0 a0 k l a r +insertWithIntMap' f k0 a0 (Z k l a r) = ppputZ f k0 a0 k l a r +insertWithIntMap' f k0 a0 (P k l a r) = ppputP f k0 a0 k l a r + +{- Not used currently - +-- | Same as 'insertWithIntMap', but takes the (relative) tree height as an extra argument and +-- returns the updated (relative) tree height. +pushH'' -- cpp madness + :: (a -> a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #) +pushH'' _ k0 a0 h E = -- cpp madness + a0 `seq` (# Z k0 E a0 E, ((h)+#1#) #) +pushH'' f k0 a0 h (N k l a r) = let t_ = ppputN f k0 a0 k l a r in t_ `seq` + (# t_,h #) -- Height can't change +pushH'' f k0 a0 h (Z k l a r) = let t_ = ppputZ f k0 a0 k l a r in + case t_ of + E -> error urk -- impossible + Z _ _ _ _ -> (# t_, h #) + _ -> (# t_,((h)+#1#) #) +pushH'' f k0 a0 h (P k l a r) = let t_ = ppputP f k0 a0 k l a r in t_ `seq` + (# t_,h #) -- Height can't change +- Not used currently -} + +----------------------------- LEVEL 1 --------------------------------- +-- ppputN, ppputZ, ppputP -- +----------------------------------------------------------------------- + +-- Put in (N k l a r), BF=-1 , (never returns P) +ppputN :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputN f k0 a0 k l a r = case compareInt# k0 k of + LT -> ppputNL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` N k0 l a' r + GT -> ppputNR f k0 a0 k l a r + +-- Put in (Z k l a r), BF= 0 +ppputZ :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputZ f k0 a0 k l a r = case compareInt# k0 k of + LT -> ppputZL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` Z k0 l a' r + GT -> ppputZR f k0 a0 k l a r + +-- Put in (P k l a r), BF=+1 , (never returns N) +ppputP :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputP f k0 a0 k l a r = case compareInt# k0 k of + LT -> ppputPL f k0 a0 k l a r + EQ -> let a' = f a in a' `seq` P k0 l a' r + GT -> ppputPR f k0 a0 k l a r + +----------------------------- LEVEL 2 --------------------------------- +-- ppputNL, ppputZL, ppputPL -- +-- ppputNR, ppputZR, ppputPR -- +----------------------------------------------------------------------- + +-- (ppputNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P) +{-# INLINE ppputNL #-} +ppputNL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputNL _ k0 a0 k E a r = a0 `seq` Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0 +ppputNL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +ppputNL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +ppputNL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + +-- (ppputZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N) +{-# INLINE ppputZL #-} +ppputZL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputZL _ k0 a0 k E a r = a0 `seq` P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1 +ppputZL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +ppputZL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +ppputZL f k0 a0 k (Z lk ll la lr) a r = let l' = ppputZ f k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + +-- (ppputZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P) +{-# INLINE ppputZR #-} +ppputZR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputZR _ k0 a0 k l a E = a0 `seq` N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1 +ppputZR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +ppputZR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +ppputZR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + +-- (ppputPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N) +{-# INLINE ppputPR #-} +ppputPR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputPR _ k0 a0 k l a E = a0 `seq` Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 +ppputPR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +ppputPR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +ppputPR f k0 a0 k l a (Z rk rl ra rr) = let r' = ppputZ f k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + +-- (ppputNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P) +{-# INLINE ppputNR #-} +ppputNR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputNR _ _ _ _ _ _ E = error urk -- impossible if BF=-1 +ppputNR f k0 a0 k l a (N rk rl ra rr) = let r' = ppputN f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +ppputNR f k0 a0 k l a (P rk rl ra rr) = let r' = ppputP f k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +ppputNR f k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL + LT -> ppputNRL f k0 a0 k l a rk rl ra rr -- RL (never returns P) + EQ -> let ra' = f ra in ra' `seq` N k l a (Z k0 rl ra' rr) -- new ra + GT -> ppputNRR f k0 a0 k l a rk rl ra rr -- RR (never returns P) + +-- (ppputPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N) +{-# INLINE ppputPL #-} +ppputPL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputPL _ _ _ _ E _ _ = error urk -- impossible if BF=+1 +ppputPL f k0 a0 k (N lk ll la lr) a r = let l' = ppputN f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +ppputPL f k0 a0 k (P lk ll la lr) a r = let l' = ppputP f k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +ppputPL f k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR + LT -> ppputPLL f k0 a0 k lk ll la lr a r -- LL (never returns N) + EQ -> let la' = f la in la' `seq` P k (Z k0 ll la' lr) a r -- new la + GT -> ppputPLR f k0 a0 k lk ll la lr a r -- LR (never returns N) + +----------------------------- LEVEL 3 --------------------------------- +-- ppputNRR, ppputPLL -- +-- ppputNRL, ppputPLR -- +----------------------------------------------------------------------- + +-- (ppputNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE ppputNRR #-} +ppputNRR :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputNRR _ k0 a0 k l a rk rl ra E = a0 `seq` Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!! +ppputNRR f k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = ppputN f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +ppputNRR f k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = ppputP f k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +ppputNRR f k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = ppputZ f k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + +-- (ppputPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE ppputPLL #-} +ppputPLL :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +ppputPLL _ k0 a0 k lk E la lr a r = a0 `seq` Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!! +ppputPLL f k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = ppputN f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +ppputPLL f k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = ppputP f k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +ppputPLL f k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = ppputZ f k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + +-- (ppputNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE ppputNRL #-} +ppputNRL :: (a -> a) -> Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +ppputNRL _ k0 a0 k l a rk E ra rr = a0 `seq` Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !! +ppputNRL f k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = ppputN f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +ppputNRL f k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = ppputP f k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +ppputNRL f k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = ppputZ f k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + +-- (ppputPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE ppputPLR #-} +ppputPLR :: (a -> a) -> Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +ppputPLR _ k0 a0 k lk ll la E a r = a0 `seq` Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !! +ppputPLR f k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = ppputN f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +ppputPLR f k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = ppputP f k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +ppputPLR f k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = ppputZ f k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +------------------ insertWithIntMap'/pushH'' Ends Here -------------------- +----------------------------------------------------------------------- + +-- | Local insertion facility which just overwrites any existing entry. +ins :: Key -> a -> IntMap a -> IntMap a +ins k0 a0 E = Z k0 E a0 E +ins k0 a0 (N k l a r) = insN k0 a0 k l a r +ins k0 a0 (Z k l a r) = insZ k0 a0 k l a r +ins k0 a0 (P k l a r) = insP k0 a0 k l a r + +-- | Same as 'ins', but takes the (relative) tree height as an extra argument and +-- returns the updated (relative) tree height. +insH :: Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #) +insH k0 a0 h E = (# Z k0 E a0 E, ((h)+#1#) #) +insH k0 a0 h (N k l a r) = let t_ = insN k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change +insH k0 a0 h (Z k l a r) = let t_ = insZ k0 a0 k l a r in + case t_ of + N _ _ _ _ -> (# t_,((h)+#1#) #) + P _ _ _ _ -> (# t_,((h)+#1#) #) + _ -> (# t_, h #) +insH k0 a0 h (P k l a r) = let t_ = insP k0 a0 k l a r in t_ `seq` (# t_,h #) -- Height can't change + +----------------------------- LEVEL 1 --------------------------------- +-- insN, insZ, insP -- +----------------------------------------------------------------------- + +-- Put in (N k l a r), BF=-1 , (never returns P) +insN :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insN k0 a0 k l a r = case compareInt# k0 k of + LT -> insNL k0 a0 k l a r + EQ -> N k l a0 r + GT -> insNR k0 a0 k l a r + +-- Put in (Z k l a r), BF= 0 +insZ :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insZ k0 a0 k l a r = case compareInt# k0 k of + LT -> insZL k0 a0 k l a r + EQ -> Z k l a0 r + GT -> insZR k0 a0 k l a r + +-- Put in (P k l a r), BF=+1 , (never returns N) +insP :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insP k0 a0 k l a r = case compareInt# k0 k of + LT -> insPL k0 a0 k l a r + EQ -> P k l a0 r + GT -> insPR k0 a0 k l a r + +----------------------------- LEVEL 2 --------------------------------- +-- insNL, insZL, insPL -- +-- insNR, insZR, insPR -- +----------------------------------------------------------------------- + +-- (insNL k l a r): Put in L subtree of (N k l a r), BF=-1 (Never requires rebalancing) , (never returns P) +{-# INLINE insNL #-} +insNL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insNL k0 a0 k E a r = Z k (Z k0 E a0 E) a r -- L subtree empty, H:0->1, parent BF:-1-> 0 +insNL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +insNL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N k l' a r +insNL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l' a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z k l' a r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + +-- (insZL k l a r): Put in L subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns N) +{-# INLINE insZL #-} +insZL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insZL k0 a0 k E a r = P k (Z k0 E a0 E) a r -- L subtree H:0->1, parent BF: 0->+1 +insZL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +insZL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z k l' a r +insZL k0 a0 k (Z lk ll la lr) a r = let l' = insZ k0 a0 lk ll la lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l' a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P k l' a r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + +-- (insZR k l a r): Put in R subtree of (Z k l a r), BF= 0 (Never requires rebalancing) , (never returns P) +{-# INLINE insZR #-} +insZR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insZR k0 a0 k l a E = N k l a (Z k0 E a0 E) -- R subtree H:0->1, parent BF: 0->-1 +insZR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +insZR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z k l a r' +insZR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> Z k l a r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N k l a r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + +-- (insPR k l a r): Put in R subtree of (P k l a r), BF=+1 (Never requires rebalancing) , (never returns N) +{-# INLINE insPR #-} +insPR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insPR k0 a0 k l a E = Z k l a (Z k0 E a0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 +insPR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +insPR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P k l a r' +insPR k0 a0 k l a (Z rk rl ra rr) = let r' = insZ k0 a0 rk rl ra rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error urk -- impossible + Z _ _ _ _ -> P k l a r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z k l a r' -- R subtree BF:0->+/-1, H:h->h+1, parent BF:+1-> 0 + + -------- These 2 cases (NR and PL) may need rebalancing if they go to LEVEL 3 --------- + +-- (insNR k l a r): Put in R subtree of (N k l a r), BF=-1 , (never returns P) +{-# INLINE insNR #-} +insNR :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insNR _ _ _ _ _ E = error urk -- impossible if BF=-1 +insNR k0 a0 k l a (N rk rl ra rr) = let r' = insN k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +insNR k0 a0 k l a (P rk rl ra rr) = let r' = insP k0 a0 rk rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N k l a r' +insNR k0 a0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of -- determine if RR or RL + LT -> insNRL k0 a0 k l a rk rl ra rr -- RL (never returns P) + EQ -> N k l a (Z rk rl a0 rr) + GT -> insNRR k0 a0 k l a rk rl ra rr -- RR (never returns P) + +-- (insPL k l a r): Put in L subtree of (P k l a r), BF=+1 , (never returns N) +{-# INLINE insPL #-} +insPL :: Key -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insPL _ _ _ E _ _ = error urk -- impossible if BF=+1 +insPL k0 a0 k (N lk ll la lr) a r = let l' = insN k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +insPL k0 a0 k (P lk ll la lr) a r = let l' = insP k0 a0 lk ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P k l' a r +insPL k0 a0 k (Z lk ll la lr) a r = case compareInt# k0 lk of -- determine if LL or LR + LT -> insPLL k0 a0 k lk ll la lr a r -- LL (never returns N) + EQ -> P k (Z lk ll a0 lr) a r + GT -> insPLR k0 a0 k lk ll la lr a r -- LR (never returns N) + +----------------------------- LEVEL 3 --------------------------------- +-- insNRR, insPLL -- +-- insNRL, insPLR -- +----------------------------------------------------------------------- + +-- (insNRR k l a rk rl ra rr): Put in RR subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE insNRR #-} +insNRR :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insNRR k0 a0 k l a rk rl ra E = Z rk (Z k l a rl) ra (Z k0 E a0 E) -- l and rl must also be E, special CASE RR!! +insNRR k0 a0 k l a rk rl ra (N rrk rrl rra rrr) = let rr' = insN k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +insNRR k0 a0 k l a rk rl ra (P rrk rrl rra rrr) = let rr' = insP k0 a0 rrk rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N k l a (Z rk rl ra rr') +insNRR k0 a0 k l a rk rl ra (Z rrk rrl rra rrr) = let rr' = insZ k0 a0 rrk rrl rra rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl ra rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z rk (Z k l a rl) ra rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + +-- (insPLL k lk ll la lr a r): Put in LL subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE insPLL #-} +insPLL :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +insPLL k0 a0 k lk E la lr a r = Z lk (Z k0 E a0 E) la (Z k lr a r) -- r and lr must also be E, special CASE LL!! +insPLL k0 a0 k lk (N llk lll lla llr) la lr a r = let ll' = insN k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +insPLL k0 a0 k lk (P llk lll lla llr) la lr a r = let ll' = insP k0 a0 llk lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P k (Z lk ll' la lr) a r +insPLL k0 a0 k lk (Z llk lll lla llr) la lr a r = let ll' = insZ k0 a0 llk lll lla llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll' la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z lk ll' la (Z k lr a r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + +-- (insNRL k l a rk rl ra rr): Put in RL subtree of (N k l a (Z rk rl ra rr)) , (never returns P) +{-# INLINE insNRL #-} +insNRL :: Key -> a -> Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> IntMap a +insNRL k0 a0 k l a rk E ra rr = Z k0 (Z k l a E) a0 (Z rk E ra rr) -- l and rr must also be E, special CASE LR !! +insNRL k0 a0 k l a rk (N rlk rll rla rlr) ra rr = let rl' = insN k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +insNRL k0 a0 k l a rk (P rlk rll rla rlr) ra rr = let rl' = insP k0 a0 rlk rll rla rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N k l a (Z rk rl' ra rr) +insNRL k0 a0 k l a rk (Z rlk rll rla rlr) ra rr = let rl' = insZ k0 a0 rlk rll rla rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error urk -- impossible + Z _ _ _ _ -> N k l a (Z rk rl' ra rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rlk' rll' rla' rlr' -> Z rlk' (P k l a rll') rla' (Z rk rlr' ra rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rlk' rll' rla' rlr' -> Z rlk' (Z k l a rll') rla' (N rk rlr' ra rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + +-- (insPLR k lk ll la lr a r): Put in LR subtree of (P k (Z lk ll la lr) a r) , (never returns N) +{-# INLINE insPLR #-} +insPLR :: Key -> a -> Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> IntMap a +insPLR k0 a0 k lk ll la E a r = Z k0 (Z lk ll la E) a0 (Z k E a r) -- r and ll must also be E, special CASE LR !! +insPLR k0 a0 k lk ll la (N lrk lrl lra lrr) a r = let lr' = insN k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +insPLR k0 a0 k lk ll la (P lrk lrl lra lrr) a r = let lr' = insP k0 a0 lrk lrl lra lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P k (Z lk ll la lr') a r +insPLR k0 a0 k lk ll la (Z lrk lrl lra lrr) a r = let lr' = insZ k0 a0 lrk lrl lra lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error urk -- impossible + Z _ _ _ _ -> P k (Z lk ll la lr') a r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrk' lrl' lra' lrr' -> Z lrk' (P lk ll la lrl') lra' (Z k lrr' a r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrk' lrl' lra' lrr' -> Z lrk' (Z lk ll la lrl') lra' (N k lrr' a r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +-------------------------- ins/insH End Here -------------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'union'. +unionIntMap :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionIntMap f t0_ t1_ = u0 t0_ t1_ where + u0 E t1 = t1 + u0 t0 E = t0 + u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1 + u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1 + u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1 + u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1 + -- uH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- IntMap a + uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t + -- u :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- (# Int#,IntMap a #) -- Output IntMap with height + ------------------------------------------------ + u 0# _ h1 t1 = (# t1,h1 #) + u h0 t0 0# _ = (# t0,h0 #) + ------------------------------------------------ + u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of + LT -> (# N k0 E a0 t1, 2# #) + EQ -> (# Z k0 E (f a0 a1) E , 1# #) + GT -> (# P k0 t1 a0 E , 2# #) + u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1 + u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0 + ------------------------------------------------ + u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 + u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 + ------------------------------------------------ + u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u _ _ _ _ = error (mErr ++ "unionIntMap: Bad IntMap.") + u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 = + case compareInt# k0 k1 of + -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1) + LT -> case forkR hr0 r0 k1 a1 of + (# hrl0,rl0,a1_,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0) + (# hll1,ll1,a0_,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1) + -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1) + case u hl0 l0 hll1 ll1 of + (# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of + (# m,hm #) -> case u hrr0 rr0 hr1 r1 of + (# r,hr #) -> case spliceH k1 m hm a1_ r hr of + (# t,ht #) -> spliceH k0 l hl a0_ t ht + -- k0 = k1 + EQ -> case u hl0 l0 hl1 l1 of + (# l,hl #) -> case u hr0 r0 hr1 r1 of + (# r,hr #) -> spliceH k0 l hl (f a0 a1) r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL k0 a0 hr1 r1 of + (# hrl1,rl1,a0_,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1) + (# hll0,ll0,a1_,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u hll0 ll0 hl1 l1 of + (# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of + (# m,hm #) -> case u hr0 r0 hrr1 rr1 of + (# r,hr #) -> case spliceH k1 l hl a1_ m hm of + (# t,ht #) -> spliceH k0 t ht a0_ r hr + -- We need 2 different versions of fork (L & R) to ensure that values are combined in + -- the right order (f a0 a1) + ------------------------------------------------ + -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #) + forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where + forkL_ h E = (# h,E,a0,h,E #) + forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r + forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r + forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r + forkL__ k hl l a hr r = case compareInt# k0 k of + LT -> case forkL_ hl l of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #) + EQ -> (# hl,l,f a0 a,hr,r #) + GT -> case forkL_ hr r of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #) + ------------------------------------------------ + -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #) + forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where + forkR_ h E = (# h,E,a1,h,E #) + forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r + forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r + forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r + forkR__ k hl l a hr r = case compareInt# k k1 of + LT -> case forkR_ hr r of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #) + EQ -> (# hl,l,f a a1,hr,r #) + GT -> case forkR_ hl l of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #) + ------------------------------------------------ + -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB k0 a0 ht1 t1 = pushH (\a1 -> f a0 a1) k0 a0 ht1 t1 + ------------------------------------------------ + -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA k1 a1 ht0 t0 = pushH (\a0 -> f a0 a1) k1 a1 ht0 t0 + ------------------------------------------------ + -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of + (# t,h #) -> pushAB k0 a0 h t + ------------------------------------------------ + -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of + (# t,h #) -> pushBA k1 a1 h t + ------------------------------------------------ + -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of + (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t + ------------------------------------------------ + -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of + (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t +----------------------------------------------------------------------- +----------------------- unionIntMap Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'union''. +unionIntMap' :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a +unionIntMap' f t0_ t1_ = u0 t0_ t1_ where + u0 E t1 = t1 + u0 t0 E = t0 + u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1 + u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1 + u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1 + u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1 + -- uH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- IntMap a + uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t + -- u :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- (# Int#,IntMap a #) -- Output IntMap with height + ------------------------------------------------ + u 0# _ h1 t1 = (# t1,h1 #) + u h0 t0 0# _ = (# t0,h0 #) + ------------------------------------------------ + u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of + LT -> (# N k0 E a0 t1, 2# #) + EQ -> let a_ = f a0 a1 in a_ `seq` + (# Z k0 E a_ E , 1# #) + GT -> (# P k0 t1 a0 E , 2# #) + u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1 + u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0 + ------------------------------------------------ + u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 + u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 + ------------------------------------------------ + u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u _ _ _ _ = error (mErr ++ "unionIntMap: Bad IntMap.") + u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 = + case compareInt# k0 k1 of + -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1) + LT -> case forkR hr0 r0 k1 a1 of + (# hrl0,rl0,a1_,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0) + (# hll1,ll1,a0_,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1) + -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1) + case u hl0 l0 hll1 ll1 of + (# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of + (# m,hm #) -> case u hrr0 rr0 hr1 r1 of + (# r,hr #) -> case spliceH k1 m hm a1_ r hr of + (# t,ht #) -> spliceH k0 l hl a0_ t ht + -- k0 = k1 + EQ -> case u hl0 l0 hl1 l1 of + (# l,hl #) -> case u hr0 r0 hr1 r1 of + (# r,hr #) -> let a_ = f a0 a1 in a_ `seq` spliceH k0 l hl a_ r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL k0 a0 hr1 r1 of + (# hrl1,rl1,a0_,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1) + (# hll0,ll0,a1_,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u hll0 ll0 hl1 l1 of + (# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of + (# m,hm #) -> case u hr0 r0 hrr1 rr1 of + (# r,hr #) -> case spliceH k1 l hl a1_ m hm of + (# t,ht #) -> spliceH k0 t ht a0_ r hr + -- We need 2 different versions of fork (L & R) to ensure that values are combined in + -- the right order (f a0 a1) + ------------------------------------------------ + -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,a,Int#,IntMap a #) + forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where + forkL_ h E = (# h,E,a0,h,E #) + forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r + forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r + forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r + forkL__ k hl l a hr r = case compareInt# k0 k of + LT -> case forkL_ hl l of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #) + EQ -> let a_ = f a0 a in a_ `seq` + (# hl,l,a_,hr,r #) + GT -> case forkL_ hr r of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #) + ------------------------------------------------ + -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,a,Int#,IntMap a #) + forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where + forkR_ h E = (# h,E,a1,h,E #) + forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r + forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r + forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r + forkR__ k hl l a hr r = case compareInt# k k1 of + LT -> case forkR_ hr r of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #) + EQ -> let a_ = f a a1 in a_ `seq` + (# hl,l,a_,hr,r #) + GT -> case forkR_ hl l of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #) + ------------------------------------------------ + -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB k0 a0 ht1 t1 = pushH' (\a1 -> f a0 a1) k0 a0 ht1 t1 + ------------------------------------------------ + -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA k1 a1 ht0 t0 = pushH' (\a0 -> f a0 a1) k1 a1 ht0 t0 + ------------------------------------------------ + -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of + (# t,h #) -> pushAB k0 a0 h t + ------------------------------------------------ + -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of + (# t,h #) -> pushBA k1 a1 h t + ------------------------------------------------ + -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of + (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t + ------------------------------------------------ + -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of + (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t +----------------------------------------------------------------------- +----------------------- unionIntMap' Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'unionMaybe'. +unionMaybeIntMap :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a +unionMaybeIntMap f t0_ t1_ = u0 t0_ t1_ where + u0 E t1 = t1 + u0 t0 E = t0 + u0 t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 2# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 2# l0) t0 (addHeight 1# l1) t1 + u0 t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 2# l0) t0 (addHeight 2# r1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 2# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = uH (addHeight 1# l0) t0 (addHeight 1# l1) t1 + u0 t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = uH (addHeight 1# l0) t0 (addHeight 2# r1) t1 + u0 t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 2# l1) t1 + u0 t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = uH (addHeight 2# r0) t0 (addHeight 1# l1) t1 + u0 t0@(P _ _ _ r0) t1@(P _ _ _ r1) = uH (addHeight 2# r0) t0 (addHeight 2# r1) t1 + -- uH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- IntMap a + uH h0 t0 h1 t1 = case u h0 t0 h1 t1 of (# t,_ #) -> t + -- u :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap a -> -- 2nd IntMap with height + -- (# Int#,IntMap a #) -- Output IntMap with height + ------------------------------------------------ + u 0# _ h1 t1 = (# t1,h1 #) + u h0 t0 0# _ = (# t0,h0 #) + ------------------------------------------------ + u 1# (Z k0 _ a0 _ ) 1# t1@(Z k1 _ a1 _ ) = case compareInt# k0 k1 of + LT -> (# N k0 E a0 t1, 2# #) + EQ -> case f a0 a1 of + Just a -> (# Z k0 E a E , 1# #) + Nothing -> (# E , 0# #) + GT -> (# P k0 t1 a0 E , 2# #) + u 1# (Z k0 _ a0 _ ) ht1 t1 = pushAB k0 a0 ht1 t1 + u ht0 t0 1# (Z k1 _ a1 _ ) = pushBA k1 a1 ht0 t0 + ------------------------------------------------ + u 2# (N k0 _ a0 (Z k0_ _ a0_ _)) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u 2# (P k0_ (Z k0 _ a0 _) a0_ _) ht1 t1 = pushAB2 k0 a0 k0_ a0_ ht1 t1 + u ht0 t0 2# (N k1 _ a1 (Z k1_ _ a1_ _)) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u ht0 t0 2# (P k1_ (Z k1 _ a1 _) a1_ _) = pushBA2 k1 a1 k1_ a1_ ht0 t0 + u 2# (Z k0_ (Z k0 _ a0 _) a0_ (Z k0__ _ a0__ _)) ht1 t1 = pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 + u ht0 t0 2# (Z k1_ (Z k1 _ a1 _) a1_ (Z k1__ _ a1__ _)) = pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 + ------------------------------------------------ + u h0 (N k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (N k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#2#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (Z k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (Z k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#1#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u h0 (P k0 l0 a0 r0) h1 (N k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#2#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (Z k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#1#) r1 + u h0 (P k0 l0 a0 r0) h1 (P k1 l1 a1 r1) = u_ k0 ((h0)-#1#) l0 a0 ((h0)-#2#) r0 k1 ((h1)-#1#) l1 a1 ((h1)-#2#) r1 + u _ _ _ _ = error (mErr ++ "unionMaybeIntMap: Bad IntMap.") + u_ k0 hl0 l0 a0 hr0 r0 k1 hl1 l1 a1 hr1 r1 = + case compareInt# k0 k1 of + -- k0 < k1, so (l0 < k0 < k1) & (k0 < k1 < r1) + LT -> case forkR hr0 r0 k1 a1 of + (# hrl0,rl0,mba1,hrr0,rr0 #) -> case forkL k0 a0 hl1 l1 of -- (k0 < rl0 < k1) & (k0 < k1 < rr0) + (# hll1,ll1,mba0,hlr1,lr1 #) -> -- (ll1 < k0 < k1) & (k0 < lr1 < k1) + -- (l0 + ll1) < k0 < (rl0 + lr1) < k1 < (rr0 + r1) + case u hl0 l0 hll1 ll1 of + (# l,hl #) -> case u hrl0 rl0 hlr1 lr1 of + (# m,hm #) -> case u hrr0 rr0 hr1 r1 of + (# r,hr #) -> case (case mba1 of Just a -> spliceH k1 m hm a r hr + Nothing -> joinH m hm r hr + ) of + (# t,ht #) -> case mba0 of Just a -> spliceH k0 l hl a t ht + Nothing -> joinH l hl t ht + -- k0 = k1 + EQ -> case u hl0 l0 hl1 l1 of + (# l,hl #) -> case u hr0 r0 hr1 r1 of + (# r,hr #) -> case f a0 a1 of Just a -> spliceH k0 l hl a r hr + Nothing -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL k0 a0 hr1 r1 of + (# hrl1,rl1,mba0,hrr1,rr1 #) -> case forkR hl0 l0 k1 a1 of -- (k1 < rl1 < k0) & (k1 < k0 < rr1) + (# hll0,ll0,mba1,hlr0,lr0 #) -> -- (ll0 < k1 < k0) & (k1 < lr0 < k0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u hll0 ll0 hl1 l1 of + (# l,hl #) -> case u hlr0 lr0 hrl1 rl1 of + (# m,hm #) -> case u hr0 r0 hrr1 rr1 of + (# r,hr #) -> case (case mba1 of Just a -> spliceH k1 l hl a m hm + Nothing -> joinH l hl m hm + ) of + (# t,ht #) -> case mba0 of Just a -> spliceH k0 t ht a r hr + Nothing -> joinH t ht r hr + -- We need 2 different versions of fork (L & R) to ensure that values are combined in + -- the right order (f a0 a1) + ------------------------------------------------ + -- forkL :: Key -> a -> Int# -> IntMap a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #) + forkL k0 a0 ht1 t1 = forkL_ ht1 t1 where + forkL_ h E = (# h,E,Just a0,h,E #) + forkL_ h (N k l a r) = forkL__ k ((h)-#2#) l a ((h)-#1#) r + forkL_ h (Z k l a r) = forkL__ k ((h)-#1#) l a ((h)-#1#) r + forkL_ h (P k l a r) = forkL__ k ((h)-#1#) l a ((h)-#2#) r + forkL__ k hl l a hr r = case compareInt# k0 k of + LT -> case forkL_ hl l of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a0_,hl1_,l1_ #) + EQ -> let mba = f a0 a in mba `seq` (# hl,l,mba,hr,r #) + GT -> case forkL_ hr r of + (# hl0,l0,a0_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a0_,hl1,l1 #) + ------------------------------------------------ + -- forkL :: Int# -> IntMap a -> Key -> a -> (# Int#,IntMap a,Maybe a,Int#,IntMap a #) + forkR ht0 t0 k1 a1 = forkR_ ht0 t0 where + forkR_ h E = (# h,E,Just a1,h,E #) + forkR_ h (N k l a r) = forkR__ k ((h)-#2#) l a ((h)-#1#) r + forkR_ h (Z k l a r) = forkR__ k ((h)-#1#) l a ((h)-#1#) r + forkR_ h (P k l a r) = forkR__ k ((h)-#1#) l a ((h)-#2#) r + forkR__ k hl l a hr r = case compareInt# k k1 of + LT -> case forkR_ hr r of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l hl a l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,a1_,hl1,l1 #) + EQ -> let mba = f a a1 in mba `seq` (# hl,l,mba,hr,r #) + GT -> case forkR_ hl l of + (# hl0,l0,a1_,hl1,l1 #) -> case spliceH k l1 hl1 a r hr of + (# l1_,hl1_ #) -> (# hl0,l0,a1_,hl1_,l1_ #) + ------------------------------------------------ + -- pushAB :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB k0 a0 ht1 t1 = pushMaybeH (\a1 -> f a0 a1) k0 a0 ht1 t1 + ------------------------------------------------ + -- pushBA :: Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA k1 a1 ht0 t0 = pushMaybeH (\a0 -> f a0 a1) k1 a1 ht0 t0 + ------------------------------------------------ + -- pushAB2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB2 k0 a0 k0_ a0_ ht1 t1 = case pushAB k0_ a0_ ht1 t1 of + (# t,h #) -> pushAB k0 a0 h t + ------------------------------------------------ + -- pushBA2 :: Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA2 k1 a1 k1_ a1_ ht0 t0 = case pushBA k1_ a1_ ht0 t0 of + (# t,h #) -> pushBA k1 a1 h t + ------------------------------------------------ + -- pushAB3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushAB3 k0 a0 k0_ a0_ k0__ a0__ ht1 t1 = case pushAB k0__ a0__ ht1 t1 of + (# t,h #) -> pushAB2 k0 a0 k0_ a0_ h t + ------------------------------------------------ + -- pushBA3 :: Key -> a -> Key -> a -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) + pushBA3 k1 a1 k1_ a1_ k1__ a1__ ht0 t0 = case pushBA k1__ a1__ ht0 t0 of + (# t,h #) -> pushBA2 k1 a1 k1_ a1_ h t +----------------------------------------------------------------------- +-------------------- unionMaybeIntMap Ends Here ------------------------ +----------------------------------------------------------------------- + +-- Utility used by unionMaybeIntMap +pushMaybeH :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a,Int# #) +pushMaybeH f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of + Nothing -> insH k0 a0 ht1 t1 + Just a -> case f a of + Nothing -> delH k0 ht1 t1 + Just a_ -> let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq` + (# t_,ht1 #) -- No height change + +-- -- Utility used by unionMaybeIntMap +-- pushMaybeH' :: (a -> Maybe a) -> Key -> a -> Int# -> IntMap a -> (# IntMap a, Int# #) +-- pushMaybeH' f k0 a0 ht1 t1 = case lookupIntMap k0 t1 of +-- Nothing -> insH k0 a0 ht1 t1 +-- Just a -> case f a of +-- Nothing -> delH k0 ht1 t1 +-- Just a_ -> a_ `seq` let t_ = assertWriteIntMap k0 a_ t1 in t_ `seq` +-- (# t_,ht1 #) -- No height change + +-- | Specialised association list. +data IAList a = Empt + | Cons {-# UNPACK #-} !Int# a (IAList a) + deriving(Eq,Ord) + +-- | Convert an 'IntMap' to an 'IAList' (in ascending order). +asIAList :: IntMap a -> IAList a +asIAList imp = f imp Empt where + f E ial = ial + f (N k l a r) ial = f' k l a r ial + f (Z k l a r) ial = f' k l a r ial + f (P k l a r) ial = f' k l a r ial + f' k l a r ial = let ial' = f r ial + ial'' = ial' `seq` Cons k a ial' + in ial'' `seq` f l ial'' + +-- | See 'Map' class method 'intersection'. +intersectionIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionIntMap f ta0 tb0 = i0 ta0 tb0 where + -- i0 :: IntMap a -> IntMap b -> IntMap c + i0 E _ = E + i0 _ E = E + i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb + i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb + i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb + i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb + i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb + i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb + i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb + i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb + i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb + + -- iH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IntMap c + iH hta ta htb tb = case i hta ta htb tb Empt 0# of + (# ial,n #) -> case subst (rep (I# (n))) ial of + (# imp,rm #) -> case rm of + Empt -> imp + _ -> error (mErr ++ "intersectionIntMap: Bad IAList.") + + -- i :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IAList c -> Int# -> -- Input IAList with length + -- (# IAList c, Int# #) -- Output IAList with length + ------------------------------------------------ + i 0# _ _ _ cs n = (# cs,n #) + i _ _ 0# _ cs n = (# cs,n #) + ------------------------------------------------ + i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then (# Cons ka (f ea eb) cs, ((n)+#1#) #) + else (# cs,n #) + i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n + i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n + ------------------------------------------------ + i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n + i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n + ------------------------------------------------ + -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1 + i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i _ _ _ _ _ _ = error (mErr ++ "intersectionIntMap: Bad IntMap.") + ------------------------------------------------ + i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case fork kb hra ra of + (# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra) + (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb) + -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb) + (# cs_,n_ #) -> case (case mbb of + Nothing -> i hrla rla hlrb lrb cs_ n_ + Just b -> i hrla rla hlrb lrb (Cons ka (f ea b) cs_) ((n_)+#1#) + ) of + (# cs__,n__ #) -> case mba of + Nothing -> i hla la hllb llb cs__ n__ + Just a -> i hla la hllb llb (Cons kb (f a eb) cs__) ((n__)+#1#) + -- ka = kb + EQ -> case i hra ra hrb rb cs n of + (# cs_,n_ #) -> i hla la hlb lb (Cons ka (f ea eb) cs_) ((n_)+#1#) + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case fork ka hrb rb of + (# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb) + (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka) + -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb) + (# cs_,n_ #) -> case (case mba of + Nothing -> i hlra lra hrlb rlb cs_ n_ + Just a -> i hlra lra hrlb rlb (Cons kb (f a eb) cs_) ((n_)+#1#) + ) of + (# cs__,n__ #) -> case mbb of + Nothing -> i hlla lla hlb lb cs__ n__ + Just b -> i hlla lla hlb lb (Cons ka (f ea b) cs__) ((n__)+#1#) + ------------------------------------------------ + -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #) + -- Tree height (ht) is known to be >= 1, can we exploit this ?? + fork k0 ht t = fork_ ht t where + fork_ h E = (# h,E,Nothing,h,E #) + fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r + fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r + fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r + fork__ k hl l x hr r = case compareInt# k0 k of + LT -> case fork_ hl l of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of + (# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #) + EQ -> (# hl,l,Just x,hr,r #) + GT -> case fork_ hr r of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #) + ------------------------------------------------ + -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB ka ea tb cs n = rd tb where + rd E = (# cs,n #) + rd (N k l b r) = rd_ k l b r + rd (Z k l b r) = rd_ k l b r + rd (P k l b r) = rd_ k l b r + rd_ k l b r = case compareInt# ka k of + LT -> rd l + EQ -> (# Cons ka (f ea b) cs, ((n)+#1#) #) + GT -> rd r + ------------------------------------------------ + -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA kb eb ta cs n = rd ta where + rd E = (# cs,n #) + rd (N k l a r) = rd_ k l a r + rd (Z k l a r) = rd_ k l a r + rd (P k l a r) = rd_ k l a r + rd_ k l a r = case compareInt# kb k of + LT -> rd l + EQ -> (# Cons kb (f a eb) cs, ((n)+#1#) #) + GT -> rd r + ------------------------------------------------ + -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of + (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_ + ------------------------------------------------ + -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of + (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of + (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of + (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_ +----------------------------------------------------------------------- +-------------------- intersectionIntMap Ends Here ---------------------- +----------------------------------------------------------------------- + + +-- | See 'Map' class method 'intersection''. +intersectionIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c +intersectionIntMap' f ta0 tb0 = i0 ta0 tb0 where + -- i0 :: IntMap a -> IntMap b -> IntMap c + i0 E _ = E + i0 _ E = E + i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb + i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb + i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb + i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb + i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb + i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb + i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb + i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb + i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb + + -- iH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IntMap c + iH hta ta htb tb = case i hta ta htb tb Empt 0# of + (# ial,n #) -> case subst (rep (I# (n))) ial of + (# imp,rm #) -> case rm of + Empt -> imp + _ -> error (mErr ++ "intersectionIntMap': Bad IAList.") + + -- i :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IAList c -> Int# -> -- Input IAList with length + -- (# IAList c, Int# #) -- Output IAList with length + ------------------------------------------------ + i 0# _ _ _ cs n = (# cs,n #) + i _ _ 0# _ cs n = (# cs,n #) + ------------------------------------------------ + i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then let c = f ea eb in c `seq` + (# Cons ka c cs, ((n)+#1#) #) + else (# cs,n #) + i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n + i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n + ------------------------------------------------ + i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n + i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n + ------------------------------------------------ + -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1 + i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i _ _ _ _ _ _ = error (mErr ++ "intersectionIntMap': Bad IntMap.") + ------------------------------------------------ + i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case fork kb hra ra of + (# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra) + (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb) + -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb) + (# cs_,n_ #) -> case (case mbb of + Nothing -> i hrla rla hlrb lrb cs_ n_ + Just b -> let c = f ea b in c `seq` + i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#) + ) of + (# cs__,n__ #) -> case mba of + Nothing -> i hla la hllb llb cs__ n__ + Just a -> let c = f a eb in c `seq` + i hla la hllb llb (Cons kb c cs__) ((n__)+#1#) + -- ka = kb + EQ -> case i hra ra hrb rb cs n of + (# cs_,n_ #) -> let c = f ea eb in c `seq` + i hla la hlb lb (Cons ka c cs_) ((n_)+#1#) + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case fork ka hrb rb of + (# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb) + (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka) + -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb) + (# cs_,n_ #) -> case (case mba of + Nothing -> i hlra lra hrlb rlb cs_ n_ + Just a -> let c = f a eb in c `seq` + i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#) + ) of + (# cs__,n__ #) -> case mbb of + Nothing -> i hlla lla hlb lb cs__ n__ + Just b -> let c = f ea b in c `seq` + i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#) + ------------------------------------------------ + -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #) + -- Tree height (ht) is known to be >= 1, can we exploit this ?? + fork k0 ht t = fork_ ht t where + fork_ h E = (# h,E,Nothing,h,E #) + fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r + fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r + fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r + fork__ k hl l x hr r = case compareInt# k0 k of + LT -> case fork_ hl l of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of + (# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #) + EQ -> (# hl,l,Just x,hr,r #) + GT -> case fork_ hr r of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #) + ------------------------------------------------ + -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB ka ea tb cs n = rd tb where + rd E = (# cs,n #) + rd (N k l b r) = rd_ k l b r + rd (Z k l b r) = rd_ k l b r + rd (P k l b r) = rd_ k l b r + rd_ k l b r = case compareInt# ka k of + LT -> rd l + EQ -> let c = f ea b in c `seq` (# Cons ka c cs, ((n)+#1#) #) + GT -> rd r + ------------------------------------------------ + -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA kb eb ta cs n = rd ta where + rd E = (# cs,n #) + rd (N k l a r) = rd_ k l a r + rd (Z k l a r) = rd_ k l a r + rd (P k l a r) = rd_ k l a r + rd_ k l a r = case compareInt# kb k of + LT -> rd l + EQ -> let c = f a eb in c `seq` (# Cons kb c cs, ((n)+#1#) #) + GT -> rd r + ------------------------------------------------ + -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of + (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_ + ------------------------------------------------ + -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of + (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of + (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of + (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_ +----------------------------------------------------------------------- +-------------------- intersectionIntMap' Ends Here --------------------- +----------------------------------------------------------------------- + + +-- | See 'Map' class method 'intersectionMaybe'. +intersectionMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> IntMap c +intersectionMaybeIntMap f ta0 tb0 = i0 ta0 tb0 where + -- i0 :: IntMap a -> IntMap b -> IntMap c + i0 E _ = E + i0 _ E = E + i0 ta@(N _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 2# lb) tb + i0 ta@(N _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 2# la) ta (addHeight 1# lb) tb + i0 ta@(N _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 2# la) ta (addHeight 2# rb) tb + i0 ta@(Z _ la _ _ ) tb@(N _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 2# lb) tb + i0 ta@(Z _ la _ _ ) tb@(Z _ lb _ _ ) = iH (addHeight 1# la) ta (addHeight 1# lb) tb + i0 ta@(Z _ la _ _ ) tb@(P _ _ _ rb) = iH (addHeight 1# la) ta (addHeight 2# rb) tb + i0 ta@(P _ _ _ ra) tb@(N _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 2# lb) tb + i0 ta@(P _ _ _ ra) tb@(Z _ lb _ _ ) = iH (addHeight 2# ra) ta (addHeight 1# lb) tb + i0 ta@(P _ _ _ ra) tb@(P _ _ _ rb) = iH (addHeight 2# ra) ta (addHeight 2# rb) tb + + -- iH :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IntMap c + iH hta ta htb tb = case i hta ta htb tb Empt 0# of + (# ial,n #) -> case subst (rep (I# (n))) ial of + (# imp,rm #) -> case rm of + Empt -> imp + _ -> error (mErr ++ "intersectionMaybeIntMap: Bad IAList.") + + -- i :: Int# -> IntMap a -> -- 1st IntMap with height + -- Int# -> IntMap b -> -- 2nd IntMap with height + -- IAList c -> Int# -> -- Input IAList with length + -- (# IAList c, Int# #) -- Output IAList with length + ------------------------------------------------ + i 0# _ _ _ cs n = (# cs,n #) + i _ _ 0# _ cs n = (# cs,n #) + ------------------------------------------------ + i 1# (Z ka _ ea _ ) 1# (Z kb _ eb _ ) cs n = if ka ==# kb then case f ea eb of + Just c -> (# Cons ka c cs, ((n)+#1#) #) + Nothing -> (# cs,n #) + else (# cs,n #) + i 1# (Z ka _ ea _ ) _ tb cs n = lookAB ka ea tb cs n + i _ ta 1# (Z kb _ eb _ ) cs n = lookBA kb eb ta cs n + ------------------------------------------------ + i 2# (N ka0 _ ea0 (Z ka1 _ ea1 _)) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i 2# (P ka1 (Z ka0 _ ea0 _) ea1 _ ) _ tb cs n = lookAB2 ka0 ea0 ka1 ea1 tb cs n + i _ ta 2# (N kb0 _ eb0 (Z kb1 _ eb1 _)) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i _ ta 2# (P kb1 (Z kb0 _ eb0 _) eb1 _ ) cs n = lookBA2 kb0 eb0 kb1 eb1 ta cs n + i 2# (Z ka1 (Z ka0 _ ea0 _) ea1 (Z ka2 _ ea2 _)) _ tb cs n = lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n + i _ ta 2# (Z kb1 (Z kb0 _ eb0 _) eb1 (Z kb2 _ eb2 _)) cs n = lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n + ------------------------------------------------ + -- Both tree heights are known to be >= 3 at this point, so sub-tree heights >= 1 + i ha (N ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (N ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#2#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (Z ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (Z ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#1#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i ha (P ka la ea ra) hb (N kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#2#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (Z kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#1#) rb cs n + i ha (P ka la ea ra) hb (P kb lb eb rb) cs n = i_ ka ((ha)-#1#) la ea ((ha)-#2#) ra kb ((hb)-#1#) lb eb ((hb)-#2#) rb cs n + i _ _ _ _ _ _ = error (mErr ++ "intersectionMaybeIntMap: Bad IntMap.") + ------------------------------------------------ + i_ ka hla la ea hra ra kb hlb lb eb hrb rb cs n = case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case fork kb hra ra of + (# hrla,rla,mba,hrra,rra #) -> case fork ka hlb lb of -- (ka < rla < kb) & (ka < kb < rra) + (# hllb,llb,mbb,hlrb,lrb #) -> case i hrra rra hrb rb cs n of -- (llb < ka < kb) & (ka < lrb < kb) + -- (la + llb) < ka < (rla + lrb) < kb < (rra + rb) + (# cs_,n_ #) -> case (case mbb of + Nothing -> i hrla rla hlrb lrb cs_ n_ + Just b -> case f ea b of + Just c -> i hrla rla hlrb lrb (Cons ka c cs_) ((n_)+#1#) + Nothing -> i hrla rla hlrb lrb cs_ n_ + ) of + (# cs__,n__ #) -> case mba of + Nothing -> i hla la hllb llb cs__ n__ + Just a -> case f a eb of + Just c -> i hla la hllb llb (Cons kb c cs__) ((n__)+#1#) + Nothing -> i hla la hllb llb cs__ n__ + -- ka = kb + EQ -> case i hra ra hrb rb cs n of + (# cs_,n_ #) -> case f ea eb of + Just c -> i hla la hlb lb (Cons ka c cs_) ((n_)+#1#) + Nothing -> i hla la hlb lb cs_ n_ + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case fork ka hrb rb of + (# hrlb,rlb,mbb,hrrb,rrb #) -> case fork kb hla la of -- (kb < rlb < ka) & (kb < ka < rrb) + (# hlla,lla,mba,hlra,lra #) -> case i hra ra hrrb rrb cs n of -- (lla < kb < ka) & (kb < lra < ka) + -- (lla + lb) < kb < (lra + rlb) < ka < (ra + rrb) + (# cs_,n_ #) -> case (case mba of + Nothing -> i hlra lra hrlb rlb cs_ n_ + Just a -> case f a eb of + Just c -> i hlra lra hrlb rlb (Cons kb c cs_) ((n_)+#1#) + Nothing -> i hlra lra hrlb rlb cs_ n_ + ) of + (# cs__,n__ #) -> case mbb of + Nothing -> i hlla lla hlb lb cs__ n__ + Just b -> case f ea b of + Just c -> i hlla lla hlb lb (Cons ka c cs__) ((n__)+#1#) + Nothing -> i hlla lla hlb lb cs__ n__ +------------------------------------------------ + -- fork :: Key -> Int# -> IntMap x -> (# Int#,IntMap x,Maybe x,Int#,IntMap x #) + -- Tree height (ht) is known to be >= 1, can we exploit this ?? + fork k0 ht t = fork_ ht t where + fork_ h E = (# h,E,Nothing,h,E #) + fork_ h (N k l x r) = fork__ k ((h)-#2#) l x ((h)-#1#) r + fork_ h (Z k l x r) = fork__ k ((h)-#1#) l x ((h)-#1#) r + fork_ h (P k l x r) = fork__ k ((h)-#1#) l x ((h)-#2#) r + fork__ k hl l x hr r = case compareInt# k0 k of + LT -> case fork_ hl l of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l1 hl1 x r hr of + (# l1_,hl1_ #) -> (# hl0,l0,mbx,hl1_,l1_ #) + EQ -> (# hl,l,Just x,hr,r #) + GT -> case fork_ hr r of + (# hl0,l0,mbx,hl1,l1 #) -> case spliceH k l hl x l0 hl0 of + (# l0_,hl0_ #) -> (# hl0_,l0_,mbx,hl1,l1 #) + ------------------------------------------------ + -- lookAB :: Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB ka ea tb cs n = rd tb where + rd E = (# cs,n #) + rd (N k l b r) = rd_ k l b r + rd (Z k l b r) = rd_ k l b r + rd (P k l b r) = rd_ k l b r + rd_ k l b r = case compareInt# ka k of + LT -> rd l + EQ -> case f ea b of + Just c -> (# Cons ka c cs, ((n)+#1#) #) + Nothing -> (# cs,n #) + GT -> rd r + ------------------------------------------------ + -- lookBA :: Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA kb eb ta cs n = rd ta where + rd E = (# cs,n #) + rd (N k l a r) = rd_ k l a r + rd (Z k l a r) = rd_ k l a r + rd (P k l a r) = rd_ k l a r + rd_ k l a r = case compareInt# kb k of + LT -> rd l + EQ -> case f a eb of + Just c -> (# Cons kb c cs, ((n)+#1#) #) + Nothing -> (# cs,n #) + GT -> rd r + ------------------------------------------------ + -- lookAB2 :: Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB2 ka0 ea0 ka1 ea1 tb cs n = case lookAB ka1 ea1 tb cs n of + (# cs_,n_ #) -> lookAB ka0 ea0 tb cs_ n_ + ------------------------------------------------ + -- lookBA2 :: Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA2 kb0 eb0 kb1 eb1 ta cs n = case lookBA kb1 eb1 ta cs n of + (# cs_,n_ #) -> lookBA kb0 eb0 ta cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> a -> Key -> a -> Key -> a -> IntMap b -> IAList c -> Int# -> (# IAList c,Int# #) + lookAB3 ka0 ea0 ka1 ea1 ka2 ea2 tb cs n = case lookAB ka2 ea2 tb cs n of + (# cs_,n_ #) -> lookAB2 ka0 ea0 ka1 ea1 tb cs_ n_ + ------------------------------------------------ + -- lookAB3 :: Key -> b -> Key -> b -> Key -> b -> IntMap a -> IAList c -> Int# -> (# IAList c,Int# #) + lookBA3 kb0 eb0 kb1 eb1 kb2 eb2 ta cs n = case lookBA kb2 eb2 ta cs n of + (# cs_,n_ #) -> lookBA2 kb0 eb0 kb1 eb1 ta cs_ n_ +----------------------------------------------------------------------- +----------------- intersectionMaybeIntMap Ends Here -------------------- +----------------------------------------------------------------------- + +-- AVL template, output of rep +data Tmp = ET | NT Tmp Tmp | ZT Tmp Tmp | PT Tmp Tmp +-- Construct a template of size n (n>=0). This is for internal use only. +-- N.B. Uses regular (boxed) Ints. Optimising for unboxed Ints is just too painful in this case. +-- Hopefully the compiler will do a decent job for us...??? +rep :: Int -> Tmp +rep n | odd n = repOdd n -- n is odd , >=1 +rep n = repEvn n -- n is even, >=0 +-- n is known to be odd (>=1), so left and right sub-trees are identical +repOdd :: Int -> Tmp +repOdd n = let sub = rep (n `shiftR` 1) in ZT sub sub +-- n is known to be even (>=0) +repEvn :: Int -> Tmp +repEvn n | n .&. (n-1) == 0 = repP2 n -- treat exact powers of 2 specially, traps n=0 too +repEvn n = let nl = n `shiftR` 1 -- size of left subtree (odd or even) + nr = nl - 1 -- size of right subtree (even or odd) + in if odd nr + then let l = repEvn nl -- right sub-tree is odd , so left is even (>=2) + r = repOdd nr + in l `seq` r `seq` ZT l r + else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2) + r = repEvn nr + in l `seq` r `seq` ZT l r +-- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16.. +repP2 :: Int -> Tmp +repP2 0 = ET +repP2 1 = ZT ET ET +repP2 n = let nl = n `shiftR` 1 -- nl is also an exact power of 2 + nr = nl - 1 -- nr is one less that an exact power of 2 + l = repP2 nl + r = repP2M1 nr + in l `seq` r `seq` PT l r -- BF=+1 +-- n is one less than an exact power of 2, I.E. 0,1,3,7,15.. +repP2M1 :: Int -> Tmp +repP2M1 0 = ET +repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` ZT sub sub + + +-- Substitute template values for real values taken from the IAList. This is for internal use only. +-- Length of IAList should match Template size +subst :: Tmp -> IAList a -> (# IntMap a, IAList a #) +subst ET as = (# E,as #) +subst (NT l r) as = subst_ N l r as +subst (ZT l r) as = subst_ Z l r as +subst (PT l r) as = subst_ P l r as +subst_ :: (Key -> IntMap a -> a -> IntMap a -> IntMap a) -> Tmp -> Tmp -> IAList a -> (# IntMap a, IAList a #) +{-# INLINE subst_ #-} +subst_ c l r as = case subst l as of + (# l_,as_ #) -> case as_ of + Cons ka a as__ -> case subst r as__ of + (# r_,as___ #) -> let t = c ka l_ a r_ + in t `seq` (# t,as___ #) + Empt -> error (mErr ++ "subst: List too short.") + +-- | See 'Map' class method 'difference'. +differenceIntMap :: IntMap a -> IntMap b -> IntMap a +differenceIntMap ta0 tb0 = d0 ta0 tb0 where + d0 E _ = E + d0 _ E = ta0 + d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here! + d0 (Z _ la _ _ ) _ = dH (addHeight 1# la) + d0 (P _ _ _ ra) _ = dH (addHeight 2# ra) + dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t + -- d :: Int# -> IntMap a -> -- 1st IntMap with height + -- IntMap b -> -- 2nd IntMap (without height) + -- (# Int#,IntMap a #) -- Output IntMap with height + ------------------------------------------------ + d ha E _ = (# E ,ha #) -- Relative heights!! + d ha ta E = (# ta,ha #) + d ha (N ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb + d ha (N ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb + d ha (N ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb rb + d ha (Z ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb + d ha (Z ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb + d ha (Z ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb rb + d ha (P ka la a ra) (N kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb + d ha (P ka la a ra) (Z kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb + d ha (P ka la a ra) (P kb lb _ rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb rb + d_ ka hla la a hra ra kb lb rb = + case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case fork hra ra kb of + (# hrla,rla,hrra,rra #) -> case spliceH ka la hla a rla hrla of + (# la_,hla_ #) -> case d hla_ la_ lb of + (# l,hl #) -> case d hrra rra rb of + (# r,hr #) -> joinH l hl r hr + -- ka = kb + EQ -> case d hra ra rb of -- right + (# r,hr #) -> case d hla la lb of -- left + (# l,hl #) -> joinH l hl r hr + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case fork hla la kb of + (# hlla,lla,hlra,lra #) -> case spliceH ka lra hlra a ra hra of + (# ra_,hra_ #) -> case d hra_ ra_ rb of + (# r,hr #) -> case d hlla lla lb of + (# l,hl #) -> joinH l hl r hr + -- fork :: Int# -> IntMap a -> Key -> (# Int#, IntMap a, Int#, IntMap a #) + fork hta ta kb = fork_ hta ta where + fork_ h E = (# h,E,h,E #) -- Relative heights!! + fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r + fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r + fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r + fork__ k hl l a hr r = case compareInt# k kb of + LT -> case fork_ hr r of + (# hx0,x0,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of + (# x0_,hx0_ #) -> (# hx0_,x0_,hx1,x1 #) + EQ -> (# hl,l,hr,r #) -- (k,a) is dropped. + GT -> case fork_ hl l of + (# hx0,x0,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of + (# x1_,hx1_ #) -> (# hx0,x0,hx1_,x1_ #) +----------------------------------------------------------------------- +--------------------- differenceIntMap Ends Here ----------------------- +----------------------------------------------------------------------- + +-- | See 'Map' class method 'differenceMaybe'. +differenceMaybeIntMap :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a +differenceMaybeIntMap f ta0 tb0 = d0 ta0 tb0 where + d0 E _ = E + d0 _ E = ta0 + d0 (N _ la _ _ ) _ = dH (addHeight 2# la) -- ?? As things are, we could use relative heights here! + d0 (Z _ la _ _ ) _ = dH (addHeight 1# la) + d0 (P _ _ _ ra) _ = dH (addHeight 2# ra) + dH hta0 = case d hta0 ta0 tb0 of (# t,_ #) -> t + -- d :: Int# -> IntMap a -> -- 1st IntMap with height + -- IntMap b -> -- 2nd IntMap (without height) + -- (# Int#,IntMap a #) -- Output IntMap with height + ------------------------------------------------ + d ha E _ = (# E ,ha #) -- Relative heights!! + d ha ta E = (# ta,ha #) + d ha (N ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb + d ha (N ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb + d ha (N ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#2#) la a ((ha)-#1#) ra kb lb b rb + d ha (Z ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb + d ha (Z ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb + d ha (Z ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#1#) ra kb lb b rb + d ha (P ka la a ra) (N kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb + d ha (P ka la a ra) (Z kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb + d ha (P ka la a ra) (P kb lb b rb) = d_ ka ((ha)-#1#) la a ((ha)-#2#) ra kb lb b rb + d_ ka hla la a hra ra kb lb b rb = + case compareInt# ka kb of + -- ka < kb, so (la < ka < kb) & (ka < kb < rb) + LT -> case fork hra ra kb b of + (# hrla,rla,mba,hrra,rra #) -> case spliceH ka la hla a rla hrla of + (# la_,hla_ #) -> case d hla_ la_ lb of + (# l,hl #) -> case d hrra rra rb of + (# r,hr #) -> case mba of + Nothing -> joinH l hl r hr + Just a' -> spliceH kb l hl a' r hr + -- ka = kb + EQ -> case d hra ra rb of -- right + (# r,hr #) -> case d hla la lb of -- left + (# l,hl #) -> case f a b of + Nothing -> joinH l hl r hr + Just a' -> spliceH kb l hl a' r hr + -- kb < ka, so (lb < kb < ka) & (kb < ka < ra) + GT -> case fork hla la kb b of + (# hlla,lla,mba,hlra,lra #) -> case spliceH ka lra hlra a ra hra of + (# ra_,hra_ #) -> case d hra_ ra_ rb of + (# r,hr #) -> case d hlla lla lb of + (# l,hl #) -> case mba of + Nothing -> joinH l hl r hr + Just a' -> spliceH kb l hl a' r hr + -- fork :: Int# -> IntMap a -> Key -> b -> (# Int#, IntMap a, Maybe a, Int#, IntMap a #) + fork hta ta kb b = fork_ hta ta where + fork_ h E = (# h,E,Nothing,h,E #) -- Relative heights!! + fork_ h (N k l a r) = fork__ k ((h)-#2#) l a ((h)-#1#) r + fork_ h (Z k l a r) = fork__ k ((h)-#1#) l a ((h)-#1#) r + fork_ h (P k l a r) = fork__ k ((h)-#1#) l a ((h)-#2#) r + fork__ k hl l a hr r = case compareInt# k kb of + LT -> case fork_ hr r of + (# hx0,x0,mba,hx1,x1 #) -> case spliceH k l hl a x0 hx0 of + (# x0_,hx0_ #) -> (# hx0_,x0_,mba,hx1,x1 #) + EQ -> let mba = f a b in mba `seq` (# hl,l,mba,hr,r #) + GT -> case fork_ hl l of + (# hx0,x0,mba,hx1,x1 #) -> case spliceH k x1 hx1 a r hr of + (# x1_,hx1_ #) -> (# hx0,x0,mba,hx1_,x1_ #) +----------------------------------------------------------------------- +------------------ differenceMaybeIntMap Ends Here --------------------- +----------------------------------------------------------------------- + +-- | Join two IntMaps of known height, returning an IntMap of known height. +-- It_s OK if heights are relative (I.E. if they share same fixed offset). +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +joinH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #) +joinH l hl r hr = + case compareInt# hl hr of + -- hr > hl + LT -> case l of + E -> (# r,hr #) + N li ll la lr -> case popRN li ll la lr of + (# l_,iv,v #) -> case l_ of + Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1 + _ -> spliceHL iv l_ hl v r hr -- dH= 0 + Z li ll la lr -> case popRZ li ll la lr of + (# l_,iv,v #) -> case l_ of + E -> pushHL l r hr -- l had only 1 element + _ -> spliceHL iv l_ hl v r hr -- dH=0 + P li ll la lr -> case popRP li ll la lr of + (# l_,iv,v #) -> case l_ of + Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1 + _ -> spliceHL iv l_ hl v r hr -- dH= 0 + -- hr = hl + EQ -> case l of + E -> (# l,hl #) -- r must be empty too + N li ll la lr -> case popRN li ll la lr of + (# l_,iv,v #) -> case l_ of + Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1 + _ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0 + Z li ll la lr -> case popRZ li ll la lr of + (# l_,iv,v #) -> case l_ of + E -> pushHL l r hr -- l had only 1 element + _ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0 + P li ll la lr -> case popRP li ll la lr of + (# l_,iv,v #) -> case l_ of + Z _ _ _ _ -> spliceHL iv l_ ((hl)-#1#) v r hr -- dH=-1 + _ -> (# Z iv l_ v r, ((hr)+#1#) #) -- dH= 0 + -- hl > hr + GT -> case r of + E -> (# l,hl #) + N ri rl ra rr -> case popLN ri rl ra rr of + (# iv,v,r_ #) -> case r_ of + Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1 + _ -> spliceHR iv l hl v r_ hr -- dH= 0 + Z ri rl ra rr -> case popLZ ri rl ra rr of + (# iv,v,r_ #) -> case r_ of + E -> pushHR l hl r -- r had only 1 element + _ -> spliceHR iv l hl v r_ hr -- dH=0 + P ri rl ra rr -> case popLP ri rl ra rr of + (# iv,v,r_ #) -> case r_ of + Z _ _ _ _ -> spliceHR iv l hl v r_ ((hr)-#1#) -- dH=-1 + _ -> spliceHR iv l hl v r_ hr -- dH= 0 + + +-- | Splice two IntMaps of known height using the supplied bridging association pair. +-- That is, the bridging pair appears \"in the middle\" of the resulting IntMap. +-- The pairs of the first tree argument are to the left of the bridging pair and +-- the pairs of the second tree are to the right of the bridging pair. +-- +-- This function does not require that the IntMap heights are absolutely correct, only that +-- the difference in supplied heights is equal to the difference in actual heights. So it_s +-- OK if the input heights both have the same unknown constant offset. (The output height +-- will also have the same constant offset in this case.) +-- +-- Complexity: O(d), where d is the absolute difference in tree heights. +spliceH :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #) +-- You_d think inlining this function would make a significant difference to many functions +-- (such as set operations), but it doesn_t. It makes them marginally slower!! +spliceH ib l hl b r hr = + case compareInt# hl hr of + LT -> spliceHL ib l hl b r hr + EQ -> (# Z ib l b r, ((hl)+#1#) #) + GT -> spliceHR ib l hl b r hr + +----------------------------------------------------------------------- +----------------------------- spliceHL -------------------------------- +----------------------------------------------------------------------- +-- Splice tree s into the left edge of tree t (where ht>hs) using the supplied bridging pair (ib,b), +-- returning another tree of known relative height. +spliceHL :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #) +spliceHL ib s hs b t ht = let d = ((ht)-#(hs)) + in if d ==# 1# then (# N ib s b t, ((ht)+#1#) #) + else sHL ht d t + where -- s, ib and b are free + + -- Splice two trees of known relative height where hr>hl+1, using the supplied bridging element, + -- returning another tree of known relative height. d >= 2 + {-# INLINE sHL #-} + sHL _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl + sHL hr d (N ri rl ra rr) = let r_ = sLN ((d)-#2#) ri rl ra rr + in r_ `seq` (# r_,hr #) + sHL hr d (Z ri rl ra rr) = let r_ = sLZ ((d)-#1#) ri rl ra rr + in case r_ of + E -> error "spliceHL: Bug1" + Z _ _ _ _ -> (# r_, hr #) + _ -> (# r_,((hr)+#1#) #) + sHL hr d (P ri rl ra rr) = let r_ = sLP ((d)-#1#) ri rl ra rr + in r_ `seq` (# r_,hr #) + + -- Splice into left subtree of (N i l a r), height cannot change as a result of this + sLN 0# i l a r = Z i (Z ib s b l) a r -- dH=0 + sLN 1# i l a r = Z i (N ib s b l) a r -- dH=0 + sLN d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` N i l_ a r + sLN d i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr + in case l_ of + Z _ _ _ _ -> N i l_ a r -- dH=0 + P _ _ _ _ -> Z i l_ a r -- dH=0 + _ -> error "spliceHL: Bug2" -- impossible + sLN d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` N i l_ a r + sLN _ _ E _ _ = error "spliceHL: Bug3" -- impossible + + -- Splice into left subtree of (Z i l a r), Z->P if dH=1, Z->Z if dH=0 + sLZ 1# i l a r = P i (N ib s b l) a r -- Z->P, dH=1 + sLZ d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0 + sLZ d i (Z li ll la lr) a r = let l_ = sLZ ((d)-#1#) li ll la lr + in case l_ of + Z _ _ _ _ -> Z i l_ a r -- Z->Z, dH=0 + P _ _ _ _ -> P i l_ a r -- Z->P, dH=1 + _ -> error "spliceHL: Bug4" -- impossible + sLZ d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` Z i l_ a r -- Z->Z, dH=0 + sLZ _ _ E _ _ = error "spliceHL: Bug5" -- impossible + + -- Splice into left subtree of (P i l a r), height cannot change as a result of this + sLP 1# i (N li ll la lr) a r = Z li (P ib s b ll) la (Z i lr a r) -- dH=0 + sLP 1# i (Z li ll la lr) a r = Z li (Z ib s b ll) la (Z i lr a r) -- dH=0 + sLP 1# i (P li ll la lr) a r = Z li (Z ib s b ll) la (N i lr a r) -- dH=0 + sLP d i (N li ll la lr) a r = let l_ = sLN ((d)-#2#) li ll la lr in l_ `seq` P i l_ a r -- dH=0 + sLP d i (Z li ll la lr) a r = sLPZ ((d)-#1#) i li ll la lr a r -- dH=0 + sLP d i (P li ll la lr) a r = let l_ = sLP ((d)-#1#) li ll la lr in l_ `seq` P i l_ a r -- dH=0 + sLP _ _ E _ _ = error "spliceHL: Bug6" + + -- Splice into left subtree of (P i (Z li ll la lr) a r) + {-# INLINE sLPZ #-} + sLPZ 1# i li ll la lr a r = Z li (N ib s b ll) la (Z i lr a r) -- dH=0 + sLPZ d i li (N lli lll lle llr) la lr a r = let ll_ = sLN ((d)-#2#) lli lll lle llr -- dH=0 + in ll_ `seq` P i (Z li ll_ la lr) a r + sLPZ d i li (Z lli lll lle llr) la lr a r = let ll_ = sLZ ((d)-#1#) lli lll lle llr -- dH=0 + in case ll_ of + Z _ _ _ _ -> P i (Z li ll_ la lr) a r -- dH=0 + P _ _ _ _ -> Z li ll_ la (Z i lr a r) -- dH=0 + _ -> error "spliceHL: Bug7" -- impossible + sLPZ d i li (P lli lll lle llr) la lr a r = let ll_ = sLP ((d)-#1#) lli lll lle llr -- dH=0 + in ll_ `seq` P i (Z li ll_ la lr) a r + sLPZ _ _ _ E _ _ _ _ = error "spliceHL: Bug8" +----------------------------------------------------------------------- +------------------------- spliceHL Ends Here -------------------------- +----------------------------------------------------------------------- + +----------------------------------------------------------------------- +----------------------------- spliceHR -------------------------------- +----------------------------------------------------------------------- +-- Splice tree t into the right edge of tree s (where hs>ht) using the supplied bridging pair (ib,b), +-- returning another tree of known relative height. +spliceHR :: Key -> IntMap a -> Int# -> a -> IntMap a -> Int# -> (# IntMap a,Int# #) +spliceHR ib s hs b t ht = let d = ((hs)-#(ht)) + in if d ==# 1# then (# P ib s b t, ((hs)+#1#) #) + else sHR hs d s + where -- t, ib and b are free + + {-# INLINE sHR #-} + sHR _ _ E = error "spliceHL: Bug0" -- impossible if hl>hr + sHR hl d (N li ll la lr) = let l_ = sRN ((d)-#1#) li ll la lr + in l_ `seq` (# l_,hl #) + sHR hl d (Z li ll la lr) = let l_ = sRZ ((d)-#1#) li ll la lr + in case l_ of + E -> error "spliceHL: Bug1" + Z _ _ _ _ -> (# l_, hl #) + _ -> (# l_,((hl)+#1#) #) + sHR hl d (P li ll la lr) = let l_ = sRP ((d)-#2#) li ll la lr + in l_ `seq` (# l_,hl #) + + -- Splice into right subtree of (P i l a r), height cannot change as a result of this + sRP 0# i l a r = Z i l a (Z ib r b t) -- dH=0 + sRP 1# i l a r = Z i l a (P ib r b t) -- dH=0 + sRP d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` P i l a r_ + sRP d i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr + in case r_ of + Z _ _ _ _ -> P i l a r_ -- dH=0 + N _ _ _ _ -> Z i l a r_ -- dH=0 + _ -> error "spliceHL: Bug2" -- impossible + sRP d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` P i l a r_ + sRP _ _ _ _ E = error "spliceHL: Bug3" -- impossible + + -- Splice into right subtree of (Z i l a r), Z->N if dH=1, Z->Z if dH=0 + sRZ 1# i l a r = N i l a (P ib r b t) -- Z->N, dH=1 + sRZ d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0 + sRZ d i l a (Z ri rl ra rr) = let r_ = sRZ ((d)-#1#) ri rl ra rr + in case r_ of + Z _ _ _ _ -> Z i l a r_ -- Z->Z, dH=0 + N _ _ _ _ -> N i l a r_ -- Z->N, dH=1 + _ -> error "spliceHL: Bug4" -- impossible + sRZ d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` Z i l a r_ -- Z->Z, dH=0 + sRZ _ _ _ _ E = error "spliceHL: Bug5" -- impossible + + -- Splice into right subtree of (N i l a r), height cannot change as a result of this + sRN 1# i l a (N ri rl ra rr) = Z ri (P i l a rl) ra (Z ib rr b t) -- dH=0 + sRN 1# i l a (Z ri rl ra rr) = Z ri (Z i l a rl) ra (Z ib rr b t) -- dH=0 + sRN 1# i l a (P ri rl ra rr) = Z ri (Z i l a rl) ra (N ib rr b t) -- dH=0 + sRN d i l a (N ri rl ra rr) = let r_ = sRN ((d)-#1#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0 + sRN d i l a (Z ri rl ra rr) = sRNZ ((d)-#1#) i l a ri rl ra rr -- dH=0 + sRN d i l a (P ri rl ra rr) = let r_ = sRP ((d)-#2#) ri rl ra rr in r_ `seq` N i l a r_ -- dH=0 + sRN _ _ _ _ E = error "spliceHL: Bug6" + + -- Splice into right subtree of (N i l a (Z ri rl ra rr)) + {-# INLINE sRNZ #-} + sRNZ 1# i l a ri rl ra rr = Z ri (Z i l a rl) ra (P ib rr b t) -- dH=0 + sRNZ d i l a ri rl ra (N rri rrl rre rrr) = let rr_ = sRN ((d)-#1#) rri rrl rre rrr + in rr_ `seq` N i l a (Z ri rl ra rr_) -- dH=0 + sRNZ d i l a ri rl ra (Z rri rrl rre rrr) = let rr_ = sRZ ((d)-#1#) rri rrl rre rrr -- dH=0 + in case rr_ of + Z _ _ _ _ -> N i l a (Z ri rl ra rr_) -- dH=0 + N _ _ _ _ -> Z ri (Z i l a rl) ra rr_ -- dH=0 + _ -> error "spliceHL: Bug7" -- impossible + sRNZ d i l a ri rl ra (P rri rrl rre rrr) = let rr_ = sRP ((d)-#2#) rri rrl rre rrr -- dH=0 + in rr_ `seq` N i l a (Z ri rl ra rr_) + sRNZ _ _ _ _ _ _ _ E = error "spliceHL: Bug8" +----------------------------------------------------------------------- +------------------------- spliceHR Ends Here -------------------------- +----------------------------------------------------------------------- + + +-- | Push a singleton IntMap to the leftmost position of an IntMap of known height. +-- Returns an IntMap of known height. +-- It_s OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +pushHL :: IntMap a -> IntMap a -> Int# -> (# IntMap a,Int# #) +pushHL t0 t h = case t of + E -> (# t0, ((h)+#1#) #) -- Relative Heights + N i l a r -> let t_ = potNL i l a r in t_ `seq` (# t_,h #) + P i l a r -> let t_ = potPL i l a r in t_ `seq` (# t_,h #) + Z i l a r -> let t_ = potZL i l a r + in case t_ of + Z _ _ _ _ -> (# t_, h #) + P _ _ _ _ -> (# t_, ((h)+#1#) #) + _ -> error "pushHL: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- potNL, potZL, potPL -- + ----------------------------------------------------------------------- + + -- (potNL i l a r): Put t0 in L subtree of (N i l a r), BF=-1 (Never requires rebalancing) , (never returns P) + potNL i E a r = Z i t0 a r -- L subtree empty, H:0->1, parent BF:-1-> 0 + potNL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l_ `seq` N i l_ a r + potNL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l_ `seq` N i l_ a r + potNL i (Z li ll la lr) a r = let l_ = potZL li ll la lr -- L subtree BF= 0, so need to look for changes + in case l_ of + Z _ _ _ _ -> N i l_ a r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + P _ _ _ _ -> Z i l_ a r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0 + _ -> error "pushHL: Bug1" -- impossible + + -- (potZL i l a r): Put t0 in L subtree of (Z i l a r), BF= 0 (Never requires rebalancing) , (never returns N) + potZL i E a r = P i t0 a r -- L subtree H:0->1, parent BF: 0->+1 + potZL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l_ `seq` Z i l_ a r + potZL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l_ `seq` Z i l_ a r + potZL i (Z li ll la lr) a r = let l_ = potZL li ll la lr -- L subtree BF= 0, so need to look for changes + in case l_ of + Z _ _ _ _ -> Z i l_ a r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ _ -> error "pushHL: Bug2" -- impossible + _ -> P i l_ a r -- L subtree BF: 0->+1, H:h->h+1, parent BF: 0->+1 + + -------- This case (PL) may need rebalancing if it goes to LEVEL 3 --------- + + -- (potPL i l a r): Put t0 in L subtree of (P i l a r), BF=+1 , (never returns N) + potPL _ E _ _ = error "pushHL: Bug3" -- impossible if BF=+1 + potPL i (N li ll la lr) a r = let l_ = potNL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l_ `seq` P i l_ a r + potPL i (P li ll la lr) a r = let l_ = potPL li ll la lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l_ `seq` P i l_ a r + potPL i (Z li ll la lr) a r = potPLL i li ll la lr a r -- LL (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- potPLL -- + ----------------------------------------------------------------------- + + -- (potPLL i li ll la lr a r): Put t0 in LL subtree of (P i (Z li ll la lr) a r) , (never returns N) + {-# INLINE potPLL #-} + potPLL i li E la lr a r = Z li t0 la (Z i lr a r) -- r and lr must also be E, special CASE LL!! + potPLL i li (N lli lll lla llr) la lr a r = let ll_ = potNL lli lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll_ `seq` P i (Z li ll_ la lr) a r + potPLL i li (P lli lll lla llr) la lr a r = let ll_ = potPL lli lll lla llr -- LL subtree BF<>0, H:h->h, so no change + in ll_ `seq` P i (Z li ll_ la lr) a r + potPLL i li (Z lli lll lla llr) la lr a r = let ll_ = potZL lli lll lla llr -- LL subtree BF= 0, so need to look for changes + in case ll_ of + Z _ _ _ _ -> P i (Z li ll_ la lr) a r -- LL subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ _ -> error "pushHL: Bug4" -- impossible + _ -> Z li ll_ la (Z i lr a r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !! +----------------------------------------------------------------------- +-------------------------- pushHL Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- | Push a singleton IntMap to the rightmost position of an IntMap of known height. +-- Returns an IntMap of known height. +-- It_s OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +pushHR :: IntMap a -> Int# -> IntMap a -> (# IntMap a,Int# #) +pushHR t h t0 = case t of + E -> (# t0, ((h)+#1#) #) -- Relative Heights + N i l a r -> let t_ = potNR i l a r in t_ `seq` (# t_,h #) + P i l a r -> let t_ = potPR i l a r in t_ `seq` (# t_,h #) + Z i l a r -> let t_ = potZR i l a r + in case t_ of + Z _ _ _ _ -> (# t_, h #) + N _ _ _ _ -> (# t_, ((h)+#1#) #) + _ -> error "pushHR: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- potNR, potZR, potPR -- + ----------------------------------------------------------------------- + + -- (potZR i l a r): Put t0 in R subtree of (Z i l a r), BF= 0 (Never requires rebalancing) , (never returns P) + potZR i l a E = N i l a t0 -- R subtree H:0->1, parent BF: 0->-1 + potZR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r_ `seq` Z i l a r_ + potZR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r_ `seq` Z i l a r_ + potZR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr -- R subtree BF= 0, so need to look for changes + in case r_ of + Z _ _ _ _ -> Z i l a r_ -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ _ -> N i l a r_ -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1 + _ -> error "pushHR: Bug1" -- impossible + + -- (potPR i l a r): Put t0 in R subtree of (P i l a r), BF=+1 (Never requires rebalancing) , (never returns N) + potPR i l a E = Z i l a t0 -- R subtree empty, H:0->1, parent BF:+1-> 0 + potPR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r_ `seq` P i l a r_ + potPR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r_ `seq` P i l a r_ + potPR i l a (Z ri rl ra rr) = let r_ = potZR ri rl ra rr -- R subtree BF= 0, so need to look for changes + in case r_ of + Z _ _ _ _ -> P i l a r_ -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + N _ _ _ _ -> Z i l a r_ -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0 + _ -> error "pushHR: Bug2" -- impossible + + -------- This case (NR) may need rebalancing if it goes to LEVEL 3 --------- + + -- (potNR i l a r): Put t0 in R subtree of (N i l a r), BF=-1 , (never returns P) + potNR _ _ _ E = error "pushHR: Bug3" -- impossible if BF=-1 + potNR i l a (N ri rl ra rr) = let r_ = potNR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r_ `seq` N i l a r_ + potNR i l a (P ri rl ra rr) = let r_ = potPR ri rl ra rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r_ `seq` N i l a r_ + potNR i l a (Z ri rl ra rr) = potNRR i l a ri rl ra rr -- RR (never returns P) + + ----------------------------- LEVEL 3 --------------------------------- + -- potNRR -- + ----------------------------------------------------------------------- + + -- (potNRR i l a ri rl ra rr): Put t0 in RR subtree of (N i l a (Z ri rl ra rr)) , (never returns P) + {-# INLINE potNRR #-} + potNRR i l a ri rl ra E = Z ri (Z i l a rl) ra t0 -- l and rl must also be E, special CASE RR!! + potNRR i l a ri rl ra (N rri rrl rra rrr) = let rr_ = potNR rri rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr_ `seq` N i l a (Z ri rl ra rr_) + potNRR i l a ri rl ra (P rri rrl rra rrr) = let rr_ = potPR rri rrl rra rrr -- RR subtree BF<>0, H:h->h, so no change + in rr_ `seq` N i l a (Z ri rl ra rr_) + potNRR i l a ri rl ra (Z rri rrl rra rrr) = let rr_ = potZR rri rrl rra rrr -- RR subtree BF= 0, so need to look for changes + in case rr_ of + Z _ _ _ _ -> N i l a (Z ri rl ra rr_) -- RR subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ _ -> Z ri (Z i l a rl) ra rr_ -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + _ -> error "pushHR: Bug4" -- impossible +----------------------------------------------------------------------- +-------------------------- pushHR Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | Delete the association pair with the supplied Key from an IntMap. +-- For use only if it is already known to contain an entry for the supplied key. +-- This function raises an error if there is no such pair. +del :: Key -> IntMap a -> IntMap a +del _ E = error "del: Key not found." +del k0 (N k l a r) = delN k0 k l a r +del k0 (Z k l a r) = delZ k0 k l a r +del k0 (P k l a r) = delP k0 k l a r + +-- | Same as 'del', but takes the (relative) tree height as an extra argument and +-- returns the updated (relative) tree height. +delH :: Key -> Int# -> IntMap a -> (# IntMap a,Int# #) +delH _ _ E = error "delH: Key not found." +delH k0 ht (N k l a r) = let t_ = delN k0 k l a r in + case t_ of + Z _ _ _ _ -> (# t_,((ht)-#1#) #) + _ -> (# t_, ht #) +delH k0 ht (Z k l a r) = let t_ = delZ k0 k l a r in + case t_ of + E -> (# t_,((ht)-#1#) #) + _ -> (# t_, ht #) +delH k0 ht (P k l a r) = let t_ = delP k0 k l a r in + case t_ of + Z _ _ _ _ -> (# t_,((ht)-#1#) #) + _ -> (# t_, ht #) + +----------------------------- LEVEL 1 --------------------------------- +-- delN, delZ, delP -- +----------------------------------------------------------------------- + +-- Delete from (N k l a r) +delN :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delN k0 k l a r = case compareInt# k0 k of + LT -> delNL k0 k l a r + EQ -> subN l r + GT -> delNR k0 k l a r + +-- Delete from (Z k l a r) +delZ :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delZ k0 k l a r = case compareInt# k0 k of + LT -> delZL k0 k l a r + EQ -> subZR l r + GT -> delZR k0 k l a r + +-- Delete from (P k l a r) +delP :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delP k0 k l a r = case compareInt# k0 k of + LT -> delPL k0 k l a r + EQ -> subP l r + GT -> delPR k0 k l a r + +----------------------------- LEVEL 2 --------------------------------- +-- delNL, delZL, delPL -- +-- delNR, delZR, delPR -- +----------------------------------------------------------------------- + +-- Delete from the left subtree of (N k l a r) +delNL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delNL _ _ E _ _ = error "assertDelete: Key not found." -- Left sub-tree is empty +delNL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLN k (delNL k0 lk ll la lr) a r + EQ -> chkLN k (subN ll lr) a r + GT -> chkLN k (delNR k0 lk ll la lr) a r +delNL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of + LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` N k l_ a r -- height can't change + EQ -> chkLN_ k (subZR ll lr) a r -- << But it can here + GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` N k l_ a r -- height can't change +delNL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLN k (delPL k0 lk ll la lr) a r + EQ -> chkLN k (subP ll lr) a r + GT -> chkLN k (delPR k0 lk ll la lr) a r + +-- Delete from the right subtree of (N k l a r) +delNR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delNR _ _ _ _ E = error "delNR: Bug0" -- Impossible +delNR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRN k l a (delNL k0 rk rl ra rr) + EQ -> chkRN k l a (subN rl rr) + GT -> chkRN k l a (delNR k0 rk rl ra rr) +delNR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of + LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` N k l a r_ -- height can't change + EQ -> chkRN_ k l a (subZL rl rr) -- << But it can here + GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` N k l a r_ -- height can't change +delNR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRN k l a (delPL k0 rk rl ra rr) + EQ -> chkRN k l a (subP rl rr) + GT -> chkRN k l a (delPR k0 rk rl ra rr) + +-- Delete from the left subtree of (Z k l a r) +delZL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delZL _ _ E _ _ = error "assertDelete: Key not found." -- Left sub-tree is empty +delZL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLZ k (delNL k0 lk ll la lr) a r + EQ -> chkLZ k (subN ll lr) a r + GT -> chkLZ k (delNR k0 lk ll la lr) a r +delZL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of + LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` Z k l_ a r -- height can't change + EQ -> chkLZ_ k (subZR ll lr) a r -- << But it can here + GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` Z k l_ a r -- height can't change +delZL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLZ k (delPL k0 lk ll la lr) a r + EQ -> chkLZ k (subP ll lr) a r + GT -> chkLZ k (delPR k0 lk ll la lr) a r + +-- Delete from the right subtree of (Z k l a r) +delZR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delZR _ _ _ _ E = error "assertDelete: Key not found." -- Right sub-tree is empty +delZR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRZ k l a (delNL k0 rk rl ra rr) + EQ -> chkRZ k l a (subN rl rr) + GT -> chkRZ k l a (delNR k0 rk rl ra rr) +delZR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of + LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` Z k l a r_ -- height can't change + EQ -> chkRZ_ k l a (subZL rl rr) -- << But it can here + GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` Z k l a r_ -- height can't change +delZR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRZ k l a (delPL k0 rk rl ra rr) + EQ -> chkRZ k l a (subP rl rr) + GT -> chkRZ k l a (delPR k0 rk rl ra rr) + +-- Delete from the left subtree of (P k l a r) +delPL :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delPL _ _ E _ _ = error "delPL: Bug0" -- Impossible +delPL k0 k (N lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLP k (delNL k0 lk ll la lr) a r + EQ -> chkLP k (subN ll lr) a r + GT -> chkLP k (delNR k0 lk ll la lr) a r +delPL k0 k (Z lk ll la lr) a r = case compareInt# k0 lk of + LT -> let l_ = delZL k0 lk ll la lr in l_ `seq` P k l_ a r -- height can't change + EQ -> chkLP_ k (subZR ll lr) a r -- << But it can here + GT -> let l_ = delZR k0 lk ll la lr in l_ `seq` P k l_ a r -- height can't change +delPL k0 k (P lk ll la lr) a r = case compareInt# k0 lk of + LT -> chkLP k (delPL k0 lk ll la lr) a r + EQ -> chkLP k (subP ll lr) a r + GT -> chkLP k (delPR k0 lk ll la lr) a r + +-- Delete from the right subtree of (P l a r) +delPR :: Key -> Key -> IntMap a -> a -> IntMap a -> IntMap a +delPR _ _ _ _ E = error "assertDelete: Key not found." -- Right sub-tree is empty +delPR k0 k l a (N rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRP k l a (delNL k0 rk rl ra rr) + EQ -> chkRP k l a (subN rl rr) + GT -> chkRP k l a (delNR k0 rk rl ra rr) +delPR k0 k l a (Z rk rl ra rr) = case compareInt# k0 rk of + LT -> let r_ = delZL k0 rk rl ra rr in r_ `seq` P k l a r_ -- height can't change + EQ -> chkRP_ k l a (subZL rl rr) -- << But it can here + GT -> let r_ = delZR k0 rk rl ra rr in r_ `seq` P k l a r_ -- height can't change +delPR k0 k l a (P rk rl ra rr) = case compareInt# k0 rk of + LT -> chkRP k l a (delPL k0 rk rl ra rr) + EQ -> chkRP k l a (subP rl rr) + GT -> chkRP k l a (delPR k0 rk rl ra rr) +----------------------------------------------------------------------- +------------------------- del/delH End Here --------------------------- +----------------------------------------------------------------------- + + +----------------------------------------------------------------------- +------------------------ popL Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popL LEVEL 1 ------------------------------- +-- popLN, popLZ, popLP -- +----------------------------------------------------------------------- +-- Delete leftmost from (N k l a r) +popLN :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLN k E a r = (# k,a,r #) -- Terminal case, r must be of form (Z a ra E) +popLN k (N lk ll la lr) a r = case popLN lk ll la lr of + (# iv,v,l #) -> let t = chkLN k l a r in t `seq` (# iv,v,t #) +popLN k (Z lk ll la lr) a r = popLNZ k lk ll la lr a r +popLN k (P lk ll la lr) a r = case popLP lk ll la lr of + (# iv,v,l #) -> let t = chkLN k l a r in t `seq` (# iv,v,t #) + +-- Delete leftmost from (Z k l a r) +popLZ :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLZ k E a _ = (# k,a,E #) -- Terminal case, r must be E +popLZ k (N lk ll la lr) a r = popLZN k lk ll la lr a r +popLZ k (Z lk ll la lr) a r = popLZZ k lk ll la lr a r +popLZ k (P lk ll la lr) a r = popLZP k lk ll la lr a r + +-- Delete leftmost from (P k l a r) +popLP :: Key -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLP _ E _ _ = error "popLP: Bug!" -- Impossible if BF=+1 +popLP k (N lk ll la lr) a r = case popLN lk ll la lr of + (# iv,v,l #) -> let t = chkLP k l a r in t `seq` (# iv,v,t #) +popLP k (Z lk ll la lr) a r = popLPZ k lk ll la lr a r +popLP k (P lk ll la lr) a r = case popLP lk ll la lr of + (# iv,v,l #) -> let t = chkLP k l a r in t `seq` (# iv,v,t #) + +-------------------------- popL LEVEL 2 ------------------------------- +-- popLNZ, popLZZ, popLPZ -- +-- popLZN, popLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N k (Z lk ll la lr) a r), height of left sub-tree can't change in this case +popLNZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +{-# INLINE popLNZ #-} +popLNZ k lk E la _ a r = let t = rebalN k E a r -- Terminal case, Needs rebalancing + in t `seq` (# lk,la,t #) +popLNZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,N k l a r #) +popLNZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,N k l a r #) +popLNZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,N k l a r #) + +-- Delete leftmost from (Z k (Z lk ll la lr) a r), height of left sub-tree can't change in this case +-- Don't INLINE this! +popLZZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLZZ k lk E la _ a r = (# lk,la,N k E a r #) -- Terminal case +popLZZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,Z k l a r #) +popLZZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,Z k l a r #) +popLZZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,Z k l a r #) + +-- Delete leftmost from (P k (Z lk ll la lr) a r), height of left sub-tree can't change in this case +popLPZ :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +{-# INLINE popLPZ #-} +popLPZ k lk E la _ a _ = (# lk,la,Z k E a E #) -- Terminal case +popLPZ k lk (N llk lll lla llr) la lr a r = case popLZN lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,P k l a r #) +popLPZ k lk (Z llk lll lla llr) la lr a r = case popLZZ lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,P k l a r #) +popLPZ k lk (P llk lll lla llr) la lr a r = case popLZP lk llk lll lla llr la lr of + (# iv,v,l #) -> (# iv,v,P k l a r #) + +-- Delete leftmost from (Z k (N lk ll la lr) a r) +-- Don't INLINE this! +popLZN :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLZN k lk ll la lr a r = case popLN lk ll la lr of + (# iv,v,l #) -> let t = chkLZ k l a r in t `seq` (# iv,v,t #) +-- Delete leftmost from (Z k (P lk ll la lr) a r) +-- Don't INLINE this! +popLZP :: Key -> Key -> IntMap a -> a -> IntMap a -> a -> IntMap a -> (# Key,a,IntMap a #) +popLZP k lk ll la lr a r = case popLP lk ll la lr of + (# iv,v,l #) -> let t = chkLZ k l a r in t `seq` (# iv,v,t #) +----------------------------------------------------------------------- +-------------------------- popL Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ popR Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popR LEVEL 1 ------------------------------- +-- popRN, popRZ, popRP -- +----------------------------------------------------------------------- +-- Delete rightmost from (N k l a r) +popRN :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRN _ _ _ E = error "popRN: Bug!" -- Impossible if BF=-1 +popRN k l a (N rk rl ra rr) = case popRN rk rl ra rr of + (# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #) +popRN k l a (Z rk rl ra rr) = popRNZ k l a rk rl ra rr +popRN k l a (P rk rl ra rr) = case popRP rk rl ra rr of + (# r,iv,v #) -> let t = chkRN k l a r in t `seq` (# t,iv,v #) + +-- Delete rightmost from (Z k l a r) +popRZ :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRZ k _ a E = (# E,k,a #) -- Terminal case, l must be E +popRZ k l a (N rk rl ra rr) = popRZN k l a rk rl ra rr +popRZ k l a (Z rk rl ra rr) = popRZZ k l a rk rl ra rr +popRZ k l a (P rk rl ra rr) = popRZP k l a rk rl ra rr + +-- Delete rightmost from (P k l a r) +popRP :: Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRP k l a E = (# l,k,a #) -- Terminal case, l must be of form (Z a la E) +popRP k l a (N rk rl ra rr) = case popRN rk rl ra rr of + (# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #) +popRP k l a (Z rk rl ra rr) = popRPZ k l a rk rl ra rr +popRP k l a (P rk rl ra rr) = case popRP rk rl ra rr of + (# r,iv,v #) -> let t = chkRP k l a r in t `seq` (# t,iv,v #) + +-------------------------- popR LEVEL 2 ------------------------------- +-- popRNZ, popRZZ, popRPZ -- +-- popRZN, popRZP -- +----------------------------------------------------------------------- + +-- Delete rightmost from (N k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case +popRNZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +{-# INLINE popRNZ #-} +popRNZ k _ a rk _ ra E = (# Z k E a E,rk,ra #) -- Terminal case +popRNZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# N k l a r,iv,v #) +popRNZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# N k l a r,iv,v #) +popRNZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# N k l a r,iv,v #) + +-- Delete rightmost from (Z k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case +-- Don't INLINE this! +popRZZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRZZ k l a rk _ ra E = (# P k l a E,rk,ra #) -- Terminal case +popRZZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# Z k l a r,iv,v #) +popRZZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# Z k l a r,iv,v #) +popRZZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# Z k l a r,iv,v #) + +-- Delete rightmost from (P k l a (Z rk rl ra rr)), height of right sub-tree can't change in this case +popRPZ :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +{-# INLINE popRPZ #-} +popRPZ k l a rk _ ra E = let t = rebalP k l a E -- Terminal case, Needs rebalancing + in t `seq` (# t,rk,ra #) +popRPZ k l a rk rl ra (N rrk rrl rra rrr) = case popRZN rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# P k l a r,iv,v #) +popRPZ k l a rk rl ra (Z rrk rrl rra rrr) = case popRZZ rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# P k l a r,iv,v #) +popRPZ k l a rk rl ra (P rrk rrl rra rrr) = case popRZP rk rl ra rrk rrl rra rrr of + (# r,iv,v #) -> (# P k l a r,iv,v #) + +-- Delete rightmost from (Z k l a (N rk rl ra rr)) +-- Don't INLINE this! +popRZN :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRZN k l a rk rl ra rr = case popRN rk rl ra rr of + (# r,iv,v #) -> let t = chkRZ k l a r in t `seq` (# t,iv,v #) + +-- Delete rightmost from (Z k l a (P rk rl ra rr)) +-- Don't INLINE this! +popRZP :: Key -> IntMap a -> a -> Key -> IntMap a -> a -> IntMap a -> (# IntMap a, Key, a #) +popRZP k l a rk rl ra rr = case popRP rk rl ra rr of + (# r,iv,v #) -> let t = chkRZ k l a r in t `seq` (# t,iv,v #) +----------------------------------------------------------------------- +-------------------------- popR Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +{-************************** Balancing Utilities Below Here ************************************-} + +-- Rebalance a tree of form (N k l a r) which has become unbalanced as +-- a result of the height of the left sub-tree (l) decreasing by 1. +-- N.B Result is never of form (N _ _ _ _) (or E!) +rebalN :: Key -> IntMap a -> a -> IntMap a -> IntMap a +rebalN _ _ _ E = error "rebalN: Bug0" -- impossible case +rebalN k l a (N rk rl ra rr) = Z rk (Z k l a rl) ra rr -- N->Z, dH=-1 +rebalN k l a (Z rk rl ra rr) = P rk (N k l a rl) ra rr -- N->P, dH= 0 +rebalN _ _ _ (P _ E _ _ ) = error "rebalN: Bug1" -- impossible case +rebalN k l a (P rk (N rlk rll rla rlr) ra rr) = Z rlk (P k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1 +rebalN k l a (P rk (Z rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (Z rk rlr ra rr) -- N->Z, dH=-1 +rebalN k l a (P rk (P rlk rll rla rlr) ra rr) = Z rlk (Z k l a rll) rla (N rk rlr ra rr) -- N->Z, dH=-1 + +-- Rebalance a tree of form (P k l a r) which has become unbalanced as +-- a result of the height of the right sub-tree (r) decreasing by 1. +-- N.B Result is never of form (P _ _ _ _) (or E!) +rebalP :: Key -> IntMap a -> a -> IntMap a -> IntMap a +rebalP _ E _ _ = error "rebalP: Bug0" -- impossible case +rebalP k (P lk ll la lr ) a r = Z lk ll la (Z k lr a r) -- P->Z, dH=-1 +rebalP k (Z lk ll la lr ) a r = N lk ll la (P k lr a r) -- P->N, dH= 0 +rebalP _ (N _ _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case +rebalP k (N lk ll la (P lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (N k lrr a r) -- P->Z, dH=-1 +rebalP k (N lk ll la (Z lrk lrl lra lrr)) a r = Z lrk (Z lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1 +rebalP k (N lk ll la (N lrk lrl lra lrr)) a r = Z lrk (P lk ll la lrl) lra (Z k lrr a r) -- P->Z, dH=-1 + +-- Check for height changes in left subtree of (N k l a r), +-- where l was (N lk ll la lr) or (P lk ll la lr) +chkLN :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLN k l a r = case l of + E -> error "chkLN: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> N k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> rebalN k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> N k l a r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (Z k l a r), +-- where l was (N lk ll la lr) or (P lk ll la lr) +chkLZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLZ k l a r = case l of + E -> error "chkLZ: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> Z k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> N k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> Z k l a r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (P k l a r), +-- where l was (N lk ll la lr) or (P lk ll la lr) +chkLP :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLP k l a r = case l of + E -> error "chkLP: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> P k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> Z k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> P k l a r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (N k l a r), +-- where r was (N rk rl ra rr) or (P rk rl ra rr) +chkRN :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRN k l a r = case r of + E -> error "chkRN: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> N k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> Z k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> N k l a r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (Z k l a r), +-- where r was (N rk rl ra rr) or (P rk rl ra rr) +chkRZ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRZ k l a r = case r of + E -> error "chkRZ: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> Z k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> P k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> Z k l a r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (P k l a r), +-- where l was (N rk rl ra rr) or (P rk rl ra rr) +chkRP :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRP k l a r = case r of + E -> error "chkRP: Bug0" -- impossible if BF<>0 + N _ _ _ _ -> P k l a r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ _ -> rebalP k l a r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ _ -> P k l a r -- BF +/-1 -> +1, so dH= 0 + + +-- Substitute deleted element from (N _ l _ r) +subN :: IntMap a -> IntMap a -> IntMap a +subN _ E = error "subN: Bug0" -- Impossible +subN l (N rk rl ra rr) = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRN iv l v r_ +subN l (Z rk rl ra rr) = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRN_ iv l v r_ +subN l (P rk rl ra rr) = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRN iv l v r_ + +-- Substitute deleted element from (Z _ l _ r) +-- Pops the replacement from the right sub-tree, so result may be (P _ _ _) +subZR :: IntMap a -> IntMap a -> IntMap a +subZR _ E = E -- Both left and right subtrees must have been empty +subZR l (N rk rl ra rr) = case popLN rk rl ra rr of (# iv,v,r_ #) -> chkRZ iv l v r_ +subZR l (Z rk rl ra rr) = case popLZ rk rl ra rr of (# iv,v,r_ #) -> chkRZ_ iv l v r_ +subZR l (P rk rl ra rr) = case popLP rk rl ra rr of (# iv,v,r_ #) -> chkRZ iv l v r_ + +-- Local utility to substitute deleted element from (Z _ l _ r) +-- Pops the replacement from the left sub-tree, so result may be (N _ _ _) +subZL :: IntMap a -> IntMap a -> IntMap a +subZL E _ = E -- Both left and right subtrees must have been empty +subZL (N lk ll la lr) r = case popRN lk ll la lr of (# l_,iv,v #) -> chkLZ iv l_ v r +subZL (Z lk ll la lr) r = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLZ_ iv l_ v r +subZL (P lk ll la lr) r = case popRP lk ll la lr of (# l_,iv,v #) -> chkLZ iv l_ v r + +-- Substitute deleted element from (P _ l _ r) +subP :: IntMap a -> IntMap a -> IntMap a +subP E _ = error "subP: Bug0" -- Impossible +subP (N lk ll la lr) r = case popRN lk ll la lr of (# l_,iv,v #) -> chkLP iv l_ v r +subP (Z lk ll la lr) r = case popRZ lk ll la lr of (# l_,iv,v #) -> chkLP_ iv l_ v r +subP (P lk ll la lr) r = case popRP lk ll la lr of (# l_,iv,v #) -> chkLP iv l_ v r + +-- Check for height changes in left subtree of (N k l a r), +-- where l was (Z lk ll la lr) +chkLN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLN_ k l a r = case l of + E -> rebalN k l a r -- BF 0 -> E, so dH=-1 + _ -> N k l a r -- Otherwise dH=0 +-- Check for height changes in left subtree of (Z k l a r), +-- where l was (Z lk ll la lr) +chkLZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLZ_ k l a r = case l of + E -> N k l a r -- BF 0 -> E, so dH=-1 + _ -> Z k l a r -- Otherwise dH=0 +-- Check for height changes in left subtree of (P k l a r), +-- where l was (Z lk ll la lr) +chkLP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkLP_ k l a r = case l of + E -> Z k l a r -- BF 0 -> E, so dH=-1 + _ -> P k l a r -- Otherwise dH=0 +-- Check for height changes in right subtree of (N k l a r), +-- where r was (Z lk rl ra rr) +chkRN_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRN_ k l a r = case r of + E -> Z k l a r -- BF 0 -> E, so dH=-1 + _ -> N k l a r -- Otherwise dH=0 +-- Check for height changes in right subtree of (Z k l a r), +-- where r was (Z lk rl ra rr) +chkRZ_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRZ_ k l a r = case r of + E -> P k l a r -- BF 0 -> E, so dH=-1 + _ -> Z k l a r -- Otherwise dH=0 +-- Check for height changes in right subtree of (P k l a r), +-- where l was (Z lk rl ra rr) +chkRP_ :: Key -> IntMap a -> a -> IntMap a -> IntMap a +chkRP_ k l a r = case r of + E -> rebalP k l a r -- BF 0 -> E, so dH=-1 + _ -> P k l a r -- Otherwise dH=0 + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance (Eq a) => Eq (IntMap a) where + imp0 == imp1 = asIAList imp0 == asIAList imp1 + +--------- +-- Ord -- +--------- +instance Ord a => Ord (IntMap a) where + compare imp0 imp1 = compare (asIAList imp0) (asIAList imp1) + +---------- +-- Show -- +---------- +instance Show a => Show (IntMap a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocsAsc " . shows (assocsAsc mp) + +---------- +-- Read -- +---------- + +instance R.Read a => R.Read (IntMap a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocsAsc" <- R.lexP + xs <- R.readPrec + return (fromAssocsAsc xs) + readListPrec = R.readListPrecDefault + + + + + + + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance Typeable1 IntMap where + typeOf1 _ = mkTyConApp (mkTyCon "Data.GMap.IntMap.IntMap") [] +-------------- +instance Typeable a => Typeable (IntMap a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance Functor IntMap where +-- fmap :: (a -> b) -> IntMap a -> IntMap b + fmap = mapIntMap -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance M.Monoid a => M.Monoid (IntMap a) where +-- mempty :: IntMap a + mempty = emptyIntMap +-- mappend :: IntMap a -> IntMap a -> IntMap a + mappend map0 map1 = unionIntMap M.mappend map0 map1 +-- mconcat :: [IntMap a] -> IntMap a + mconcat maps = L.foldr (unionIntMap M.mappend) emptyIntMap maps + +------------------- +-- Data.Foldable -- +------------------- +instance F.Foldable IntMap where +-- fold :: Monoid m => IntMap m -> m + fold mp = foldElemsAscIntMap M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> IntMap a -> m + foldMap f mp = foldElemsAscIntMap (\a b -> M.mappend (f a) b) M.mempty mp +-- foldr :: (a -> b -> b) -> b -> IntMap a -> b + foldr f b0 mp = foldElemsAscIntMap f b0 mp +-- foldl :: (a -> b -> a) -> a -> IntMap b -> a + foldl f b0 mp = foldElemsDescIntMap (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- fold1 :: (a -> a -> a) -> IntMap a -> a + fold1 = undefined +-- foldl1 :: (a -> a -> a) -> IntMap a -> a + foldl1 = undefined +-} + +{- ?? +data IntMap a = E -- ^ Empty IntMap + | N {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=-1 (right height > left height) + | Z {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF= 0 + | P {-# UNPACK #-} !Key (IntMap a) a (IntMap a) -- ^ BF=+1 (left height > right height) +-} + + + +---- ToDo: Tidy This Stuff up later -- +vennIntMap :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b) +vennIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,E,t1) + gu t0 E = (t0,E,E ) + gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1) + gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1) + gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1) + gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1) + gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1) + gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1) + gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1) + gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1) + gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1) + gu_ t0 h0 t1 h1 = case vennH f Empt 0# t0 h0 t1 h1 of + (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba) + +vennH :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) +vennH f = v where + -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) + v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #) + v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #) + v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#) + v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb = + case compareInt# ka kb of + -- a < b, so (la < a < b) & (a < b < rb) + LT -> case forkVenn ka lb hlb of + (# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of + (# lra,hlra,myba,rra,hrra #) -> + -- (la + llb) < a < (lra + rlb) < b < (rra + rb) + case v cs cl rra hrra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of + Nothing -> case v cs0 cl0 lra hlra rlb hrlb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + Just a_ -> case (let c = f a_ b + in v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + ) of + (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> case (case mybb of + Nothing -> case v cs1 cl1 la hla llb hllb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + Just b_ -> case (let c = f a b_ + in v (Cons ka c cs1) (cl1+#1#) la hla llb hllb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + ) of + (# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #) + -- a = b + EQ -> case v cs cl ra hra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (let c = f a b + in v (Cons ka c cs0) (cl0+#1#) la hla lb hlb + ) of + (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of + (# ab,hab #) -> case joinH lba hlba rba hrba of + (# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #) + -- b < a, so (lb < b < a) & (b < a < ra) + GT -> case forkVenn ka rb hrb of + (# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of + (# lla,hlla,myba,rla,hrla #) -> + -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) + case v cs cl ra hra rrb hrrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of + Nothing -> case v cs0 cl0 rla hrla lrb hlrb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + Just b_ -> case (let c = f a b_ + in v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + ) of + (# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> case (case myba of + Nothing -> case v cs1 cl1 lla hlla lb hlb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + Just a_ -> case (let c = f a_ b + in v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + ) of + (# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #) +----------------------------------------------------------------------- +-------------------------- vennH Ends Here ---------------------------- +----------------------------------------------------------------------- + +vennIntMap' :: (a -> b -> c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b) +vennIntMap' f = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,E,t1) + gu t0 E = (t0,E,E ) + gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1) + gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1) + gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1) + gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1) + gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1) + gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1) + gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1) + gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1) + gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1) + gu_ t0 h0 t1 h1 = case vennH' f Empt 0# t0 h0 t1 h1 of + (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba) +-- Strict version of vennH +vennH' :: (a -> b -> c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) +vennH' f = v where + -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) + v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #) + v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #) + v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#) + v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb = + case compareInt# ka kb of + -- a < b, so (la < a < b) & (a < b < rb) + LT -> case forkVenn ka lb hlb of + (# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of + (# lra,hlra,myba,rra,hrra #) -> + -- (la + llb) < a < (lra + rlb) < b < (rra + rb) + case v cs cl rra hrra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of + Nothing -> case v cs0 cl0 lra hlra rlb hrlb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + Just a_ -> case (let c = f a_ b + in c `seq` v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + ) of + (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> case (case mybb of + Nothing -> case v cs1 cl1 la hla llb hllb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + Just b_ -> case (let c = f a b_ + in c `seq` v (Cons ka c cs1) (cl1+#1#) la hla llb hllb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + ) of + (# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #) + -- a = b + EQ -> case v cs cl ra hra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (let c = f a b + in c `seq` v (Cons ka c cs0) (cl0+#1#) la hla lb hlb + ) of + (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of + (# ab,hab #) -> case joinH lba hlba rba hrba of + (# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #) + -- b < a, so (lb < b < a) & (b < a < ra) + GT -> case forkVenn ka rb hrb of + (# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of + (# lla,hlla,myba,rla,hrla #) -> + -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) + case v cs cl ra hra rrb hrrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of + Nothing -> case v cs0 cl0 rla hrla lrb hlrb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + Just b_ -> case (let c = f a b_ + in c `seq` v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + ) of + (# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> case (case myba of + Nothing -> case v cs1 cl1 lla hlla lb hlb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + Just a_ -> case (let c = f a_ b + in c `seq` v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + ) of + (# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #) +----------------------------------------------------------------------- +-------------------------- vennH' Ends Here --------------------------- +----------------------------------------------------------------------- + + +vennMaybeIntMap :: (a -> b -> Maybe c) -> IntMap a -> IntMap b -> (IntMap a, IntMap c, IntMap b) +vennMaybeIntMap f = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = (E ,E,t1) + gu t0 E = (t0,E,E ) + gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1) + gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1) + gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1) + gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1) + gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1) + gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1) + gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1) + gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1) + gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1) + gu_ t0 h0 t1 h1 = case vennMaybeH f Empt 0# t0 h0 t1 h1 of + (# tab,_,cs,cl,tba,_ #) -> case subst (rep (I# cl)) cs of (# tc,_ #) -> (tab,tc,tba) +vennMaybeH :: (a -> b -> Maybe c) -> IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) +vennMaybeH f = v where + -- v :: IAList c -> Int# -> IntMap a -> Int# -> IntMap b -> Int# -> (# IntMap a,Int#,IAList c,Int#,IntMap b,Int# #) + v cs cl E ha tb hb = (# E ,ha,cs,cl,tb,hb #) + v cs cl ta ha E hb = (# ta,ha,cs,cl,E ,hb #) + v cs cl (N ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (N ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#2#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (Z ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (Z ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#1#) kb lb (hb-#1#) b rb (hb-#2#) + v cs cl (P ka la a ra) ha (N kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#2#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (Z kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#1#) + v cs cl (P ka la a ra) ha (P kb lb b rb) hb = v_ cs cl ka la (ha-#1#) a ra (ha-#2#) kb lb (hb-#1#) b rb (hb-#2#) + v_ cs cl ka la hla a ra hra kb lb hlb b rb hrb = + case compareInt# ka kb of + -- a < b, so (la < a < b) & (a < b < rb) + LT -> case forkVenn ka lb hlb of + (# llb,hllb,mybb,rlb,hrlb #) -> case forkVenn kb ra hra of + (# lra,hlra,myba,rra,hrra #) -> + -- (la + llb) < a < (lra + rlb) < b < (rra + rb) + case v cs cl rra hrra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case myba of + Nothing -> case v cs0 cl0 lra hlra rlb hrlb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH kb mba hmba b rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + Just a_ -> case (case f a_ b of + Nothing -> v cs0 cl0 lra hlra rlb hrlb + Just c -> v (Cons kb c cs0) (cl0+#1#) lra hlra rlb hrlb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> (# mab,hmab,cs1,cl1,mrba,hmrba #) + ) of + (# mab,hmab,cs1,cl1,mrba,hmrba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> case (case mybb of + Nothing -> case v cs1 cl1 la hla llb hllb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH ka lab hlab a mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + Just b_ -> case (case f a b_ of + Nothing -> v cs1 cl1 la hla llb hllb + Just c -> v (Cons ka c cs1) (cl1+#1#) la hla llb hllb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,lba,hlba #) + ) of + (# ab,hab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# ab,hab,cs2,cl2,ba,hba #) + -- a = b + EQ -> case v cs cl ra hra rb hrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case f a b of + Nothing -> v cs0 cl0 la hla lb hlb + Just c -> v (Cons ka c cs0) (cl0+#1#) la hla lb hlb + ) of + (# lab,hlab,cs1,cl1,lba,hlba #) -> case joinH lab hlab rab hrab of + (# ab,hab #) -> case joinH lba hlba rba hrba of + (# ba,hba #) -> (# ab,hab,cs1,cl1,ba,hba #) + -- b < a, so (lb < b < a) & (b < a < ra) + GT -> case forkVenn ka rb hrb of + (# lrb,hlrb,mybb,rrb,hrrb #) -> case forkVenn kb la hla of + (# lla,hlla,myba,rla,hrla #) -> + -- (lla + lb) < b < (rla + lrb) < a < (ra + rrb) + case v cs cl ra hra rrb hrrb of + (# rab,hrab,cs0,cl0,rba,hrba #) -> case (case mybb of + Nothing -> case v cs0 cl0 rla hrla lrb hlrb of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case spliceH ka mab hmab a rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + Just b_ -> case (case f a b_ of + Nothing -> v cs0 cl0 rla hrla lrb hlrb + Just c -> v (Cons ka c cs0) (cl0+#1#) rla hrla lrb hlrb + ) of + (# mab,hmab,cs1,cl1,mba,hmba #) -> case joinH mab hmab rab hrab of + (# mrab,hmrab #) -> (# mrab,hmrab,cs1,cl1,mba,hmba #) + ) of + (# mrab,hmrab,cs1,cl1,mba,hmba #) -> case joinH mba hmba rba hrba of + (# mrba,hmrba #) -> case (case myba of + Nothing -> case v cs1 cl1 lla hlla lb hlb of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case spliceH kb lba hlba b mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + Just a_ -> case (case f a_ b of + Nothing -> v cs1 cl1 lla hlla lb hlb + Just c -> v (Cons kb c cs1) (cl1+#1#) lla hlla lb hlb + ) of + (# lab,hlab,cs2,cl2,lba,hlba #) -> case joinH lba hlba mrba hmrba of + (# ba,hba #) -> (# lab,hlab,cs2,cl2,ba,hba #) + ) of + (# lab,hlab,cs2,cl2,ba,hba #) -> case joinH lab hlab mrab hmrab of + (# ab,hab #) -> (# ab,hab,cs2,cl2,ba,hba #) +----------------------------------------------------------------------- +------------------------ vennMaybeH Ends Here ------------------------- +----------------------------------------------------------------------- + +-- Common fork for Vennops +forkVenn :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,Maybe a,IntMap a,Int# #) +forkVenn k ta hta = f ta hta where + f E h = (# E,h,Nothing,E,h #) + f (N ka l a r) h = f_ ka l (h-#2#) a r (h-#1#) + f (Z ka l a r) h = f_ ka l (h-#1#) a r (h-#1#) + f (P ka l a r) h = f_ ka l (h-#1#) a r (h-#2#) + f_ ka l hl a r hr = case compareInt# k ka of + LT -> case f l hl of + (# ll,hll,mba,lr,hlr #) -> case spliceH ka lr hlr a r hr of + (# r_,hr_ #) -> (# ll,hll,mba,r_,hr_ #) + EQ -> (# l,hl,Just a,r,hr #) + GT -> case f r hr of + (# rl,hrl,mbc,rr,hrr #) -> case spliceH ka l hl a rl hrl of + (# l_,hl_ #) -> (# l_,hl_,mbc,rr,hrr #) + + +disjointUnionIntMap :: IntMap a -> IntMap a -> IntMap a +disjointUnionIntMap = gu where -- This is to avoid O(log n) height calculation for empty sets + gu E t1 = t1 + gu t0 E = t0 + gu t0@(N _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# l1) + gu t0@(N _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# l0) t1 (addHeight 1# l1) + gu t0@(N _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# l0) t1 (addHeight 2# r1) + gu t0@(Z _ l0 _ _ ) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# l1) + gu t0@(Z _ l0 _ _ ) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 1# l0) t1 (addHeight 1# l1) + gu t0@(Z _ l0 _ _ ) t1@(P _ _ _ r1) = gu_ t0 (addHeight 1# l0) t1 (addHeight 2# r1) + gu t0@(P _ _ _ r0) t1@(N _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# l1) + gu t0@(P _ _ _ r0) t1@(Z _ l1 _ _ ) = gu_ t0 (addHeight 2# r0) t1 (addHeight 1# l1) + gu t0@(P _ _ _ r0) t1@(P _ _ _ r1) = gu_ t0 (addHeight 2# r0) t1 (addHeight 2# r1) + gu_ t0 h0 t1 h1 = case disjointUnionH t0 h0 t1 h1 of (# t,_ #) -> t +disjointUnionH :: IntMap a -> Int# -> IntMap a -> Int# -> (# IntMap a,Int# #) +disjointUnionH = u where + -- u :: IntMap a -> UINT -> IntMap a -> UINT -> (# IntMap a,UINT #) + u E _ t1 h1 = (# t1,h1 #) + u t0 h0 E _ = (# t0,h0 #) + u (N k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#) + u (N k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#) + u (N k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#2#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#) + u (Z k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#2#) e1 r1 (h1-#1#) + u (Z k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#1#) + u (Z k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#1#) k1 l1 (h1-#1#) e1 r1 (h1-#2#) + u (P k0 l0 e0 r0) h0 (N k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#2#) e1 r1 (h1-#1#) + u (P k0 l0 e0 r0) h0 (Z k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#1#) + u (P k0 l0 e0 r0) h0 (P k1 l1 e1 r1) h1 = u_ k0 l0 (h0-#1#) e0 r0 (h0-#2#) k1 l1 (h1-#1#) e1 r1 (h1-#2#) + u_ k0 l0 hl0 e0 r0 hr0 k1 l1 hl1 e1 r1 hr1 = + case compareInt# k0 k1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case fork k1 r0 hr0 of + (# rl0,hrl0,rr0,hrr0 #) -> case fork k0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + (# ll1,hll1,lr1,hlr1 #) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + (# l,hl #) -> case u rl0 hrl0 lr1 hlr1 of + (# m,hm #) -> case u rr0 hrr0 r1 hr1 of + (# r,hr #) -> case spliceH k1 m hm e1 r hr of + (# t,ht #) -> spliceH k0 l hl e0 t ht + -- e0 = e1 + EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0# #) + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case fork k0 r1 hr1 of + (# rl1,hrl1,rr1,hrr1 #) -> case fork k1 l0 hl0 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + (# ll0,hll0,lr0,hlr0 #) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + (# l,hl #) -> case u lr0 hlr0 rl1 hrl1 of + (# m,hm #) -> case u r0 hr0 rr1 hrr1 of + (# r,hr #) -> case spliceH k1 l hl e1 m hm of + (# t,ht #) -> spliceH k0 t ht e0 r hr + -- fork :: Key -> IntMap a -> Int# -> (# IntMap a,Int#,IntMap a,Int# #) + fork k0 t1 ht1 = fork_ t1 ht1 where + fork_ E _ = (# E,0#,E,0# #) + fork_ (N k l e r) h = fork__ k l (h-#2#) e r (h-#1#) + fork_ (Z k l e r) h = fork__ k l (h-#1#) e r (h-#1#) + fork_ (P k l e r) h = fork__ k l (h-#1#) e r (h-#2#) + fork__ k l hl e r hr = case compareInt# k0 k of + LT -> case fork_ l hl of + (# l0,hl0,l1,hl1 #) -> case spliceH k l1 hl1 e r hr of + (# l1_,hl1_ #) -> (# l0,hl0,l1_,hl1_ #) + EQ -> error "disjointUnionH: Trees intersect" `seq` (# E,0#,E,0# #) + GT -> case fork_ r hr of + (# l0,hl0,l1,hl1 #) -> case spliceH k l hl e l0 hl0 of + (# l0_,hl0_ #) -> (# l0_,hl0_,l1,hl1 #) +----------------------------------------------------------------------- +---------------------- disjointUnionH Ends Here ----------------------- +----------------------------------------------------------------------- diff --git a/src/Data/GMap/ListMap.hs b/src/Data/GMap/ListMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/ListMap.hs @@ -0,0 +1,1704 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -Wall #-} + +module Data.GMap.ListMap +(-- * ListMap type + 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 + +-------------------------------------------------------------------------------------------- +-- Map Type for lists and various helper functions -- +-------------------------------------------------------------------------------------------- + +-- | The 'Map' type for keys of form @'Map' map k => [k]@. +data ListMap map k a + = Empt -- Empty special, never appears in non-empty ListMap! + | BraF ![k] a !(map (ListMap map k a)) -- Full branch, tail map may be empty or singleton + | BraE ![k] !(map (ListMap map k a)) -- Empty branch, no empty or singletons allowed. + +-- Invariants are: +-- * Tail maps must not contain 'Empt' ListMap elements. +-- * The tail map of a 'BraE' node must contain at least 2 entries. +-- (Empty and singleton tail maps are degenerate cases which are normalised appropriately.) +-- Smart constructor for BraE. Ensures tail is not empty or singleton map. +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 + +-- | ListMap is an instance of Map. +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 +-- fromAssocsWith = fromAssocsWithListMap +-- fromAssocsMaybe = fromAssocsMaybeListMap + delete = deleteListMap + adjustWith = adjustWithListMap + adjustWith' = adjustWithListMap' + adjustMaybe = adjustMaybeListMap + venn = vennListMap + venn' = vennListMap' + vennMaybe = vennMaybeListMap +-- disjointUnion = disjointUnionListMap + 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' + +-- Strict ++ +infixr 5 +!+ +(+!+) :: [a] -> [a] -> [a] +[] +!+ ys = ys +(x:xs) +!+ ys = let xs' = xs +!+ ys in xs' `seq` x:xs' +{- (not used currently) +xs +!+ [] = xs +xs +!+ ys = f xs where f [] = ys + f (x:xs') = let xs'' = f xs' in xs'' `seq` x:xs'' +-} + +-- Local Utility for reverse join: revTo xs ys = (reverse xs) ++ ys +revTo :: [a] -> [a] -> [a] +revTo [] ys = ys +revTo (x:xs) ys = revTo xs (x:ys) + +-- Take the first N elements of a list. +-- Gives an error if list is not long enough to do this! +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_ + +-- Return type of the match function +-- Do we need the Int# in Sfx and Sfy constructors ?? +data Match map k a = + Mat -- Input lists match and have same length (I.E. they are identical) + | Frk Int# (ListMap map k a -> ListMap map k a -> map (ListMap map k a)) [k] [k] -- n f xs ys + | Sfx Int# k [k] -- Input lists match but xs has remaining non-empty suffix -- n x xs + | Sfy Int# k [k] -- Input lists match but ys has remaining non-empty suffix -- n y ys +-- Try to match two lists of keys +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 -- x == y + +-- Common error message associated with (supposedly) sorted associations lists. +-- Can be caused by improper sorting (including duplicate keys) +badAssocs :: String +badAssocs = "Data.GMap.ListMap: Bad sorted association List." +-------------------------------------------------------------------------------------------- + +-- | See 'Map' class method 'empty'. +emptyListMap :: ListMap map k a +emptyListMap = Empt +{-# INLINE emptyListMap #-} + +-- | See 'Map' class method 'singleton'. +singletonListMap :: Map map k => [k] -> a -> ListMap map k a +singletonListMap ks a = BraF ks a empty +{-# INLINE singletonListMap #-} + +-- | See 'Map' class method 'pair'. +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 + +-- | See 'Map' class method 'nonEmpty'. +nonEmptyListMap :: ListMap map k a -> Maybe (ListMap map k a) +nonEmptyListMap Empt = Nothing +nonEmptyListMap lmp = Just lmp +{-# INLINE nonEmptyListMap #-} + +-- | See 'Map' class method 'status'. +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 +{-# INLINE statusListMap #-} + +-- | See 'Map' class method 'addSize'. +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 + +-- | See 'Map' class method 'lookup'. +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 +------------------------------ + +-- | See 'Map' class method 'lookupCont'. +lookupContListMap :: Map map k => (a -> Maybe b) -> [k] -> ListMap map k a -> Maybe b +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +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 +------------------------------ + +-- | See 'Map' class method 'delete'. +deleteListMap :: Map map k => [k] -> ListMap map k a -> ListMap map k a +deleteListMap = adjustMaybeListMap (const Nothing) +{-# INLINE deleteListMap #-} + +-- | See 'Map' class method 'adjustWith'. +adjustWithListMap :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a +-- N.B. One day we will have a more efficient implementation of this +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 +------------------------------ + +-- | See 'Map' class method 'adjustWith''. +adjustWithListMap' :: Map map k => (a -> a) -> [k] -> ListMap map k a -> ListMap map k a +-- N.B. One day we will have a more efficient implementation of this +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 +------------------------------ + +-- | See 'Map' class method 'adjustMaybe'. +adjustMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +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 +------------------------------ + +-- | See 'Map' class method 'venn'. +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 -- NB use of venn' +------------------------------------------ + 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) +------------------------------------------ + +-- | See 'Map' class method 'venn''. +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) +------------------------------------------ + +-- | See 'Map' class method 'vennMaybe'. +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) +------------------------------------------ + +-- | See 'Map' class method 'union'. +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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braFx lmp + braFx = BraF xs ax mpx + Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braFx lmp + braFx = BraF xs ax mpx + Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braEx lmp + braEx = BraE xs mpx + Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braEx lmp + braEx = BraE xs mpx + Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' + where f' lmp = u lmp braEy + braEy = BraE ys mpy +------------------------------------------ + + +-- | See 'Map' class method 'union''. +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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braFx lmp + braFx = BraF xs ax mpx + Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braFx lmp + braFx = BraF xs ax mpx + Sfy _ y ys -> BraF xs0 ax (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braEx lmp + braEx = BraE xs mpx + Sfy _ y ys -> BraE xs0 (insertWith' f' y braFy mpx) -- N.B. Use of strict insertWith' + 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) -- N.B. Use of strict union' + 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) -- N.B. Use of strict insertWith' + where f' lmp = u braEx lmp + braEx = BraE xs mpx + Sfy _ y ys -> BraE xs0 (insertWith' f' y braEy mpx) -- N.B. Use of strict insertWith' + where f' lmp = u lmp braEy + braEy = BraE ys mpy +------------------------------------------ + + +-- | See 'Map' class method 'unionMaybe'. +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) -- unionMaybe can yield empty maps !! +------------------------------------------ + 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) -- N.B Use of braE, not BraE !! + 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) -- N.B Use of braE, not BraE !! + 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) -- N.B Use of braE, not BraE !! + 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) -- N.B Use of braE, not BraE !! + 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) -- N.B Use of braE, not BraE !! + where f' lmp = uNE braEx lmp + braEx = BraE xs mpx + Sfy _ y ys -> braE xs0 (insertMaybe' f' y braEy mpx) -- N.B Use of braE, not BraE !! + where f' lmp = uNE lmp braEy + braEy = BraE ys mpy +------------------------------------------ + +-- | See 'Map' class method 'intersection'. +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) -- intersection can yield empty maps !! +------------------------------------------ + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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 +------------------------------------------ + + +-- | See 'Map' class method 'intersection''. +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) -- intersection can yield empty maps !! +------------------------------------------ + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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 +------------------------------------------ + + +-- | See 'Map' class method 'intersectionMaybe'. +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) -- intersection can yield empty maps !! +------------------------------------------ + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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 +------------------------------------------ + +-- | See 'Map' class method 'difference'. +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) -- difference can yield empty maps !! +------------------------------------------ + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + m (x:xs) (y:ys) = if x==y then m xs ys else lmpx +------------------------------------------ + + +-- | See 'Map' class method 'differenceMaybe'. +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) -- difference can yield empty maps !! +------------------------------------------ + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + 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) -- Note use of braE! + m (x:xs) (y:ys) = if x==y then m xs ys else lmpx +------------------------------------------ + +-- | See 'Map' class method 'isSubsetOf'. +isSubsetOfListMap :: Map map k => ListMap map k a -> ListMap map k b -> Bool +-- This is basically finding out if (differenceListMap lmp0 lmp1 == Empt) +-- If so, lmp0 is a submap of lmp1. +------------------------------------------ +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 -- mpx must contain at least 2 entries + 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 -- mpx must contain at least 2 entries + m (x:xs) (y:ys) = if x==y then m xs ys else False +------------------------------------------ + + +-- | See 'Map' class method 'isSubmapOf'. +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 -- mpx must contain at least 2 entries + 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 -- mpx must contain at least 2 entries + m (x:xs) (y:ys) = if x==y then m xs ys else False +------------------------------------------ + +-- | See 'Map' class method 'alter'. +alterListMap :: Map map k => (Maybe a -> Maybe a) -> [k] -> ListMap map k a -> ListMap map k a +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +alterListMap f xs0 lmp0 = iw xs0 lmp0 where + iwNE xs (Just lmp) = nonEmptyListMap (iw xs lmp) -- alter can yield empty maps !! + 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 -- xs == ys + Just ax -> BraF ys ax mp + Nothing -> braE ys mp -- N.B. Use of braE, not BraE + 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 -- xs == ys + 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) -- N.B. Use of braE, not BraE +------------------------------ + +-- | See 'Map' class method 'insertWith'. +insertWithListMap :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +-- N.B We always use the Strict insertWith' method here! +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 -- xs == ys + 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 -- xs == ys + 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) +------------------------------ + +-- | See 'Map' class method 'insertWith'''. +insertWithListMap' :: Map map k => (a -> a) -> [k] -> a -> ListMap map k a -> ListMap map k a +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +-- N.B We always use the Stricter insertWith'' method here! +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 -- xs == ys + 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) -- N.B.!! +------------------------------ + iw xs (BraE ys mp) = case match xs ys of + Mat -> ax `seq` BraF ys ax mp -- xs == ys + 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) -- N.B.!! +------------------------------ + + +-- | See 'Map' class method 'insertMaybe'. +insertMaybeListMap :: Map map k => (a -> Maybe a) -> [k] -> a -> ListMap map k a -> ListMap map k a +-- Convention below is xs is the search key list and ys is the key list fragment from the Trie (ListMap) +insertMaybeListMap f xs0 ax lmp0 = iw xs0 lmp0 where + iwNE xs lmp = nonEmptyListMap (iw xs lmp) -- insertMaybe can yield empty maps !! +------------------------------ + iw xs Empt = BraF xs ax empty +------------------------------ + iw xs (BraF ys ay mp) = case match xs ys of + Mat -> case f ay of -- xs == ys + Just ay' -> BraF ys ay' mp + Nothing -> braE ys mp -- N.B. Use of braE, not BraE + 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 -- xs == ys + 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) -- N.B. Use of braE, not BraE +------------------------------ + +-- | See 'Map' class method 'foldElems'. +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 + +-- | See 'Map' class method 'foldKeys'. +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' + +-- | See 'Map' class method 'foldAssocs'. +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' + +-- | See 'Map' class method 'foldElems''. +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 + +-- | See 'Map' class method 'foldKeys''. +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' + +-- | See 'Map' class method 'foldAssocs''. +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' + +------------------------------------------------------------------------------------------ + +-- Group an ordered list of assocs according to which part of the map they will form +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' [])]) + -- 'currentClump' and 'clumps' are list building continuations to preserve order of 'as' + 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 -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered + +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 -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered + +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 + -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered + +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 + -- NB Shouldnt have any repeated keys in 'innerAs' if 'as' is ordered + +-- | See 'Map' class method 'foldElemsAsc'. +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 + +-- | See 'Map' class method 'foldElemsDesc'. +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 + +-- | See 'Map' class method 'foldKeysAsc'. +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' + +-- | See 'Map' class method 'foldKeysDesc'. +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' + +-- | See 'Map' class method 'foldAssocsAsc'. +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' + +-- | See 'Map' class method 'foldAssocsDesc'. +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' + +-- | See 'Map' class method 'foldElemsAsc''. +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 + +-- | See 'Map' class method 'foldElemsDesc''. +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 + +-- | See 'Map' class method 'foldKeysAsc''. +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' + +-- | See 'Map' class method 'foldKeysDesc''. +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' + +-- | See 'Map' class method 'foldAssocsAsc''. +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' + +-- | See 'Map' class method 'foldAssocsDesc''. +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' + +-- | See 'Map' class method 'foldElemsUInt'. +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 + +-- | See 'Map' class method 'map'. +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) -- Note use of strict map' +mapListMap f (BraE ks mp) = BraE ks (map' (mapListMap f) mp) -- Note use of strict map' + +-- | See 'Map' class method 'map''. +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) -- Note use of strict map' +mapListMap' f (BraE ks mp) = BraE ks (map' (mapListMap' f) mp) -- Note use of strict map' + +-- | See 'Map' class method 'mapMaybe'. +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' + +-- | See 'Map' class method 'mapWithKey'. +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') -- Note use of strict mapWithKey' + where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp + mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey' + where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp + +-- | See 'Map' class method 'mapWithKey''. +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') -- Note use of strict mapWithKey' + where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp + mwk kcont (BraE ks mp') = BraE ks (mapWithKey' f' mp') -- Note use of strict mapWithKey' + where f' k lmp = mwk (kcont . (ks++) . (k:)) lmp + +-- | See 'Map' class method 'mapMaybe'. +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' + + +-- | See 'Map' class method 'valid'. +validListMap :: Map map k => ListMap map k a -> Maybe String +validListMap Empt = Nothing +validListMap lmp = validListMap' lmp +-- Disallows Empt +validListMap' :: Map map k => ListMap map k a -> Maybe String +validListMap' Empt = Just "ListMap: Non-empty map contains Empt node." +-- Empty and singleton sub-maps are OK +validListMap' (BraF _ _ mp) = case valid mp of + Nothing -> foldElems valAccum Nothing mp + Just s -> Just ("ListMap:" ++ s) +-- Empty and singleton sub-maps are invalid +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) +-- Accumulating valid (does not accept empty ListMaps) +valAccum :: Map map k => ListMap map k a -> Maybe String -> Maybe String +valAccum lmp Nothing = validListMap' lmp +valAccum _ just = just + +-- | See 'Map' class method 'compareKey. +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 + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +-- Needs -fallow-undecidable-instances +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 + +--------- +-- Ord -- +--------- +-- Needs -fallow-undecidable-instances +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 +----------------------- + +---------- +-- Show -- +---------- +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) + +---------- +-- Read -- +---------- +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 + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +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 -- This is just to get types for k & m !! +-------------- +instance (Typeable1 (ListMap map k), Typeable a) => Typeable (ListMap map k a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance Map map k => Functor (ListMap map k) where +-- fmap :: (a -> b) -> ListMap map k a -> ListMap map k b + fmap = mapListMap -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Map map k, M.Monoid a) => M.Monoid (ListMap map k a) where +-- mempty :: ListMap map k a + mempty = emptyListMap +-- mappend :: ListMap map k a -> ListMap map k a -> ListMap map k a + mappend map0 map1 = unionListMap M.mappend map0 map1 +-- mconcat :: [ListMap map k a] -> ListMap map k a + mconcat maps = L.foldr (unionListMap M.mappend) emptyListMap maps + +------------------- +-- Data.Foldable -- +------------------- +instance Map map k => F.Foldable (ListMap map k) where +-- fold :: Monoid m => ListMap map k m -> m + fold mp = foldElemsListMap M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> ListMap map k a -> m + foldMap f mp = foldElemsListMap (\a b -> M.mappend (f a) b) M.mempty mp +-- foldr :: (a -> b -> b) -> b -> ListMap map k a -> b + foldr f b0 mp = foldElemsListMap f b0 mp +-- foldl :: (a -> b -> a) -> a -> ListMap map k b -> a + foldl f b0 mp = foldElemsListMap (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- foldr1 :: (a -> a -> a) -> ListMap map k a -> a + foldr1 = undefined +-- foldl1 :: (a -> a -> a) -> ListMap map k a -> a + foldl1 = undefined +-} + diff --git a/src/Data/GMap/MaybeMap.hs b/src/Data/GMap/MaybeMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/MaybeMap.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.MaybeMap +(-- * EnumMap type + MaybeMap +) where + +import Data.GMap() + +import Data.GMap.ChoiceMap +import Data.GMap.InjectKeys +import Data.GMap.UnitMap + +-------------------------------------------------------------------------------------------- +-- Map Type for Maybe -- +-------------------------------------------------------------------------------------------- + +data InjectMaybe k + +instance Injection (InjectMaybe k) (Maybe k) (Choice2 k ()) where + inject _ (Just k) = C1of2 k + inject _ Nothing = C2of2 () + outject _ (C1of2 k) = Just k + outject _ (C2of2 _) = Nothing + +type MaybeMap map k = InjectKeys (InjectMaybe k) (Maybe k) (Choice2 k ()) (Choice2Map map UnitMap k ()) diff --git a/src/Data/GMap/OrdMap.hs b/src/Data/GMap/OrdMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/OrdMap.hs @@ -0,0 +1,543 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-warn-unused-imports -Wall #-} + +module Data.GMap.OrdMap +(-- * OrdMap type + OrdMap +) where + +import Data.GMap +import qualified Data.Tree.AVL as A +import qualified Data.COrdering as C + +import qualified Data.Monoid as M (Monoid(..)) +import qualified Data.Foldable as F (Foldable(..)) +import Data.Typeable +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L +import qualified Data.Maybe as MB +import Control.Monad + +import GHC.Base +import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault) + +-- | The default 'Map' type any key type which is an instance of 'Ord'. +-- This is a newtype wrapper around @'Data.Tree.AVL.AVL' (k,a)@. +newtype OrdMap k a = OrdMap (A.AVL (k,a)) + +instance Ord k => Map (OrdMap k) k where + empty = emptyOrdMap + singleton = singletonOrdMap + pair = pairOrdMap + nonEmpty = nonEmptyOrdMap + status = statusOrdMap + addSize = addSizeOrdMap + lookup = lookupOrdMap + lookupCont = lookupContOrdMap + alter = alterOrdMap + insertWith = insertWithOrdMap + insertWith' = insertWithOrdMap' + insertMaybe = insertMaybeOrdMap +-- fromAssocsWith = fromAssocsWithOrdMap +-- fromAssocsMaybe = fromAssocsMaybeOrdMap + delete = deleteOrdMap + adjustWith = adjustWithOrdMap + adjustWith' = adjustWithOrdMap' + adjustMaybe = adjustMaybeOrdMap + venn = vennOrdMap + venn' = vennOrdMap' + vennMaybe = vennMaybeOrdMap +-- merge = mergeOrdMap + union = unionOrdMap + union' = unionOrdMap' + unionMaybe = unionMaybeOrdMap + disjointUnion = disjointUnionOrdMap + intersection = intersectionOrdMap + intersection' = intersectionOrdMap' + intersectionMaybe = intersectionMaybeOrdMap + difference = differenceOrdMap + differenceMaybe = differenceMaybeOrdMap + isSubsetOf = isSubsetOfOrdMap + isSubmapOf = isSubmapOfOrdMap + map = mapOrdMap + map' = mapOrdMap' + mapMaybe = mapMaybeOrdMap + mapWithKey = mapWithKeyOrdMap + mapWithKey' = mapWithKeyOrdMap' + filter = filterOrdMap + foldKeys = foldKeysAscOrdMap + foldElems = foldElemsAscOrdMap + foldAssocs = foldAssocsAscOrdMap + foldKeys' = foldKeysAscOrdMap' + foldElems' = foldElemsAscOrdMap' + foldAssocs' = foldAssocsAscOrdMap' + foldElemsUInt = foldElemsUIntOrdMap + valid = validOrdMap + +instance Ord k => OrderedMap (OrdMap k) k where + compareKey = compareKeyOrdMap + fromAssocsAscWith = fromAssocsAscWithOrdMap + fromAssocsDescWith = fromAssocsDescWithOrdMap + fromAssocsAscMaybe = fromAssocsAscMaybeOrdMap + fromAssocsDescMaybe = fromAssocsDescMaybeOrdMap + foldElemsAsc = foldElemsAscOrdMap + foldElemsDesc = foldElemsDescOrdMap + foldKeysAsc = foldKeysAscOrdMap + foldKeysDesc = foldKeysDescOrdMap + foldAssocsAsc = foldAssocsAscOrdMap + foldAssocsDesc = foldAssocsDescOrdMap + foldElemsAsc' = foldElemsAscOrdMap' + foldElemsDesc' = foldElemsDescOrdMap' + foldKeysAsc' = foldKeysAscOrdMap' + foldKeysDesc' = foldKeysDescOrdMap' + foldAssocsAsc' = foldAssocsAscOrdMap' + foldAssocsDesc' = foldAssocsDescOrdMap' + +-- | See 'Map' class method 'empty'. +emptyOrdMap :: OrdMap k a +emptyOrdMap = OrdMap (A.empty) + +-- | See 'Map' class method 'singleton'. +singletonOrdMap :: k -> a -> OrdMap k a +singletonOrdMap k a = OrdMap (A.singleton (k,a)) +{-# INLINE singletonOrdMap #-} + +-- | See 'Map' class method 'nonEmpty'. +nonEmptyOrdMap :: OrdMap k a -> Maybe (OrdMap k a) +nonEmptyOrdMap m@(OrdMap t) = if A.isEmpty t then Nothing else Just m +{-# INLINE nonEmptyOrdMap #-} + +-- | See 'Map' class method 'pair'. +pairOrdMap :: Ord k => k -> k -> Maybe (a -> a -> OrdMap k a) +pairOrdMap x y = case compare x y of + LT -> Just (\ax ay -> OrdMap (A.pair (x,ax) (y,ay))) + EQ -> Nothing + GT -> Just (\ax ay -> OrdMap (A.pair (y,ay) (x,ax))) + +-- Group an ordered list of assocs by key +clump :: Eq k => [(k,a)] -> [(k,[a])] +clump [] = [] +clump kas = list' [(k',as' [])] + where (k',as',list') = L.foldl' combine (fst $ head kas,id,id) kas + -- 'as' and 'list' are list building continuations - so order of 'kas' is preserved + combine (k1,as,list) (k2,a) = + if k1 == k2 + then (k1, as . (a:), list ) + else (k2, (a:), list . ((k1,as []):) ) + +-- | See 'Map' class method 'fromAssocsAscWith' +fromAssocsAscWithOrdMap :: Ord k => (a -> a -> a) -> [(k,a)] -> OrdMap k a +fromAssocsAscWithOrdMap f kas = OrdMap $ A.asTreeL [ (k,L.foldl1' f as) | (k,as) <- clump kas] + +-- | See 'Map' class method 'fromAssocsDescWith' +fromAssocsDescWithOrdMap :: Ord k => (a -> a -> a) -> [(k,a)] -> OrdMap k a +fromAssocsDescWithOrdMap f kas = OrdMap $ A.asTreeR [ (k,L.foldl1' f as) | (k,as) <- clump kas] + +-- | See 'Map' class method 'fromAssocsAscMaybe' +fromAssocsAscMaybeOrdMap :: Ord k => (a -> a -> Maybe a) -> [(k,a)] -> OrdMap k a +fromAssocsAscMaybeOrdMap f kas = OrdMap $ A.asTreeL $ MB.catMaybes [ fld k as | (k,as) <- clump kas] + where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) -- NB 'as' guaranteed nonempty by clump + +-- | See 'Map' class method 'fromAssocsDescMaybe' +fromAssocsDescMaybeOrdMap :: Ord k => (a -> a -> Maybe a) -> [(k,a)] -> OrdMap k a +fromAssocsDescMaybeOrdMap f kas = OrdMap $ A.asTreeR $ MB.catMaybes [ fld k as | (k,as) <- clump kas] + where fld k as = (\a -> (k,a)) `fmap` foldM f (head as) (tail as) -- NB 'as' guaranteed nonempty by clump + +-- | See 'Map' class method 'status'. +statusOrdMap :: OrdMap k a -> Status k a +statusOrdMap (OrdMap t) = case A.tryGetSingleton t of + Just (k,a) -> One k a + Nothing -> if A.isEmpty t then None else Many +{-# INLINE statusOrdMap #-} + +-- | See 'Map' class method 'addSize'. +addSizeOrdMap :: OrdMap k a -> Int# -> Int# +addSizeOrdMap (OrdMap t) n = A.addSize# n t +{-# INLINE addSizeOrdMap #-} + +-- | See 'Map' class method 'Data.GMap.lookup'. +lookupOrdMap :: Ord k => k -> OrdMap k a -> Maybe a +lookupOrdMap k (OrdMap t) = A.tryRead t cmp + where cmp (k',a) = case compare k k' of + LT -> C.Lt + EQ -> C.Eq a + GT -> C.Gt + +-- | See 'Map' class method 'lookupCont'. +lookupContOrdMap :: Ord k => (a -> Maybe b) -> k -> OrdMap k a -> Maybe b +lookupContOrdMap f k (OrdMap t) = A.tryReadMaybe t cmp + where cmp (k',a) = case compare k k' of + LT -> C.Lt + EQ -> let mb = f a in mb `seq` C.Eq mb + GT -> C.Gt + +-- | See 'Map' class method 'alter'. +alterOrdMap :: Ord k => (Maybe a -> Maybe a) -> k -> OrdMap k a -> OrdMap k a +alterOrdMap f k (OrdMap t) = case A.tryReadBAVL bavl of + Nothing -> OrdMap (doIt k Nothing ) -- bavl is empty + Just (k',a) -> OrdMap (doIt k' (Just a)) -- bavl is full + where bavl = A.openBAVL cmp t + cmp (k',_) = compare k k' + doIt k' mba = case f mba of + Nothing -> A.deleteBAVL bavl -- This is a nop for empty bavl + Just a' -> A.pushBAVL (k',a') bavl -- This is a write for full bavl + +-- | See 'Map' class method 'insertWith'. +insertWithOrdMap :: Ord k => (a -> a) -> k -> a -> OrdMap k a -> OrdMap k a +insertWithOrdMap f k a (OrdMap t) = OrdMap (A.push cmp (k,a) t) + where cmp (k',a') = case compare k k' of + LT -> C.Lt + EQ -> C.Eq (k',f a') + GT -> C.Gt + +-- | See 'Map' class method 'insertWith'. +insertWithOrdMap' :: Ord k => (a -> a) -> k -> a -> OrdMap k a -> OrdMap k a +insertWithOrdMap' f k a (OrdMap t) = OrdMap (A.push' cmp (a `seq` (k,a)) t) -- Note use of genPush' + where cmp (k',a') = case compare k k' of + LT -> C.Lt + EQ -> let b' = f a' in b' `seq` C.Eq (k',f a') + GT -> C.Gt + +-- | See 'Map' class method 'insertMaybe'. +insertMaybeOrdMap :: Ord k => (a -> Maybe a) -> k -> a -> OrdMap k a -> OrdMap k a +insertMaybeOrdMap f k a (OrdMap t) = case A.tryReadBAVL bavl of + Nothing -> OrdMap (A.pushBAVL (k,a) bavl) + Just (k',a') -> case f a' of + Nothing -> OrdMap (A.deleteBAVL bavl) + Just a'' -> OrdMap (A.pushBAVL (k',a'') bavl) + where bavl = A.openBAVL cmp t + cmp (k',_) = compare k k' + +-- | See 'Map' class method 'delete'. +deleteOrdMap :: Ord k => k -> OrdMap k a -> OrdMap k a +deleteOrdMap k (OrdMap t) = OrdMap (A.delete cmp t) + where cmp (k',_) = compare k k' +{-# INLINE deleteOrdMap #-} + +-- | See 'Map' class method 'adjust'. +adjustWithOrdMap :: Ord k => (a -> a) -> k -> OrdMap k a -> OrdMap k a +adjustWithOrdMap f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t) + where cmp (k',a) = case compare k k' of + LT -> C.Lt + EQ -> C.Eq (Just (k',f a)) + GT -> C.Gt + +-- | See 'Map' class method 'adjust''. +adjustWithOrdMap' :: Ord k => (a -> a) -> k -> OrdMap k a -> OrdMap k a +adjustWithOrdMap' f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t) + where cmp (k',a) = case compare k k' of + LT -> C.Lt + EQ -> let a' = f a in a' `seq` C.Eq (Just (k',a')) + GT -> C.Gt + +-- | See 'Map' class method 'adjustMaybe'. +adjustMaybeOrdMap :: Ord k => (a -> Maybe a) -> k -> OrdMap k a -> OrdMap k a +adjustMaybeOrdMap f k (OrdMap t) = OrdMap (A.deleteMaybe cmp t) + where cmp (k',a) = case compare k k' of + LT -> C.Lt + EQ -> case f a of + Nothing -> C.Eq Nothing + Just a' -> C.Eq (Just (k',a')) + GT -> C.Gt + +-- | See 'Map' class method 'venn'. +vennOrdMap :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b) +vennOrdMap f (OrdMap t) (OrdMap t') = case A.venn cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba) + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> C.Eq (k, f a b) + GT -> C.Gt + +-- | See 'Map' class method 'venn''. +vennOrdMap' :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b) +vennOrdMap' f (OrdMap t) (OrdMap t') = case A.venn cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba) + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> let c = f a b in c `seq` C.Eq (k,c) + GT -> C.Gt + +-- | See 'Map' class method 'vennMaybe'. +vennMaybeOrdMap :: Ord k => (a -> b -> Maybe c) -> OrdMap k a -> OrdMap k b -> (OrdMap k a, OrdMap k c, OrdMap k b) +vennMaybeOrdMap f (OrdMap t) (OrdMap t') = case A.vennMaybe cmp t t' of (tab,ti,tba) -> (OrdMap tab,OrdMap ti,OrdMap tba) + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> case f a b of + Nothing -> C.Eq Nothing + Just c -> C.Eq (Just (k,c)) + GT -> C.Gt + +-- | See 'Map' class method 'union'. +unionOrdMap :: Ord k => (a -> a -> a) -> OrdMap k a -> OrdMap k a -> OrdMap k a +unionOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.union cmp t t') + where cmp (k,a) (k',a') = case compare k k' of + LT -> C.Lt + EQ -> C.Eq (k, f a a') + GT -> C.Gt + +-- | See 'Map' class method 'union''. +unionOrdMap' :: Ord k => (a -> a -> a) -> OrdMap k a -> OrdMap k a -> OrdMap k a +unionOrdMap' f (OrdMap t) (OrdMap t') = OrdMap (A.union cmp t t') + where cmp (k,a) (k',a') = case compare k k' of + LT -> C.Lt + EQ -> let a'' = f a a' in a'' `seq` C.Eq (k, a'') + GT -> C.Gt + +-- | See 'Map' class method 'unionMaybe'. +unionMaybeOrdMap :: Ord k => (a -> a -> Maybe a) -> OrdMap k a -> OrdMap k a -> OrdMap k a +unionMaybeOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.unionMaybe cmp t t') + where cmp (k,a) (k',a') = case compare k k' of + LT -> C.Lt + EQ -> case f a a' of + Nothing -> C.Eq Nothing + Just a'' -> C.Eq (Just (k,a'')) + GT -> C.Gt + +-- | See 'Map' class method 'disjointUnion'. +disjointUnionOrdMap :: Ord k => OrdMap k a -> OrdMap k a -> OrdMap k a +disjointUnionOrdMap (OrdMap t) (OrdMap t') = OrdMap (A.disjointUnion cmp t t') + where cmp (k,_) (k',_) = compare k k' + +-- | See 'Map' class method 'intersection'. +intersectionOrdMap :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> OrdMap k c +intersectionOrdMap f (OrdMap t) (OrdMap t') = OrdMap (A.intersection cmp t t') + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> C.Eq (k, f a b) + GT -> C.Gt + +-- | See 'Map' class method 'intersection''. +intersectionOrdMap' :: Ord k => (a -> b -> c) -> OrdMap k a -> OrdMap k b -> OrdMap k c +intersectionOrdMap' f (OrdMap t) (OrdMap t') = OrdMap (A.intersection cmp t t') + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> let c = f a b in c `seq` C.Eq (k, c) + GT -> C.Gt + +-- | See 'Map' class method 'intersectionMaybe'. +intersectionMaybeOrdMap :: Ord k => (a -> b -> Maybe c) -> OrdMap k a -> OrdMap k b -> OrdMap k c +intersectionMaybeOrdMap f (OrdMap ta) (OrdMap tb) = OrdMap (A.intersectionMaybe cmp ta tb) + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> case f a b of + Nothing -> C.Eq Nothing + Just c -> C.Eq (Just (k,c)) + GT -> C.Gt + +-- | See 'Map' class method 'difference'. +differenceOrdMap :: Ord k => OrdMap k a -> OrdMap k b -> OrdMap k a +differenceOrdMap (OrdMap t1) (OrdMap t2) = OrdMap (A.difference cmp t1 t2) + where cmp (k,_) (k',_) = compare k k' + +-- | See 'Map' class method 'differenceMaybe'. +differenceMaybeOrdMap :: Ord k => (a -> b -> Maybe a) -> OrdMap k a -> OrdMap k b -> OrdMap k a +differenceMaybeOrdMap f (OrdMap ta) (OrdMap tb) = OrdMap (A.differenceMaybe cmp ta tb) + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> case f a b of + Nothing -> C.Eq Nothing + Just a' -> C.Eq (Just (k,a')) + GT -> C.Gt + +-- | See 'Map' class method 'isSubsetOf'. +isSubsetOfOrdMap :: Ord k => OrdMap k a -> OrdMap k b -> Bool +isSubsetOfOrdMap (OrdMap ta) (OrdMap tb) = A.isSubsetOf cmp ta tb + where cmp (k,_) (k',_) = compare k k' + +-- | See 'Map' class method 'isSubmapOf'. +isSubmapOfOrdMap :: Ord k => (a -> b -> Bool) -> OrdMap k a -> OrdMap k b -> Bool +isSubmapOfOrdMap p (OrdMap ta) (OrdMap tb) = A.isSubsetOfBy cmp ta tb + where cmp (k,a) (k',b) = case compare k k' of + LT -> C.Lt + EQ -> C.Eq $! p a b + GT -> C.Gt + +-- | See 'Map' class method 'Data.GMap.map'. +mapOrdMap :: (a -> b) -> OrdMap k a -> OrdMap k b +-- Note use of strict AVL map! (This does not force evaluation of f a). +mapOrdMap f (OrdMap t) = OrdMap (A.map' (\(k,a) -> (k,f a)) t) +{-# INLINE mapOrdMap #-} + +-- | See 'Map' class method 'map''. +mapOrdMap' :: (a -> b) -> OrdMap k a -> OrdMap k b +mapOrdMap' f (OrdMap t) = OrdMap (A.map' (\(k,a) -> let b = f a in b `seq` (k,b)) t) +{-# INLINE mapOrdMap' #-} + +-- | See 'Map' class method 'mapMaybe'. +mapMaybeOrdMap :: (a -> Maybe b) -> OrdMap k a -> OrdMap k b +mapMaybeOrdMap f (OrdMap t) = OrdMap (A.mapMaybe f' t) + where f' (k,a) = case f a of + Nothing -> Nothing + Just b -> Just (k,b) + +-- | See 'Map' class method 'mapWithKey'. +mapWithKeyOrdMap :: (k -> a -> b) -> OrdMap k a -> OrdMap k b +-- Note use of strict AVL map! (This does not force evaluation of f k a). +mapWithKeyOrdMap f (OrdMap t) = OrdMap (A.map' (\(k,a) -> (k, f k a)) t) +{-# INLINE mapWithKeyOrdMap #-} + +-- | See 'Map' class method 'mapWithKey''. +mapWithKeyOrdMap' :: (k -> a -> b) -> OrdMap k a -> OrdMap k b +mapWithKeyOrdMap' f (OrdMap t) = OrdMap (A.map' (\(k,a) -> let b = f k a in b `seq` (k, b)) t) +{-# INLINE mapWithKeyOrdMap' #-} + +-- | See 'Map' class method 'Data.GMap.filter'. +filterOrdMap :: (a -> Bool) -> OrdMap k a -> OrdMap k a +filterOrdMap f (OrdMap t) = OrdMap (A.filter (\(_,a) -> f a) t) +{-# INLINE filterOrdMap #-} + +-- | See 'Map' class method 'foldElemsAsc'. +foldElemsAscOrdMap :: (a -> b -> b) -> b -> OrdMap k a-> b +foldElemsAscOrdMap f b0 (OrdMap t) = A.foldr (\(_,a) b -> f a b) b0 t -- Lazy foldr +{-# INLINE foldElemsAscOrdMap #-} + +-- | See 'Map' class method 'foldElemsDesc'. +foldElemsDescOrdMap :: (a -> b -> b) -> b -> OrdMap k a -> b +foldElemsDescOrdMap f b0 (OrdMap t) = A.foldl (\b (_,a) -> f a b) b0 t -- Lazy foldl +{-# INLINE foldElemsDescOrdMap #-} + +-- | See 'Map' class method 'foldKeysAsc'. +foldKeysAscOrdMap :: (k -> b -> b) -> b -> OrdMap k a -> b +foldKeysAscOrdMap f b0 (OrdMap t) = A.foldr (\(k,_) b -> f k b) b0 t -- Lazy foldr +{-# INLINE foldKeysAscOrdMap #-} + +-- | See 'Map' class method 'foldKeysDesc'. +foldKeysDescOrdMap :: (k -> b -> b) -> b -> OrdMap k a -> b +foldKeysDescOrdMap f b0 (OrdMap t) = A.foldl (\b (k,_) -> f k b) b0 t -- Lazy foldl +{-# INLINE foldKeysDescOrdMap #-} + +-- | See 'Map' class method 'foldAssocsAsc'. +foldAssocsAscOrdMap :: (k -> a -> b -> b) -> b -> OrdMap k a -> b +foldAssocsAscOrdMap f b0 (OrdMap t) = A.foldr (\(k,a) b -> f k a b) b0 t -- Lazy foldr +{-# INLINE foldAssocsAscOrdMap #-} + +-- | See 'Map' class method 'foldAssocsDesc'. +foldAssocsDescOrdMap :: (k -> a -> b -> b) -> b -> OrdMap k a -> b +foldAssocsDescOrdMap f b0 (OrdMap t) = A.foldl (\b (k,a) -> f k a b) b0 t -- Lazy foldl +{-# INLINE foldAssocsDescOrdMap #-} + +-- | See 'Map' class method 'foldElemsAsc''. +foldElemsAscOrdMap' :: (a -> b -> b) -> b -> OrdMap k a -> b +foldElemsAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(_,a) b -> f a b) b0 t -- Strict foldr +{-# INLINE foldElemsAscOrdMap' #-} + +-- | See 'Map' class method 'foldElemsDesc''. +foldElemsDescOrdMap' :: (a -> b -> b) -> b -> OrdMap k a -> b +foldElemsDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (_,a) -> f a b) b0 t -- Strict foldl +{-# INLINE foldElemsDescOrdMap' #-} + +-- | See 'Map' class method 'foldKeysAsc''. +foldKeysAscOrdMap' :: (k -> b -> b) -> b -> OrdMap k a -> b +foldKeysAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(k,_) b -> f k b) b0 t -- Strict foldr +{-# INLINE foldKeysAscOrdMap' #-} + +-- | See 'Map' class method 'foldKeysDesc''. +foldKeysDescOrdMap' :: (k -> b -> b) -> b -> OrdMap k a -> b +foldKeysDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (k,_) -> f k b) b0 t -- Strict foldl +{-# INLINE foldKeysDescOrdMap' #-} + +-- | See 'Map' class method 'foldAssocsAsc''. +foldAssocsAscOrdMap' :: (k -> a -> b -> b) -> b -> OrdMap k a -> b +foldAssocsAscOrdMap' f b0 (OrdMap t) = A.foldr' (\(k,a) b -> f k a b) b0 t -- Strict foldr +{-# INLINE foldAssocsAscOrdMap' #-} + +-- | See 'Map' class method 'foldAssocsDesc''. +foldAssocsDescOrdMap' :: (k -> a -> b -> b) -> b -> OrdMap k a -> b +foldAssocsDescOrdMap' f b0 (OrdMap t) = A.foldl' (\b (k,a) -> f k a b) b0 t -- Strict foldl +{-# INLINE foldAssocsDescOrdMap' #-} + +-- | See 'Map' class method 'foldElemsUInt'. +foldElemsUIntOrdMap :: (a -> Int# -> Int#) -> Int# -> OrdMap k a -> Int# +foldElemsUIntOrdMap f n (OrdMap t) = A.foldrInt# (\(_,a) u -> f a u) n t +{-# INLINE foldElemsUIntOrdMap #-} + +-- | See 'Map' class method 'valid'. +validOrdMap :: Ord k => OrdMap k a -> Maybe String +validOrdMap (OrdMap t) = + if A.isSorted (\(k0,_) (k1,_) -> compare k0 k1) t + then if A.isBalanced t + then Nothing + else Just "OrdMap: Tree is not balanced." + else Just "OrdMap: Tree is not sorted." + +-- | See 'Map' class method 'compareKey' +compareKeyOrdMap :: Ord k => OrdMap k a -> k -> k -> Ordering +compareKeyOrdMap _ = compare + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance (Eq k, Eq a) => Eq (OrdMap k a) where + OrdMap t0 == OrdMap t1 = t0 == t1 + +--------- +-- Ord -- +--------- +instance (Ord k, Ord a) => Ord (OrdMap k a) where + compare (OrdMap t0) (OrdMap t1) = compare t0 t1 + +---------- +-- Show -- +---------- +instance (Ord k, Show k, Show a) => Show (OrdMap k a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocsAsc " . shows (assocsAsc mp) + +---------- +-- Read -- +---------- +instance (Ord k, R.Read k, R.Read a) => R.Read (OrdMap k a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocsAsc" <- R.lexP + xs <- R.readPrec + return (fromAssocsAsc xs) + readListPrec = R.readListPrecDefault + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance (Ord k, Typeable k) => Typeable1 (OrdMap k) where + typeOf1 mp = mkTyConApp (mkTyCon "Data.GMap.OrdMap.OrdMap") [typeOf k] + where [(k,_)] = assocsAsc mp -- This is just to get type for k !! +-------------- +instance (Typeable1 (OrdMap k), Typeable a) => Typeable (OrdMap k a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance Functor (OrdMap k) where +-- fmap :: (a -> b) -> OrdMap k a -> OrdMap k b + fmap = mapOrdMap -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Ord k, M.Monoid a) => M.Monoid (OrdMap k a) where +-- mempty :: OrdMap k a + mempty = emptyOrdMap +-- mappend :: OrdMap k a -> OrdMap k a -> OrdMap k a + mappend map0 map1 = unionOrdMap M.mappend map0 map1 +-- mconcat :: [OrdMap k a] -> OrdMap k a + mconcat maps = L.foldr (unionOrdMap M.mappend) emptyOrdMap maps + +------------------- +-- Data.Foldable -- +------------------- +instance F.Foldable (OrdMap k) where +-- fold :: Monoid m => OrdMap k m -> m + fold mp = foldElemsAscOrdMap M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> OrdMap k a -> m + foldMap f mp = foldElemsAscOrdMap (\a b -> M.mappend (f a) b) M.mempty mp +-- foldr :: (a -> b -> b) -> b -> OrdMap k a -> b + foldr f b0 mp = foldElemsAscOrdMap f b0 mp +-- foldl :: (a -> b -> a) -> a -> OrdMap k b -> a + foldl f b0 mp = foldElemsDescOrdMap (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- foldr1 :: (a -> a -> a) -> OrdMap k a -> a + foldr1 = undefined +-- foldl1 :: (a -> a -> a) -> OrdMap k a -> a + foldl1 = undefined +-} diff --git a/src/Data/GMap/TupleMap.hs b/src/Data/GMap/TupleMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/TupleMap.hs @@ -0,0 +1,366 @@ +{-# OPTIONS_GHC -fglasgow-exts -fno-monomorphism-restriction -Wall -fno-warn-missing-signatures #-} + +module Data.GMap.TupleMap +(-- * Tuple2Map type + Tuple2Map +,Tuple3Map +,Tuple4Map +,Tuple5Map +) where + +import Prelude hiding (foldr,map,filter,lookup) +import Data.GMap +import Data.GMap.InjectKeys + +import Data.Typeable +import qualified Data.Foldable as F +import qualified Data.Monoid as M +import Data.Ord +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L (foldr,foldl') +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 +import Control.Monad (mplus) + +-------------------------------------------------------------------------------------------- +-- Map Type for tuples and various helper functions -- +-------------------------------------------------------------------------------------------- + +data Tuple2Map map1 map2 k1 k2 a = Tuple2Map !(map1 (map2 a)) +-- Maintain the invariant that the nested maps are non-empty +emptyInnerMapError funName = error ("Data.GMap.Tuple2Map." ++ funName ++ ": Empty inner map") + +-- | Tuple2Map is an instance of Map. +instance (Map map1 k1, Map map2 k2) => Map (Tuple2Map map1 map2 k1 k2) (k1,k2) where + empty = emptyTuple2Map + singleton = singletonTuple2Map +-- pair = pairTuple2Map + nonEmpty = nonEmptyTuple2Map + status = statusTuple2Map + addSize = addSizeTuple2Map + lookup = lookupTuple2Map + lookupCont = lookupContTuple2Map + alter = alterTuple2Map + insertWith = insertWithTuple2Map + insertWith' = insertWithTuple2Map' + insertMaybe = insertMaybeTuple2Map +-- fromAssocsWith = fromAssocsWithTuple2Map +-- fromAssocsMaybe = fromAssocsMaybeTuple2Map + delete = deleteTuple2Map + adjustWith = adjustWithTuple2Map + adjustWith' = adjustWithTuple2Map' + adjustMaybe = adjustMaybeTuple2Map + venn = vennTuple2Map + venn' = vennTuple2Map' + vennMaybe = vennMaybeTuple2Map + disjointUnion = disjointUnionTuple2Map + union = unionTuple2Map + union' = unionTuple2Map' + unionMaybe = unionMaybeTuple2Map + intersection = intersectionTuple2Map + intersection' = intersectionTuple2Map' + intersectionMaybe = intersectionMaybeTuple2Map + difference = differenceTuple2Map + differenceMaybe = differenceMaybeTuple2Map + isSubsetOf = isSubsetOfTuple2Map + isSubmapOf = isSubmapOfTuple2Map + map = mapTuple2Map + map' = mapTuple2Map' + mapMaybe = mapMaybeTuple2Map + mapWithKey = mapWithKeyTuple2Map + mapWithKey' = mapWithKeyTuple2Map' + filter = filterTuple2Map + foldKeys = foldKeysTuple2Map + foldElems = foldElemsTuple2Map + foldAssocs = foldAssocsTuple2Map + foldKeys' = foldKeysTuple2Map' + foldElems' = foldElemsTuple2Map' + foldAssocs' = foldAssocsTuple2Map' + foldElemsUInt = foldElemsUIntTuple2Map + valid = validTuple2Map + +instance (OrderedMap map1 k1, OrderedMap map2 k2) => OrderedMap (Tuple2Map map1 map2 k1 k2) (k1,k2) where + compareKey = compareKeyTuple2Map + fromAssocsAscWith = fromAssocsAscWithTuple2Map + fromAssocsDescWith = fromAssocsDescWithTuple2Map + fromAssocsAscMaybe = fromAssocsAscMaybeTuple2Map + fromAssocsDescMaybe = fromAssocsDescMaybeTuple2Map + foldElemsAsc = foldElemsAscTuple2Map + foldElemsDesc = foldElemsDescTuple2Map + foldKeysAsc = foldKeysAscTuple2Map + foldKeysDesc = foldKeysDescTuple2Map + foldAssocsAsc = foldAssocsAscTuple2Map + foldAssocsDesc = foldAssocsDescTuple2Map + foldElemsAsc' = foldElemsAscTuple2Map' + foldElemsDesc' = foldElemsDescTuple2Map' + foldKeysAsc' = foldKeysAscTuple2Map' + foldKeysDesc' = foldKeysDescTuple2Map' + foldAssocsAsc' = foldAssocsAscTuple2Map' + foldAssocsDesc' = foldAssocsDescTuple2Map' + +on f g a b = f $ g a b + +emptyTuple2Map = Tuple2Map empty +singletonTuple2Map (k1,k2) a = Tuple2Map (singleton k1 (singleton k2 a)) + +nonEmptyTuple2Map (Tuple2Map mp) = Tuple2Map `fmap` nonEmpty mp + +statusTuple2Map (Tuple2Map mp) = + case status mp of + None -> None + One k1 mp' -> case status mp' of + None -> emptyInnerMapError "status" + One k2 a -> One (k1,k2) a + Many -> Many + Many -> Many + +addSizeTuple2Map (Tuple2Map mp) i = foldElemsUInt addSize i mp + +lookupTuple2Map (k1,k2) (Tuple2Map mp) = lookupCont (lookup k2) k1 mp +lookupContTuple2Map f (k1,k2) (Tuple2Map mp) = lookupCont (lookupCont f k2) k1 mp + +alterTuple2Map f (k1,k2) (Tuple2Map mp) = Tuple2Map (alter' alt k1 mp) + where alt Nothing = singleton k2 `fmap` (f Nothing) + alt (Just mp') = nonEmpty (alter f k2 mp') + +insertWithTuple2Map f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertWith' (insertWith f k2 a) k1 (singleton k2 a) mp) +insertWithTuple2Map' f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertWith' (insertWith' f k2 a) k1 (singleton k2 a) mp) +insertMaybeTuple2Map f (k1,k2) a (Tuple2Map mp) = Tuple2Map (insertMaybe' (nonEmpty . insertMaybe f k2 a) k1 (singleton k2 a) mp) + +deleteTuple2Map (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustMaybe' (nonEmpty . delete k2) k1 mp) + +adjustWithTuple2Map f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustWith' (adjustWith f k2) k1 mp) +adjustWithTuple2Map' f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustWith' (adjustWith' f k2) k1 mp) +adjustMaybeTuple2Map f (k1,k2) (Tuple2Map mp) = Tuple2Map (adjustMaybe' (nonEmpty . adjustMaybe f k2) k1 mp) + +vennTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map 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) mp1 mp2 + +vennTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map 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) mp1 mp2 + +vennMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = (Tuple2Map leftDiff, Tuple2Map inter, Tuple2Map 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) mp1 mp2 + +disjointUnionTuple2Map (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' disjointUnion mp1 mp2) +unionTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' (union f) mp1 mp2) +unionTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (union' (union' f) mp1 mp2) +unionMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (unionMaybe' (nonEmpty `on` unionMaybe f) mp1 mp2) + +intersectionTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersection f) mp1 mp2) +intersectionTuple2Map' f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersection' f) mp1 mp2) +intersectionMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (intersectionMaybe' (nonEmpty `on` intersectionMaybe f) mp1 mp2) + +differenceTuple2Map (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (differenceMaybe' (nonEmpty `on` difference) mp1 mp2) +differenceMaybeTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = Tuple2Map (differenceMaybe' (nonEmpty `on` differenceMaybe f) mp1 mp2) + +isSubsetOfTuple2Map (Tuple2Map mp1) (Tuple2Map mp2) = isSubmapOf isSubsetOf mp1 mp2 +isSubmapOfTuple2Map f (Tuple2Map mp1) (Tuple2Map mp2) = isSubmapOf (isSubmapOf f) mp1 mp2 + +mapTuple2Map f (Tuple2Map mp) = Tuple2Map (map' (map f) mp) +mapTuple2Map' f (Tuple2Map mp) = Tuple2Map (map' (map' f) mp) +mapMaybeTuple2Map f (Tuple2Map mp) = Tuple2Map (mapMaybe' (nonEmpty . mapMaybe f) mp) +mapWithKeyTuple2Map f (Tuple2Map mp) = Tuple2Map (mapWithKey' (\k1 mp' -> mapWithKey (\k2 a -> f (k1,k2) a) mp') mp) +mapWithKeyTuple2Map' f (Tuple2Map mp) = Tuple2Map (mapWithKey' (\k1 mp' -> mapWithKey' (\k2 a -> f (k1,k2) a) mp') mp) + +filterTuple2Map f (Tuple2Map mp) = Tuple2Map (mapMaybe' (nonEmpty . filter f) mp) + +foldKeysTuple2Map f b (Tuple2Map mp) = foldAssocs (\k1 mp' b' -> foldKeys (\k2 b'' -> f (k1,k2) b'') b' mp') b mp +foldKeysTuple2Map' f b (Tuple2Map mp) = foldAssocs' (\k1 mp' b' -> foldKeys' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp +foldKeysAscTuple2Map f b (Tuple2Map mp) = foldAssocsAsc (\k1 mp' b' -> foldKeysAsc (\k2 b'' -> f (k1,k2) b'') b' mp') b mp +foldKeysAscTuple2Map' f b (Tuple2Map mp) = foldAssocsAsc' (\k1 mp' b' -> foldKeysAsc' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp +foldKeysDescTuple2Map f b (Tuple2Map mp) = foldAssocsDesc (\k1 mp' b' -> foldKeysDesc (\k2 b'' -> f (k1,k2) b'') b' mp') b mp +foldKeysDescTuple2Map' f b (Tuple2Map mp) = foldAssocsDesc' (\k1 mp' b' -> foldKeysDesc' (\k2 b'' -> f (k1,k2) b'') b' mp') b mp + +foldElemsTuple2Map f b (Tuple2Map mp) = foldElems (\mp' b' -> foldElems f b' mp') b mp +foldElemsTuple2Map' f b (Tuple2Map mp) = foldElems' (\mp' b' -> foldElems' f b' mp') b mp +foldElemsAscTuple2Map f b (Tuple2Map mp) = foldElemsAsc (\mp' b' -> foldElemsAsc f b' mp') b mp +foldElemsAscTuple2Map' f b (Tuple2Map mp) = foldElemsAsc' (\mp' b' -> foldElemsAsc' f b' mp') b mp +foldElemsDescTuple2Map f b (Tuple2Map mp) = foldElemsDesc (\mp' b' -> foldElemsDesc f b' mp') b mp +foldElemsDescTuple2Map' f b (Tuple2Map mp) = foldElemsDesc' (\mp' b' -> foldElemsDesc' f b' mp') b mp + +foldAssocsTuple2Map f b (Tuple2Map mp) = foldAssocs (\k1 mp' b' -> foldAssocs (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp +foldAssocsTuple2Map' f b (Tuple2Map mp) = foldAssocs' (\k1 mp' b' -> foldAssocs' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp +foldAssocsAscTuple2Map f b (Tuple2Map mp) = foldAssocsAsc (\k1 mp' b' -> foldAssocsAsc (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp +foldAssocsAscTuple2Map' f b (Tuple2Map mp) = foldAssocsAsc' (\k1 mp' b' -> foldAssocsAsc' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp +foldAssocsDescTuple2Map f b (Tuple2Map mp) = foldAssocsDesc (\k1 mp' b' -> foldAssocsDesc (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp +foldAssocsDescTuple2Map' f b (Tuple2Map mp) = foldAssocsDesc' (\k1 mp' b' -> foldAssocsDesc' (\k2 a b'' -> f (k1,k2) a b'') b' mp') b mp + +foldElemsUIntTuple2Map f b (Tuple2Map mp) = foldElemsUInt (\mp' b' -> foldElemsUInt f b' mp') b mp + +-- Util function for fromAssocs +-- Note that the fold is building difference lists +clump [] = [] +clump kas = clumps' [(k',c' [])] + where (k', c', clumps') = L.foldl' f (fst $ fst $ head kas,id,id) kas + f (currentKey,currentClump,clumps) ((k1,k2),a) = + if k1 == currentKey + then (currentKey, currentClump . ((k2,a):), clumps ) + else (k1, ((k2,a):), clumps . ((currentKey,currentClump []):) ) + +fromAssocsAscWithTuple2Map f kkas = Tuple2Map (fromAssocsAsc [(k1,fromAssocsAscWith f kas) | (k1,kas) <- clump kkas]) +fromAssocsDescWithTuple2Map f kkas = Tuple2Map (fromAssocsDesc [(k1,fromAssocsDescWith f kas) | (k1,kas) <- clump kkas]) + +fromAssocsAscMaybeTuple2Map f kkas = Tuple2Map (mapMaybe' nonEmpty (fromAssocsAsc [(k1,fromAssocsAscMaybe f kas) | (k1,kas) <- clump kkas])) +fromAssocsDescMaybeTuple2Map f kkas = Tuple2Map (mapMaybe' nonEmpty (fromAssocsDesc [(k1,fromAssocsDescMaybe f kas) | (k1,kas) <- clump kkas])) + +validTuple2Map (Tuple2Map mp) = + case valid mp of + Nothing -> foldElems (\mp' b -> valid mp' `mplus` b) Nothing mp + je -> je + +compareKeyTuple2Map tmp (k1a,k2a) (k1b,k2b) = + case compareKey (firstMap tmp) k1a k1b of + LT -> LT + EQ -> case compareKey (secondMap tmp) k2a k2b of + LT -> LT + EQ -> EQ + GT -> GT + GT -> GT + where firstMap :: Tuple2Map map1 map2 k1 k2 a -> map1 a + firstMap _ = undefined + secondMap :: Tuple2Map map1 map2 k1 k2 a -> map2 a + secondMap _ = undefined + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance Eq (map1 (map2 a)) => Eq (Tuple2Map map1 map2 k1 k2 a) where + Tuple2Map mapa == Tuple2Map mapb = mapa == mapb + +--------- +-- Ord -- +--------- +instance (Map map1 k1, Map map2 k2, Ord (map1 (map2 a))) => Ord (Tuple2Map map1 map2 k1 k2 a) where + compare (Tuple2Map mapa) (Tuple2Map mapb) = compare mapa mapb + +---------- +-- Show -- +---------- +instance (Map map1 k1, Map map2 k2, Show k1, Show k2, Show a) => Show (Tuple2Map map1 map2 k1 k2 a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocs " . shows (assocs mp) + +---------- +-- Read -- +---------- +instance (Map map1 k1, Map map2 k2, R.Read k1, R.Read k2, R.Read a) => R.Read (Tuple2Map map1 map2 k1 k2 a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP + xs <- R.readPrec + return (fromAssocs xs) + readListPrec = R.readListPrecDefault + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance (Typeable1 map1, Typeable1 map2) => Typeable1 (Tuple2Map map1 map2 k1 k2) where + typeOf1 m = mkTyConApp (mkTyCon "Data.GMap.TupleMap.Tuple2Map") [typeOf1 map] + where Tuple2Map map = m -- This is just to get types for map1 & map2 !! +-------------- +instance (Typeable1 (Tuple2Map map1 map2 k1 k2), Typeable a) => Typeable (Tuple2Map map1 map2 k1 k2 a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance (Map map1 k1, Map map2 k2) => Functor (Tuple2Map map1 map2 k1 k2) where +-- fmap :: (a -> b) -> Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 b + fmap = mapTuple2Map -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (Map map1 k1, Map map2 k2, M.Monoid a) => M.Monoid (Tuple2Map map1 map2 k1 k2 a) where +-- mempty :: Tuple2Map map1 map2 k1 k2 a + mempty = emptyTuple2Map +-- mappend :: Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 a -> Tuple2Map map1 map2 k1 k2 a + mappend map0 map1 = unionTuple2Map M.mappend map0 map1 +-- mconcat :: [Tuple2Map map1 map2 k1 k2 a] -> Tuple2Map map1 map2 k1 k2 a + mconcat maps = L.foldr (unionTuple2Map M.mappend) emptyTuple2Map maps + +------------------- +-- Data.Foldable -- +------------------- +instance (Map map1 k1, Map map2 k2) => F.Foldable (Tuple2Map map1 map2 k1 k2) where +-- fold :: Monoid m => Tuple2Map map1 map2 m -> m + fold mp = foldElemsTuple2Map M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> Tuple2Map map1 map2 k1 k2 a -> m + foldMap f mp = foldElemsTuple2Map (\a b -> M.mappend (f a) b) M.mempty mp +-- fold :: (a -> b -> b) -> b -> Tuple2Map map1 map2 k1 k2 a -> b + foldr f b0 mp = foldElemsTuple2Map f b0 mp +-- foldl :: (a -> b -> a) -> a -> Tuple2Map map1 map2 k1 k2 b -> a + foldl f b0 mp = foldElemsTuple2Map (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- fold1 :: (a -> a -> a) -> Tuple2Map map1 map2 k1 k2 a -> a + fold1 = undefined +-- foldl1 :: (a -> a -> a) -> Tuple2Map map1 map2 k1 k2 a -> a + foldl1 = undefined +-} + +------------------------------------------------------------------------------- + +-- Larger tuples are mapped recursively + +data InjectTuple3 a b c + +instance Injection (InjectTuple3 a b c) (a,b,c) (a,(b,c)) where + inject _ (a,b,c) = (a,(b,c)) + outject _ (a,(b,c)) = (a,b,c) + +type Tuple3Map mapa mapb mapc a b c = + InjectKeys (InjectTuple3 a b c) (a,b,c) (a,(b,c)) + (Tuple2Map mapa + (Tuple2Map mapb mapc b c) + a (b,c)) + + + +data InjectTuple4 a b c d + +instance Injection (InjectTuple4 a b c d) (a,b,c,d) (a,(b,(c,d))) where + inject _ (a,b,c,d) = (a,(b,(c,d))) + outject _ (a,(b,(c,d))) = (a,b,c,d) + +type Tuple4Map mapa mapb mapc mapd a b c d = + InjectKeys (InjectTuple4 a b c d) (a,b,c,d) (a,(b,(c,d))) + (Tuple2Map mapa + (Tuple2Map mapb + (Tuple2Map mapc mapd c d) + b (c,d)) + a (b,(c,d))) + + + +data InjectTuple5 a b c d e + +instance Injection (InjectTuple5 a b c d e) (a,b,c,d,e) (a,(b,(c,(d,e)))) where + inject _ (a,b,c,d,e) = (a,(b,(c,(d,e)))) + outject _ (a,(b,(c,(d,e)))) = (a,b,c,d,e) + +type Tuple5Map mapa mapb mapc mapd mape a b c d e = + InjectKeys (InjectTuple5 a b c d e) (a,b,c,d,e) (a,(b,(c,(d,e)))) + (Tuple2Map mapa + (Tuple2Map mapb + (Tuple2Map mapc + (Tuple2Map mapd mape d e) + c (d,e)) + b (c,(d,e))) + a (b,(c,(d,e)))) diff --git a/src/Data/GMap/UnitMap.hs b/src/Data/GMap/UnitMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/GMap/UnitMap.hs @@ -0,0 +1,266 @@ +{-# OPTIONS_GHC -fglasgow-exts -Wall -fno-warn-orphans -fno-warn-unused-imports -fno-warn-missing-signatures #-} + +module Data.GMap.UnitMap +(-- * UnitMap type + UnitMap +) where + +import Data.GMap + +import qualified Data.Monoid as M (Monoid(..)) +import qualified Data.Foldable as F (Foldable(..)) +import Data.Typeable +-- -fno-warn-unused-imports used because ghc currently gives spurious warning with this import +-- See Tickets 1074 and 1148 +import qualified Data.List as L (foldr) + +import GHC.Base hiding (map) +import qualified Text.Read as R (Read(..),Lexeme(..),parens,prec,lexP,readListPrecDefault) + +import Data.Maybe + +-- | The default 'Map' type unit (empty tuple) keys. +newtype UnitMap a = UnitMap (Maybe a) + +instance Map UnitMap () where + empty = emptyUnitMap + singleton = singletonUnitMap + pair = pairUnitMap + nonEmpty = nonEmptyUnitMap + status = statusUnitMap + addSize = addSizeUnitMap + lookup = lookupUnitMap + alter = alterUnitMap + vennMaybe = vennMaybeUnitMap + unionMaybe = unionMaybeUnitMap + isSubsetOf = isSubsetOfUnitMap + isSubmapOf = isSubmapOfUnitMap + mapMaybe = mapMaybeUnitMap + mapWithKey = mapWithKeyUnitMap + mapWithKey' = mapWithKeyUnitMap' + filter = filterUnitMap + foldKeys = foldKeysUnitMap + foldElems = foldElemsUnitMap + foldAssocs = foldAssocsUnitMap + foldKeys' = foldKeysUnitMap + foldElems' = foldElemsUnitMap + foldAssocs' = foldAssocsUnitMap + foldElemsUInt = foldElemsUIntUnitMap + valid = validUnitMap + +instance OrderedMap UnitMap () where + compareKey = compareKeyUnitMap + -- fromAssocsAscWith + -- fromAssocsDescWith + -- fromAssocsAscMaybe + -- fromAssocsDescMaybe + foldElemsAsc = foldElemsUnitMap + foldElemsDesc = foldElemsUnitMap + foldKeysAsc = foldKeysUnitMap + foldKeysDesc = foldKeysUnitMap + foldAssocsAsc = foldAssocsUnitMap + foldAssocsDesc = foldAssocsUnitMap + foldElemsAsc' = foldElemsUnitMap + foldElemsDesc' = foldElemsUnitMap + foldKeysAsc' = foldKeysUnitMap + foldKeysDesc' = foldKeysUnitMap + foldAssocsAsc' = foldAssocsUnitMap + foldAssocsDesc' = foldAssocsUnitMap + +-- | See 'Map' class method 'empty'. +emptyUnitMap :: UnitMap a +emptyUnitMap = UnitMap Nothing +{-# INLINE emptyUnitMap #-} + +-- | See 'Map' class method 'singleton'. +singletonUnitMap :: () -> a -> UnitMap a +singletonUnitMap _ a = UnitMap (Just a) +{-# INLINE singletonUnitMap #-} + +-- | See 'Map' class method 'pair'. +pairUnitMap :: () -> () -> Maybe (a -> a -> UnitMap a) +pairUnitMap _ _ = Nothing -- Args are always equal!! +{-# INLINE pairUnitMap #-} + +-- | See 'Map' class method 'nonEmpty'. +nonEmptyUnitMap :: UnitMap a -> Maybe (UnitMap a) +nonEmptyUnitMap (UnitMap Nothing) = Nothing +nonEmptyUnitMap ugt = Just ugt + +-- | See 'Map' class method 'status'. +statusUnitMap :: UnitMap a -> Status () a +statusUnitMap (UnitMap (Just a)) = One () a +statusUnitMap _ = None + +-- | See 'Map' class method 'addSize'. +addSizeUnitMap :: UnitMap a -> Int# -> Int# +addSizeUnitMap (UnitMap Nothing) n = n +addSizeUnitMap _ n = (n +# 1#) + +-- | See 'Map' class method 'Data.GMap.lookup'. +lookupUnitMap :: () -> UnitMap a -> Maybe a +lookupUnitMap _ (UnitMap mba) = mba +{-# INLINE lookupUnitMap #-} + +alterUnitMap :: (Maybe a -> Maybe a) -> () -> UnitMap a -> UnitMap a +alterUnitMap f _ (UnitMap mba) = UnitMap (f mba) + +-- | See 'Map' class method 'vennMaybe' +vennMaybeUnitMap :: (a -> b -> Maybe c) -> UnitMap a -> UnitMap b -> (UnitMap a, UnitMap c, UnitMap b) +vennMaybeUnitMap _ (UnitMap Nothing) (UnitMap Nothing) = (UnitMap Nothing, UnitMap Nothing, UnitMap Nothing) +vennMaybeUnitMap _ (UnitMap ja ) (UnitMap Nothing) = (UnitMap ja , UnitMap Nothing, UnitMap Nothing) +vennMaybeUnitMap _ (UnitMap Nothing) (UnitMap jb ) = (UnitMap Nothing, UnitMap Nothing, UnitMap jb ) +vennMaybeUnitMap f (UnitMap (Just a)) (UnitMap (Just b)) = (UnitMap Nothing, UnitMap (f a b), UnitMap Nothing) + +-- | See 'Map' class method 'unionMaybe'. +unionMaybeUnitMap :: (a -> a -> Maybe a) -> UnitMap a -> UnitMap a -> UnitMap a +unionMaybeUnitMap _ (UnitMap Nothing) (UnitMap Nothing) = UnitMap Nothing +unionMaybeUnitMap _ (UnitMap ja ) (UnitMap Nothing) = UnitMap ja +unionMaybeUnitMap _ (UnitMap Nothing) (UnitMap jb ) = UnitMap jb +unionMaybeUnitMap f (UnitMap (Just a)) (UnitMap (Just b)) = UnitMap (f a b) + +-- | See 'Map' class method 'isSubsetOf'. +isSubsetOfUnitMap :: UnitMap a -> UnitMap b -> Bool +isSubsetOfUnitMap (UnitMap Nothing ) _ = True +isSubsetOfUnitMap (UnitMap (Just _)) (UnitMap (Just _)) = True +isSubsetOfUnitMap _ _ = False + +-- | See 'Map' class method 'isSubmapOf'. +isSubmapOfUnitMap :: (a -> b -> Bool) -> UnitMap a -> UnitMap b -> Bool +isSubmapOfUnitMap _ (UnitMap Nothing ) _ = True +isSubmapOfUnitMap f (UnitMap (Just a)) (UnitMap (Just b)) = f a b +isSubmapOfUnitMap _ _ _ = False + +-- | See 'Map' class method 'Data.GMap.mapMaybe'. +mapMaybeUnitMap :: (a -> Maybe b) -> UnitMap a -> UnitMap b +mapMaybeUnitMap f (UnitMap (Just a)) = UnitMap (f a) +mapMaybeUnitMap _ _ = emptyUnitMap + +-- | See 'Map' class method 'mapWithKey'. +mapWithKeyUnitMap :: (() -> a -> b) -> UnitMap a -> UnitMap b +mapWithKeyUnitMap f (UnitMap (Just a)) = UnitMap (Just (f () a)) +mapWithKeyUnitMap _ _ = emptyUnitMap + +-- | See 'Map' class method 'mapWithKey''. +mapWithKeyUnitMap' :: (() -> a -> b) -> UnitMap a -> UnitMap b +mapWithKeyUnitMap' f (UnitMap (Just a)) = let b = f () a in b `seq` UnitMap (Just b) +mapWithKeyUnitMap' _ _ = emptyUnitMap + +-- | See 'Map' class method 'Data.GMap.filter'. +filterUnitMap :: (a -> Bool) -> UnitMap a -> UnitMap a +filterUnitMap p u@(UnitMap (Just a)) = if p a then u else emptyUnitMap +filterUnitMap _ _ = emptyUnitMap + +-- | See 'Map' class method 'foldElems' +foldKeysUnitMap :: (() -> b -> b) -> b -> UnitMap a -> b +foldKeysUnitMap f b (UnitMap mba) = case mba of + Just _ -> f () b + Nothing -> b + +-- | See 'Map' class method 'foldElems' +foldElemsUnitMap :: (a -> b -> b) -> b -> UnitMap a -> b +foldElemsUnitMap f b (UnitMap mba) = case mba of + Just a -> f a b + Nothing -> b + +-- | See 'Map' class method 'foldAssocs' +foldAssocsUnitMap :: (() -> a -> b -> b) -> b -> UnitMap a -> b +foldAssocsUnitMap f b (UnitMap mba) = case mba of + Just a -> f () a b + Nothing -> b + +-- | See 'Map' class method 'foldElemsInt#'. +foldElemsUIntUnitMap :: (a -> Int# -> Int#) -> Int# -> UnitMap a -> Int# +foldElemsUIntUnitMap f n (UnitMap mba) = case mba of + Just a -> f a n + Nothing -> n + +-- | See 'Map' class method 'valid'. +validUnitMap :: UnitMap a -> Maybe String +validUnitMap _ = Nothing -- Always valid! +{-# INLINE validUnitMap #-} + +-- | See 'Map' class method 'compareKey' +compareKeyUnitMap :: UnitMap a -> () -> () -> Ordering +compareKeyUnitMap _ _ _ = EQ + +-------------------------------------------------------------------------- +-- OTHER INSTANCES -- +-------------------------------------------------------------------------- + +-------- +-- Eq -- +-------- +instance Eq a => Eq (UnitMap a) where + UnitMap mba0 == UnitMap mba1 = mba0 == mba1 + +--------- +-- Ord -- +--------- +instance Ord a => Ord (UnitMap a) where + compare (UnitMap Nothing ) (UnitMap Nothing ) = EQ + compare (UnitMap Nothing ) (UnitMap (Just _ )) = LT + compare (UnitMap (Just _ )) (UnitMap Nothing ) = GT + compare (UnitMap (Just a0)) (UnitMap (Just a1)) = compare a0 a1 + +---------- +-- Show -- +---------- +instance Show a => Show (UnitMap a) where + showsPrec d mp = showParen (d > 10) $ + showString "fromAssocs " . shows (assocs mp) + +---------- +-- Read -- +---------- +instance R.Read a => R.Read (UnitMap a) where + readPrec = R.parens $ R.prec 10 $ do R.Ident "fromAssocs" <- R.lexP + xs <- R.readPrec + return (fromAssocs xs) + readListPrec = R.readListPrecDefault + +------------------------ +-- Typeable/Typeable1 -- +------------------------ +instance Typeable1 UnitMap where + typeOf1 _ = mkTyConApp (mkTyCon "Data.GMap.UnitMap.UnitMap") [] +-------------- +instance Typeable a => Typeable (UnitMap a) where + typeOf = typeOfDefault + +------------- +-- Functor -- +------------- +instance Functor (UnitMap) where +-- fmap :: (a -> b) -> UnitMap a -> UnitMap b + fmap = Data.GMap.map -- The lazy version + +----------------- +-- Data.Monoid -- +----------------- +instance (M.Monoid a) => M.Monoid (UnitMap a) where +-- mempty :: UnitMap a + mempty = emptyUnitMap +-- mappend :: UnitMap a -> UnitMap a -> UnitMap a + mappend map0 map1 = union M.mappend map0 map1 +-- mconcat :: [UnitMap a] -> UnitMap a + mconcat maps = L.foldr (union M.mappend) emptyUnitMap maps + +------------------- +-- Data.Foldable -- +------------------- +instance F.Foldable (UnitMap) where +-- fold :: Monoid m => UnitMap m -> m + fold mp = foldElemsUnitMap M.mappend M.mempty mp +-- foldMap :: Monoid m => (a -> m) -> UnitMap a -> m + foldMap f mp = foldElemsUnitMap (\a b -> M.mappend (f a) b) M.mempty mp +-- foldr :: (a -> b -> b) -> b -> UnitMap a -> b + foldr f b0 mp = foldElemsUnitMap f b0 mp +-- foldl :: (a -> b -> a) -> a -> UnitMap b -> a + foldl f b0 mp = foldElemsUnitMap (flip f) b0 mp +{- ToDo: Implement properly. Meantime Foldable class has suitable defaults via lists. +-- foldr1 :: (a -> a -> a) -> UnitMap a -> a + foldr1 = undefined +-- foldl1 :: (a -> a -> a) -> UnitMap a -> a + foldl1 = undefined +-} diff --git a/src/Test/GMap.hs b/src/Test/GMap.hs new file mode 100644 --- /dev/null +++ b/src/Test/GMap.hs @@ -0,0 +1,727 @@ +{-# OPTIONS_GHC -fglasgow-exts -XNoMonomorphismRestriction #-} + +module Test.GMap where + +import Test.QuickCheck +import Test.QuickCheck.Batch(bottom,isBottom) +import Test.GMap.Utils + +import Data.GMap as G +import Data.GMap.AssocList +import Data.GMap.ListMap +import Data.GMap.UnitMap +import Data.GMap.MaybeMap +import Data.GMap.EitherMap +import Data.GMap.OrdMap +import Data.GMap.IntMap +-- import Data.GMap.SerialMap +import Data.GMap.CacheKeys +import Data.GMap.TupleMap +import Data.GMap.EnumMap +import Data.GMap.ChoiceMap +-- import Data.GMap.BitMap +import Data.GMap.InjectKeys + +-- import Data.Serial +-- import Data.Serial.Buildable.WordList() + +import qualified Data.List as L +import Prelude hiding (map,lookup) + +import Control.Monad(liftM) +import Data.Maybe +import Data.Ord +import qualified Data.List as L + +import System.IO +import System.Environment + +import GHC.Base hiding (map) + +mapSortKeys :: OrderedMap map k => map a -> [k] -> [k] +mapSortKeys mp = L.sortBy (compareKey mp) + +mapSortAssocs :: OrderedMap map k => map a -> [(k,a)] -> [(k,a)] +mapSortAssocs mp = L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k1 k2) + +-- ### Testing OrderedMap methods ### + +prop_lookup_empty mp k = + Nothing == (lookup k $ empty `like` mp) + +prop_lookup_singleton mp (k,a) = + Just a == (lookup k $ singleton k a `like` mp) + +-- General test pattern +doWith k a mp f = lookup k $ f $ insert k a mp + +-- Another useful pattern +doWithout k mp f = lookup k $ f $ delete k mp + +prop_insert_with mp (k,a) = + Just a == (doWith k a mp $ insert k a) + +prop_insert_without mp (k,a) = + Just a == (doWithout k mp $ insert k a) + +prop_insertWith_with mp (k,a1,a2,f) = + Just (f a1) == (doWith k a1 mp $ insertWith f k a2) + +prop_insertWith_without mp (k,a2,f) = + Just a2 == (doWithout k mp $ insertWith f k a2) + +prop_insertWith'_with mp (k,a1,a2,f) = + Just (f a1) == (doWith k a1 mp $ insertWith' f k a2) + +prop_insertWith'_without mp (k,a2,f) = + Just a2 == (doWithout k mp $ insertWith' f k a2) + +prop_insertMaybe_with mp (k,a1,a2,f) = + (f =<< Just a1) == (doWith k a1 mp $ insertMaybe f k a2) + +prop_insertMaybe_without mp (k,a2,f) = + Just a2 == (doWithout k mp $ insertMaybe f k a2) + +prop_insertMaybe'_with mp (k,a1,a2,f) = + (f =<< Just a1) == (doWith k a1 mp $ insertMaybe' f k a2) + +prop_insertMaybe'_without mp (k,a2,f) = + Just a2 == (doWithout k mp $ insertMaybe' f k a2) + +-- Dont test insertAssocs yet, still not sure whether to include them + +prop_delete_with mp (k,a) = + Nothing == (doWith k a mp $ delete k) + +prop_delete_without mp k = + Nothing == (doWithout k mp $ delete k) + +prop_adjustWith_with mp (k,a,f) = + Just (f a) == (doWith k a mp $ adjustWith f k) + +prop_adjustWith_without mp (k,f) = + Nothing == (doWithout k mp $ adjustWith f k) + +prop_adjustWith'_with mp (k,a,f) = + Just (f a) == (doWith k a mp $ adjustWith' f k) + +prop_adjustWith'_without mp (k,f) = + Nothing == (doWithout k mp $ adjustWith' f k) + +prop_adjustMaybe_with mp (k,a,f) = + (f =<< Just a) == (doWith k a mp $ adjustMaybe f k) + +prop_adjustMaybe_without mp (k,f) = + Nothing == (doWithout k mp $ adjustMaybe f k) + +prop_adjustMaybe'_with mp (k,a,f) = + (f =<< Just a) == (doWith k a mp $ adjustMaybe' f k) + +prop_adjustMaybe'_without mp (k,f) = + Nothing == (doWithout k mp $ adjustMaybe' f k) + +-- The various merges are better tested by the comparison tests + +prop_isSubsetOf mp as = + isSubsetOf mp (insertAssocs as mp) + +prop_isSubmapOf mp (f,as) = + isSubmapOf (\ a b -> f a == b) mp ((map f $ insertAssocsWith const as mp) `like` mp) + +prop_map mp (k,a,f) = + Just (f a) == (doWith k a mp $ \ mp -> map f mp `like` mp) + +prop_map' mp (k,a,f) = + Just (f a) == (doWith k a mp $ \ mp -> map' f mp `like` mp) + +prop_mapMaybe mp (k,a,f) = + (f =<< Just a) == (doWith k a mp $ \ mp -> G.mapMaybe f mp `like` mp) + +prop_mapMaybe' mp (k,a,f) = + (f =<< Just a) == (doWith k a mp $ \ mp -> G.mapMaybe' f mp `like` mp) + +prop_mapWithKey mp (k,a,f) = + Just (f k a) == (doWith k a mp $ \ mp -> mapWithKey f mp `like` mp) + +prop_mapWithKey' mp (k,a,f) = + Just (f k a) == (doWith k a mp $ \ mp -> mapWithKey' f mp `like` mp) + +prop_filter_in mp (k,a) = + Just a == (doWith k a mp $ G.filter (a ==)) + +prop_filter_out mp (k,a) = + Nothing == (doWith k a mp $ G.filter (a /=)) + +-- Dont yet know how to test folds. Need to randomly produce an associative function (or use const and lookup?) + +prop_valid mp () = + Nothing == valid mp + +-- ### Strictness tests for OrderedMap ### +-- For lazy funs make every resulting elem bottom +-- For strict funs make a single resulting elem bottom + +isMaybeBottom a = + (not $ isBottom a) && + case a of + Nothing -> True + Just a' -> isBottom a' + +isLazyAlter mp k f = + let mp' = f mp `like` mp + in (not $ isBottom mp') && + (isMaybeBottom $ lookup k mp') + +isStrictAlter mp k f = + let mp' = f mp `like` mp + in isBottom mp' + +prop_lazy_alter mp k = + isLazyAlter mp k $ alter (\a -> Just bottom) k + +prop_strict_alter' mp k = + isStrictAlter mp k $ alter' (\a -> Just bottom) k + +prop_lazy_insertWith mp k = + isLazyAlter mp k $ insertWith (\a -> bottom) k bottom + +-- insertWith' is currently only strict if the key already exists +-- !!! Remember to change this test if the semantics of insertWith' are changed +prop_strict_insertWith' mp (k,a) = + isStrictAlter (insert k a mp) k $ insertWith' (\a -> bottom) k bottom + +prop_lazy_insertMaybe mp k = + isLazyAlter mp k $ insertMaybe (\a -> Just bottom) k bottom + +-- insertMaybe' is currently only strict if the key already exists +-- !!! Remember to change this test if the semantics of insertMaybe' are changed +prop_strict_insertMaybe' mp (k,a) = + isStrictAlter (insert k a mp) k $ insertMaybe' (\a -> Just bottom) k bottom + +-- For adjusts we need to ensure that k is in the map +prop_lazy_adjustWith mp (k,a) = + isLazyAlter (insert k a mp) k $ adjustWith (\a -> bottom) k + +prop_strict_adjustWith' mp (k,a) = + isStrictAlter (insert k a mp) k $ adjustWith' (\a -> bottom) k + +prop_lazy_adjustMaybe mp (k,a) = + isLazyAlter (insert k a mp) k $ adjustMaybe (\a -> Just bottom) k + +prop_strict_adjustMaybe' mp (k,a) = + isStrictAlter (insert k a mp) k $ adjustMaybe' (\a -> Just bottom) k + +isLazyMerge :: OrderedMap map k => map a -> map a -> k -> (map a -> map a -> map a) -> Bool +isLazyMerge mp1 mp2 k f = + let mp' = f mp1 mp2 `like` mp1 + in (not $ isBottom mp') && + (isMaybeBottom $ lookup k mp') + +isStrictMerge :: OrderedMap map k => map a -> map a -> k -> (map a -> map a -> map a) -> Bool +isStrictMerge mp1 mp2 k f = + let mp' = f mp1 mp2 `like` mp1 + in isBottom mp' + +sel1 (a,b,c) = a +sel2 (a,b,c) = b +sel3 (a,b,c) = c + +-- For merge tests need to ensure that resulting map has at least one assoc or the tests dont work +-- Many of these tests need to have a shared key in both maps. + +prop2_lazy_venn_left (mp1,mp2) (k) = + isLazyMerge (map (const bottom) (insert k bottom mp1)) (delete k mp2) k $ (sel1 `on` venn const) + +prop2_lazy_venn_inter (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ (sel2 `on` venn (\a b -> bottom)) + +prop2_lazy_venn_right (mp1,mp2) (k) = + isLazyMerge (delete k mp1) (map (const bottom) (insert k bottom mp2)) k $ (sel3 `on` venn const) + +prop2_strict_venn'_inter (mp1,mp2) (k,a) = + isStrictMerge (insert k bottom mp1) (insert k a mp2) k $ (sel2 `on` venn' const) + +prop2_lazy_union (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ union (\a b -> bottom) + +prop2_strict_union' (mp1,mp2) (k,a) = + isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ union' (\a b -> a `seq` b `seq` a) + +prop2_lazy_unionMaybe (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ unionMaybe (\a b -> Just bottom) + +prop2_strict_unionMaybe' (mp1,mp2) (k,a) = + isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ unionMaybe' (\a b -> a `seq` b `seq` Just a) + +prop2_lazy_intersection (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ intersection (\a b -> bottom) + +prop2_strict_intersection' (mp1,mp2) (k,a) = + isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ intersection' (\a b -> a `seq` b `seq` a) + +prop2_lazy_intersectionMaybe (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ intersectionMaybe (\a b -> Just bottom) + +prop2_strict_intersectionMaybe' (mp1,mp2) (k,a) = + isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ intersectionMaybe' (\a b -> a `seq` b `seq` Just a) + +prop2_lazy_differenceMaybe (mp1,mp2) (k,a) = + isLazyMerge (insert k a mp1) (insert k a mp2) k $ differenceMaybe (\a b -> Just bottom) + +prop2_strict_differenceMaybe' (mp1,mp2) (k,a) = + isStrictMerge (insert k a mp1) (insert k bottom mp2) k $ differenceMaybe' (\a b -> a `seq` b `seq` Just a) + +-- Need to have a nonEmpty OrderedMap to test strictness of map +prop_lazy_map mp (k,a) = + isLazyAlter (insert k a mp) k $ map (\ a' -> bottom) + +prop_strict_map' mp (k,a) = + isStrictAlter (insert k a mp) k $ map' (\ a' -> if (a==a') then bottom else a') + +prop_lazy_mapMaybe mp (k,a) = + isLazyAlter (insert k a mp) k $ G.mapMaybe (\ a' -> Just bottom) + +prop_strict_mapMaybe' mp (k,a) = + isStrictAlter (insert k a mp) k $ G.mapMaybe' (\ a' -> if (a==a') then (Just bottom) else (Just a')) + +prop_lazy_mapWithKey mp (k,a) = + isLazyAlter (insert k a mp) k $ mapWithKey (\ k' a' -> bottom) + +prop_strict_mapWithKey' mp (k,a) = + isStrictAlter (insert k a mp) k $ mapWithKey' (\ k' a' -> if ((k',a')==(k,a)) then bottom else a') + +-- Lazy and strict folds are identical if the map has zero or one assocs so we must ensure that they have at least two assocs +-- We test folds by ensuring that the first accumalated value is bottom and the rest are Justs. + +foldArg a b + | isBottom b = Just a + | isNothing b = bottom + | otherwise = Just a + +foldArgK _ = foldArg + +prop_lazy_foldKeys mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldKeys foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +prop_strict_foldKeys' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldKeys' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +prop_lazy_foldElems mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldElems foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +prop_strict_foldElems' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldElems' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +prop_lazy_foldAssocs mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldAssocs foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +prop_strict_foldAssocs' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldAssocs' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +-- ### Comparisons to AList ### + +comp_empty mp () = + assocsAsc (empty `like` mp) + +comp_singleton mp (k,a) = + assocsAsc (singleton k a `like` mp) + +comp_pair mp (k1,k2,a1,a2) = + fmap assocsAsc ((fmap (\ f -> f a1 a2) (pair k1 k2)) `like` (Just mp)) + +comp_status mp () = + status mp + +comp_nonEmpty mp () = + fmap assocsAsc $ nonEmpty mp + +comp_addSize mp (I# i) = + I# (addSize mp i) + +comp_lookup mp k = + lookup k mp + +comp_lookupCont mp (k,f) = + lookupCont f k mp `likeMaybeElem` mp + +comp_alter mp (k,f) = + assocsAsc $ alter f k mp + +comp_alter' mp (k,f) = + assocsAsc $ alter' f k mp + +comp_insertWith mp (k,a,f) = + assocsAsc $ insertWith f k a mp + +comp_insertWith' mp (k,a,f) = + assocsAsc $ insertWith' f k a mp + +-- comp_insertAssocsWith : Waiting on updates to OrderedMap api +-- comp_insertAssocsMaybe + +comp_insertMaybe mp (k,a,f) = + assocsAsc $ insertMaybe f k a mp + +comp_insertMaybe' mp (k,a,f) = + assocsAsc $ insertMaybe' f k a mp + +comp_delete mp k = + assocsAsc $ delete k mp + +comp_adjustWith mp (k,f) = + assocsAsc $ adjustWith f k mp + +comp_adjustWith' mp (k,f) = + assocsAsc $ adjustWith' f k mp + +comp_adjustMaybe mp (k,f) = + assocsAsc $ adjustMaybe f k mp + +comp_adjustMaybe' mp (k,f) = + assocsAsc $ adjustMaybe' f k mp + +-- Why dont tuple functors work properly? +-- Note that the type is more constrained than venn. +vennAssocs :: (OrderedMap map k, Ord k) => (map a, map a, map a) -> ([(k,a)],[(k,a)],[(k,a)]) +vennAssocs (mpa,mpc,mpb) = (assocsAsc mpa,assocsAsc mpc,assocsAsc mpb) + +comp2_venn (mp1,mp2) f = + vennAssocs $ venn f mp1 mp2 + +comp2_venn' (mp1,mp2) f = + vennAssocs $ venn' f mp1 mp2 + +comp2_vennMaybe (mp1,mp2) f = + vennAssocs $ vennMaybe f mp1 mp2 + +-- Use venn to obtain disjoint maps - so relies on venn being correct +comp2_disjointUnion (mp1,mp2) () = + assocsAsc $ disjointUnion left right `like` mp1 `like` mp2 + where (left,_,right) = venn const mp1 mp2 + +comp2_union (mp1,mp2) f = + assocsAsc $ union f mp1 mp2 `like` mp1 `like` mp2 + +comp2_union' (mp1,mp2) f = + assocsAsc $ union' f mp1 mp2 `like` mp1 `like` mp2 + +comp2_unionMaybe (mp1,mp2) f = + assocsAsc $ unionMaybe f mp1 mp2 `like` mp1 `like` mp2 + +comp2_unionMaybe' (mp1,mp2) f = + assocsAsc $ unionMaybe' f mp1 mp2 `like` mp1 `like` mp2 + +comp2_intersection (mp1,mp2) f = + assocsAsc $ intersection f mp1 mp2 `like` mp1 `like` mp2 + +comp2_intersection' (mp1,mp2) f = + assocsAsc $ intersection' f mp1 mp2 `like` mp1 `like` mp2 + +comp2_intersectionMaybe (mp1,mp2) f = + assocsAsc $ intersectionMaybe f mp1 mp2 `like` mp1 `like` mp2 + +comp2_intersectionMaybe' (mp1,mp2) f = + assocsAsc $ intersectionMaybe' f mp1 mp2 `like` mp1 `like` mp2 + +comp2_difference (mp1,mp2) () = + assocsAsc $ difference mp1 mp2 `like` mp1 `like` mp2 + +comp2_differenceMaybe (mp1,mp2) f = + assocsAsc $ differenceMaybe f mp1 mp2 `like` mp1 `like` mp2 + +comp2_differenceMaybe' (mp1,mp2) f = + assocsAsc $ differenceMaybe' f mp1 mp2 `like` mp1 `like` mp2 + +comp2_isSubsetOf (mp1,mp2) () = + isSubsetOf mp1 mp2 + +comp2_isSubmapOf (mp1,mp2) f = + isSubmapOf f mp1 mp2 + +comp_map mp f = + assocsAsc $ G.map f mp `like` mp + +comp_map' mp f = + assocsAsc $ G.map' f mp `like` mp + +comp_mapMaybe mp f = + assocsAsc $ G.mapMaybe f mp `like` mp + +comp_mapMaybe' mp f = + assocsAsc $ G.mapMaybe' f mp `like` mp + +comp_mapWithKey mp f = + assocsAsc $ G.mapWithKey f mp `like` mp + +comp_mapWithKey' mp f = + assocsAsc $ G.mapWithKey' f mp `like` mp + +comp_filter mp f = + assocsAsc $ G.filter f mp + +comp_insert mp (k,a) = + assocsAsc $ insert k a mp + +-- Dont compare folds because they depend on ordering + +comp_size mp () = + size mp + +comp_insertAssocs mp as = + assocsAsc $ insertAssocs as mp + +comp_fromAssocs mp as = + assocsAsc $ fromAssocs as `like` mp + +comp_fromAssocsWith mp (f,as) = + assocsAsc $ fromAssocsWith f as `like` mp + +comp2_isProperSubsetOf (mp1,mp2) () = + isProperSubsetOf mp1 mp2 + +comp2_isProperSubmapOfBy (mp1,mp2) f = + isProperSubmapOfBy f mp1 mp2 + +-- comp_lookupM : Need to fix monad + +comp_keys mp () = + mapSortKeys mp $ keys mp + +comp_elems mp () = + mapSortKeys mp $ elems mp + +comp_assocs mp () = + assocsAsc mp + +-- ### Testing OrderedMap methods ### + +propO_keysAsc mp () = + keysAsc mp == (L.map fst $ assocsAsc mp) + +propO_keysDesc mp () = + keysDesc mp == (L.map fst $ assocsDesc mp) + +propO_elemsAsc mp () = + elemsAsc mp == (L.map snd $ assocsAsc mp) + +propO_elemsDesc mp () = + elemsDesc mp == (L.map snd $ assocsDesc mp) + +propO_assocsAsc mp () = + let as = assocsAsc mp + in L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k1 k2) as == as + +propO_assocsDesc mp () = + let as = assocsDesc mp + in L.sortBy (\ (k1,_) (k2,_) -> compareKey mp k2 k1) as == as + +-- ### Strictness tests for OrderedMap ### + +propO_lazy_foldKeysAsc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldKeysAsc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldKeysAsc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldKeysAsc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_lazy_foldKeysDesc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldKeysDesc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldKeysDesc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldKeysDesc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_lazy_foldElemsAsc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldElemsAsc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldElemsAsc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldElemsAsc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_lazy_foldElemsDesc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldElemsDesc foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldElemsDesc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldElemsDesc' foldArg Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_lazy_foldAssocsAsc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldAssocsAsc foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldAssocsAsc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldAssocsAsc' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_lazy_foldAssocsDesc mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + not $ isBottom $ foldAssocsDesc foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +propO_strict_foldAssocsDesc' mp ((k1,a1),(k2,a2)) = + k1 /= k2 ==> + isBottom $ foldAssocsDesc' foldArgK Nothing $ insertAssocs [(k1,a1),(k2,a2)] mp + +keyedLike :: OrderedMap map k => map a -> map b -> map a +keyedLike mp _ = mp + +propO_nubAscWith mp as = + (nubAscWith (empty `keyedLike` mp) as) == (mapSortKeys mp $ L.nub as) + +propO_nubDescWith mp as = + (nubDescWith (empty `keyedLike` mp) as) == (reverse $ mapSortKeys mp $ L.nub as) + +propO_sortAscWith mp as = + (sortAscWith (empty `keyedLike` mp) as) == (mapSortKeys mp as) + +propO_sortDescWith mp as = + (sortDescWith (empty `keyedLike` mp) as) == (reverse $ mapSortKeys mp as) + +-- Most methods better tested by comparisons to SList + +-- ### Comparisons to SList ### + +-- comp_compareKey : Useless because of the newtyping required for SList + +compO_fromAssocsAscWith mp (f,as) = + assocsAsc $ fromAssocsAscWith f (mapSortAssocs mp as) `like` mp + +compO_fromAssocsDescWith mp (f,as) = + assocsAsc $ fromAssocsDescWith f (reverse $ mapSortAssocs mp as) `like` mp + +compO_fromAssocsAscMaybe mp (f,as) = + assocsAsc $ fromAssocsAscMaybe f (mapSortAssocs mp as) `like` mp + +compO_fromAssocsDescMaybe mp (f,as) = + assocsAsc $ fromAssocsDescMaybe f (reverse $ mapSortAssocs mp as) `like` mp + +compO_insertAssocsAscWith mp (f,as) = + assocsAsc $ insertAssocsAscWith f (mapSortAssocs mp as) mp + +compO_insertAssocsDescWith mp (f,as) = + assocsAsc $ insertAssocsDescWith f (reverse $ mapSortAssocs mp as) mp + +compO_insertAssocsAscMaybe mp (f,as) = + assocsAsc $ insertAssocsAscMaybe f (mapSortAssocs mp as) mp + +compO_insertAssocsDescMaybe mp (f,as) = + assocsAsc $ insertAssocsDescMaybe f (reverse $ mapSortAssocs mp as) mp + +compO_foldElemsAsc mp (f,b) = + foldElemsAsc f b mp `likeElem` mp + +compO_foldElemsDesc mp (f,b) = + foldElemsDesc f b mp `likeElem` mp + +compO_foldElemsAsc' mp (f,b) = + foldElemsAsc' f b mp `likeElem` mp + +compO_foldElemsDesc' mp (f,b) = + foldElemsDesc' f b mp `likeElem` mp + +compO_foldKeysAsc mp (f,b) = + foldKeysAsc f b mp `likeElem` mp + +compO_foldKeysDesc mp (f,b) = + foldKeysDesc f b mp `likeElem` mp + +compO_foldKeysAsc' mp (f,b) = + foldKeysAsc' f b mp `likeElem` mp + +compO_foldKeysDesc' mp (f,b) = + foldKeysDesc' f b mp `likeElem` mp + +compO_foldAssocsAsc mp (f,b) = + foldAssocsAsc f b mp `likeElem` mp + +compO_foldAssocsDesc mp (f,b) = + foldAssocsDesc f b mp `likeElem` mp + +compO_foldAssocsAsc' mp (f,b) = + foldAssocsAsc' f b mp `likeElem` mp + +compO_foldAssocsDesc' mp (f,b) = + foldAssocsDesc' f b mp `likeElem` mp + +compO_elemsAsc mp () = + elemsAsc mp + +compO_elemsDesc mp () = + elemsDesc mp + +compO_keysAsc mp () = + keysAsc mp + +compO_keysDesc mp () = + keysDesc mp + +compO_assocsAsc mp () = + assocsAsc mp + +compO_assocsDesc mp () = + assocsDesc mp + +-- Partitions, sorts not yet implemented so not tested. + +-- ### Testing OrdMap methods ### + +-- prop_compareKey mp (k1,k2) = +-- compareKey mp k1 k2 == compare k1 k2 + +-- ### Scripts to collate tests ### + +propList = testList "Test/GMap.hs" "prop_" "SimpleTest " +props = [(SimpleTest prop_lookup_empty,"prop_lookup_empty"),(SimpleTest prop_lookup_singleton,"prop_lookup_singleton"),(SimpleTest prop_insert_with,"prop_insert_with"),(SimpleTest prop_insert_without,"prop_insert_without"),(SimpleTest prop_insertWith_with,"prop_insertWith_with"),(SimpleTest prop_insertWith_without,"prop_insertWith_without"),(SimpleTest prop_insertWith'_with,"prop_insertWith'_with"),(SimpleTest prop_insertWith'_without,"prop_insertWith'_without"),(SimpleTest prop_insertMaybe_with,"prop_insertMaybe_with"),(SimpleTest prop_insertMaybe_without,"prop_insertMaybe_without"),(SimpleTest prop_insertMaybe'_with,"prop_insertMaybe'_with"),(SimpleTest prop_insertMaybe'_without,"prop_insertMaybe'_without"),(SimpleTest prop_delete_with,"prop_delete_with"),(SimpleTest prop_delete_without,"prop_delete_without"),(SimpleTest prop_adjustWith_with,"prop_adjustWith_with"),(SimpleTest prop_adjustWith_without,"prop_adjustWith_without"),(SimpleTest prop_adjustWith'_with,"prop_adjustWith'_with"),(SimpleTest prop_adjustWith'_without,"prop_adjustWith'_without"),(SimpleTest prop_adjustMaybe_with,"prop_adjustMaybe_with"),(SimpleTest prop_adjustMaybe_without,"prop_adjustMaybe_without"),(SimpleTest prop_adjustMaybe'_with,"prop_adjustMaybe'_with"),(SimpleTest prop_adjustMaybe'_without,"prop_adjustMaybe'_without"),(SimpleTest prop_isSubsetOf,"prop_isSubsetOf"),(SimpleTest prop_isSubmapOf,"prop_isSubmapOf"),(SimpleTest prop_map,"prop_map"),(SimpleTest prop_map',"prop_map'"),(SimpleTest prop_mapMaybe,"prop_mapMaybe"),(SimpleTest prop_mapMaybe',"prop_mapMaybe'"),(SimpleTest prop_mapWithKey,"prop_mapWithKey"),(SimpleTest prop_mapWithKey',"prop_mapWithKey'"),(SimpleTest prop_filter_in,"prop_filter_in"),(SimpleTest prop_filter_out,"prop_filter_out"),(SimpleTest prop_valid,"prop_valid"),(SimpleTest prop_lazy_alter,"prop_lazy_alter"),(SimpleTest prop_strict_alter',"prop_strict_alter'"),(SimpleTest prop_lazy_insertWith,"prop_lazy_insertWith"),(SimpleTest prop_strict_insertWith',"prop_strict_insertWith'"),(SimpleTest prop_lazy_insertMaybe,"prop_lazy_insertMaybe"),(SimpleTest prop_strict_insertMaybe',"prop_strict_insertMaybe'"),(SimpleTest prop_lazy_adjustWith,"prop_lazy_adjustWith"),(SimpleTest prop_strict_adjustWith',"prop_strict_adjustWith'"),(SimpleTest prop_lazy_adjustMaybe,"prop_lazy_adjustMaybe"),(SimpleTest prop_strict_adjustMaybe',"prop_strict_adjustMaybe'"),(SimpleTest prop_lazy_map,"prop_lazy_map"),(SimpleTest prop_strict_map',"prop_strict_map'"),(SimpleTest prop_lazy_mapMaybe,"prop_lazy_mapMaybe"),(SimpleTest prop_strict_mapMaybe',"prop_strict_mapMaybe'"),(SimpleTest prop_lazy_mapWithKey,"prop_lazy_mapWithKey"),(SimpleTest prop_strict_mapWithKey',"prop_strict_mapWithKey'"),(SimpleTest prop_lazy_foldKeys,"prop_lazy_foldKeys"),(SimpleTest prop_strict_foldKeys',"prop_strict_foldKeys'"),(SimpleTest prop_lazy_foldElems,"prop_lazy_foldElems"),(SimpleTest prop_strict_foldElems',"prop_strict_foldElems'"),(SimpleTest prop_lazy_foldAssocs,"prop_lazy_foldAssocs"),(SimpleTest prop_strict_foldAssocs',"prop_strict_foldAssocs'")] + +compList = testList "Test/GMap.hs" "comp_" "compareTest " +comps = [(compareTest comp_empty,"comp_empty"),(compareTest comp_singleton,"comp_singleton"),(compareTest comp_pair,"comp_pair"),(compareTest comp_status,"comp_status"),(compareTest comp_nonEmpty,"comp_nonEmpty"),(compareTest comp_addSize,"comp_addSize"),(compareTest comp_lookup,"comp_lookup"),(compareTest comp_lookupCont,"comp_lookupCont"),(compareTest comp_alter,"comp_alter"),(compareTest comp_alter',"comp_alter'"),(compareTest comp_insertWith,"comp_insertWith"),(compareTest comp_insertWith',"comp_insertWith'"),(compareTest comp_insertMaybe,"comp_insertMaybe"),(compareTest comp_insertMaybe',"comp_insertMaybe'"),(compareTest comp_delete,"comp_delete"),(compareTest comp_adjustWith,"comp_adjustWith"),(compareTest comp_adjustWith',"comp_adjustWith'"),(compareTest comp_adjustMaybe,"comp_adjustMaybe"),(compareTest comp_adjustMaybe',"comp_adjustMaybe'"),(compareTest comp_map,"comp_map"),(compareTest comp_map',"comp_map'"),(compareTest comp_mapMaybe,"comp_mapMaybe"),(compareTest comp_mapMaybe',"comp_mapMaybe'"),(compareTest comp_mapWithKey,"comp_mapWithKey"),(compareTest comp_mapWithKey',"comp_mapWithKey'"),(compareTest comp_filter,"comp_filter"),(compareTest comp_insert,"comp_insert"),(compareTest comp_size,"comp_size"),(compareTest comp_insertAssocs,"comp_insertAssocs"),(compareTest comp_fromAssocs,"comp_fromAssocs"),(compareTest comp_fromAssocsWith,"comp_fromAssocsWith"),(compareTest comp_keys,"comp_keys"),(compareTest comp_elems,"comp_elems"),(compareTest comp_assocs,"comp_assocs")] + +prop2List = testList "Test/GMap.hs" "prop2_" "SimpleTest2 " +prop2s = [(SimpleTest2 prop2_lazy_venn_left,"prop2_lazy_venn_left"),(SimpleTest2 prop2_lazy_venn_inter,"prop2_lazy_venn_inter"),(SimpleTest2 prop2_lazy_venn_right,"prop2_lazy_venn_right"),(SimpleTest2 prop2_strict_venn'_inter,"prop2_strict_venn'_inter"),(SimpleTest2 prop2_lazy_union,"prop2_lazy_union"),(SimpleTest2 prop2_strict_union',"prop2_strict_union'"),(SimpleTest2 prop2_lazy_unionMaybe,"prop2_lazy_unionMaybe"),(SimpleTest2 prop2_strict_unionMaybe',"prop2_strict_unionMaybe'"),(SimpleTest2 prop2_lazy_intersection,"prop2_lazy_intersection"),(SimpleTest2 prop2_strict_intersection',"prop2_strict_intersection'"),(SimpleTest2 prop2_lazy_intersectionMaybe,"prop2_lazy_intersectionMaybe"),(SimpleTest2 prop2_strict_intersectionMaybe',"prop2_strict_intersectionMaybe'"),(SimpleTest2 prop2_lazy_differenceMaybe,"prop2_lazy_differenceMaybe"),(SimpleTest2 prop2_strict_differenceMaybe',"prop2_strict_differenceMaybe'")] + +comp2List = testList "Test/GMap.hs" "comp2_" "compareTest2 " +comp2s = [(compareTest2 comp2_venn,"comp2_venn"),(compareTest2 comp2_venn',"comp2_venn'"),(compareTest2 comp2_vennMaybe,"comp2_vennMaybe"),(compareTest2 comp2_disjointUnion,"comp2_disjointUnion"),(compareTest2 comp2_union,"comp2_union"),(compareTest2 comp2_union',"comp2_union'"),(compareTest2 comp2_unionMaybe,"comp2_unionMaybe"),(compareTest2 comp2_unionMaybe',"comp2_unionMaybe'"),(compareTest2 comp2_intersection,"comp2_intersection"),(compareTest2 comp2_intersection',"comp2_intersection'"),(compareTest2 comp2_intersectionMaybe,"comp2_intersectionMaybe"),(compareTest2 comp2_intersectionMaybe',"comp2_intersectionMaybe'"),(compareTest2 comp2_difference,"comp2_difference"),(compareTest2 comp2_differenceMaybe,"comp2_differenceMaybe"),(compareTest2 comp2_differenceMaybe',"comp2_differenceMaybe'"),(compareTest2 comp2_isSubsetOf,"comp2_isSubsetOf"),(compareTest2 comp2_isSubmapOf,"comp2_isSubmapOf"),(compareTest2 comp2_isProperSubsetOf,"comp2_isProperSubsetOf"),(compareTest2 comp2_isProperSubmapOfBy,"comp2_isProperSubmapOfBy")] + +propOList = testList "Test/GMap.hs" "propO_" "SimpleTest " +propOs = [(SimpleTest propO_keysAsc,"propO_keysAsc"),(SimpleTest propO_keysDesc,"propO_keysDesc"),(SimpleTest propO_elemsAsc,"propO_elemsAsc"),(SimpleTest propO_elemsDesc,"propO_elemsDesc"),(SimpleTest propO_assocsAsc,"propO_assocsAsc"),(SimpleTest propO_assocsDesc,"propO_assocsDesc"),(SimpleTest propO_lazy_foldKeysAsc,"propO_lazy_foldKeysAsc"),(SimpleTest propO_strict_foldKeysAsc',"propO_strict_foldKeysAsc'"),(SimpleTest propO_lazy_foldKeysDesc,"propO_lazy_foldKeysDesc"),(SimpleTest propO_strict_foldKeysDesc',"propO_strict_foldKeysDesc'"),(SimpleTest propO_lazy_foldElemsAsc,"propO_lazy_foldElemsAsc"),(SimpleTest propO_strict_foldElemsAsc',"propO_strict_foldElemsAsc'"),(SimpleTest propO_lazy_foldElemsDesc,"propO_lazy_foldElemsDesc"),(SimpleTest propO_strict_foldElemsDesc',"propO_strict_foldElemsDesc'"),(SimpleTest propO_lazy_foldAssocsAsc,"propO_lazy_foldAssocsAsc"),(SimpleTest propO_strict_foldAssocsAsc',"propO_strict_foldAssocsAsc'"),(SimpleTest propO_lazy_foldAssocsDesc,"propO_lazy_foldAssocsDesc"),(SimpleTest propO_strict_foldAssocsDesc',"propO_strict_foldAssocsDesc'"),(SimpleTest propO_nubAscWith,"propO_nubAscWith"),(SimpleTest propO_nubDescWith,"propO_nubDescWith"),(SimpleTest propO_sortAscWith,"propO_sortAscWith"),(SimpleTest propO_sortDescWith,"propO_sortDescWith")] + +compOList = testList "Test/GMap.hs" "compO_" "compareTest " +compOs = [(compareTest compO_fromAssocsAscWith,"compO_fromAssocsAscWith"),(compareTest compO_fromAssocsDescWith,"compO_fromAssocsDescWith"),(compareTest compO_fromAssocsAscMaybe,"compO_fromAssocsAscMaybe"),(compareTest compO_fromAssocsDescMaybe,"compO_fromAssocsDescMaybe"),(compareTest compO_insertAssocsAscWith,"compO_insertAssocsAscWith"),(compareTest compO_insertAssocsDescWith,"compO_insertAssocsDescWith"),(compareTest compO_insertAssocsAscMaybe,"compO_insertAssocsAscMaybe"),(compareTest compO_insertAssocsDescMaybe,"compO_insertAssocsDescMaybe"),(compareTest compO_foldElemsAsc,"compO_foldElemsAsc"),(compareTest compO_foldElemsDesc,"compO_foldElemsDesc"),(compareTest compO_foldElemsAsc',"compO_foldElemsAsc'"),(compareTest compO_foldElemsDesc',"compO_foldElemsDesc'"),(compareTest compO_foldKeysAsc,"compO_foldKeysAsc"),(compareTest compO_foldKeysDesc,"compO_foldKeysDesc"),(compareTest compO_foldKeysAsc',"compO_foldKeysAsc'"),(compareTest compO_foldKeysDesc',"compO_foldKeysDesc'"),(compareTest compO_foldAssocsAsc,"compO_foldAssocsAsc"),(compareTest compO_foldAssocsDesc,"compO_foldAssocsDesc"),(compareTest compO_foldAssocsAsc',"compO_foldAssocsAsc'"),(compareTest compO_foldAssocsDesc',"compO_foldAssocsDesc'"),(compareTest compO_elemsAsc,"compO_elemsAsc"),(compareTest compO_elemsDesc,"compO_elemsDesc"),(compareTest compO_keysAsc,"compO_keysAsc"),(compareTest compO_keysDesc,"compO_keysDesc"),(compareTest compO_assocsAsc,"compO_assocsAsc"),(compareTest compO_assocsDesc,"compO_assocsDesc")] + +unorderedTests = props ++ prop2s ++ comps ++ comp2s -- Cant currently run tests on unordered maps. Easily changed if you complain at me +allTests = props ++ propOs ++ prop2s ++ comps ++ compOs ++ comp2s + +-- ### Some ready made test types ### + +testSList = undefined :: OList Int (Int,Int) +testUnitMap = undefined :: UnitMap Int +testEitherMap = undefined :: EitherMap (OList Int) (OList Bool) Int Bool Int +testMaybeMap = undefined :: MaybeMap (OList Int) Int Int +testOrdMap = undefined :: OrdMap Int Int +testEnumMap = undefined :: EnumMap Bool Int +testIntMap = undefined :: IntMap Int +testListMap = undefined :: ListMap (OList Int) Int Int +testListOrdMap = undefined :: ListMap (OrdMap Char) Char Int +testListIntMap = undefined :: ListMap IntMap Int Int +-- testSerialMap = undefined :: SerialMap Int Int +-- testSerialMap2 = undefined :: SerialMap String Int -- !!! Define arbitrary for some more interesting serialisable types. +-- testCacheKeysSerialMap = undefined :: CacheKeys (SerialMap String) String Int +testTuple2Map = undefined :: Tuple2Map (OList Int) (EnumMap Bool) Int Bool Int +testTuple3Map = undefined :: Tuple3Map (OList Int) (EnumMap Bool) IntMap Int Bool Int Int +testTuple4Map = undefined :: Tuple4Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) Int Bool Int Char Int +testTuple5Map = undefined :: Tuple5Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) (OrdMap String) Int Bool Int Char String Int +testChoice2Map = undefined :: Choice2Map (OList Int) (EnumMap Bool) Int Bool Int +testChoice3Map = undefined :: Choice3Map (OList Int) (EnumMap Bool) IntMap Int Bool Int Int +testChoice4Map = undefined :: Choice4Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) Int Bool Int Char Int +testChoice5Map = undefined :: Choice5Map (OList Int) (EnumMap Bool) IntMap (OrdMap Char) (OrdMap String) Int Bool Int Char String Int +-- testBitMap = undefined :: SafeBitMap Int +-- testUnrollMap = undefined :: UnrollMap Int diff --git a/src/Test/GMap/Utils.hs b/src/Test/GMap/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/GMap/Utils.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fallow-incoherent-instances -XRank2Types -fno-monomorphism-restriction #-} + +module Test.GMap.Utils where + +import Test.QuickCheck + +import Data.GMap +import Data.GMap.ChoiceMap +import qualified Data.List as L +import Control.Monad(liftM) + +import Data.GMap.AssocList + +import System.Random(newStdGen) + +gen n g = do + stdg <- newStdGen + return $ generate n stdg g + +-- eg use: (Just `on` (+)) is (\a b -> Just (a + b)) +on f g a b = f (g a b) + +-- ### QuickCheck instances ### + +instance Show (a->b) where + show _ = "" + +instance (OrderedMap map k, Arbitrary k, Arbitrary a) => Arbitrary (map a) where + arbitrary = liftM fromAssocs (arbitrary :: Gen [(k,a)]) + coarbitrary mp = coarbitrary (assocs mp) + +instance (OrderedMap map k, Show k, Show a) => Show (map a) where + show map = "fromAssocs " ++ (show $ assocs map) + +instance Arbitrary Char where + arbitrary = sized $ \n -> choose (minBound , maxBound `min` (toEnum n)) + coarbitrary c = variant (fromEnum c) + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a,b,c,d,e) where + arbitrary = do + (a,b,c,(d,e)) <- arbitrary + return (a,b,c,d,e) + coarbitrary (a,b,c,d,e) = coarbitrary (a,b,c,(d,e)) + +instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice2 a b) where + arbitrary = oneof [C1of2 `fmap` arbitrary, C2of2 `fmap` arbitrary] + coarbitrary choice = case choice of + C1of2 a -> coarbitrary a + C2of2 b -> coarbitrary b + +instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Choice3 a b c) where + arbitrary = oneof [C1of3 `fmap` arbitrary, C2of3 `fmap` arbitrary, C3of3 `fmap` arbitrary] + coarbitrary choice = case choice of + C1of3 a -> coarbitrary a + C2of3 b -> coarbitrary b + C3of3 c -> coarbitrary c + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Choice4 a b c d) where + arbitrary = oneof [C1of4 `fmap` arbitrary, C2of4 `fmap` arbitrary, C3of4 `fmap` arbitrary, C4of4 `fmap` arbitrary] + coarbitrary choice = case choice of + C1of4 a -> coarbitrary a + C2of4 b -> coarbitrary b + C3of4 c -> coarbitrary c + C4of4 d -> coarbitrary d + +instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (Choice5 a b c d e) where + arbitrary = oneof [C1of5 `fmap` arbitrary, C2of5 `fmap` arbitrary, C3of5 `fmap` arbitrary, C4of5 `fmap` arbitrary, C5of5 `fmap` arbitrary] + coarbitrary choice = case choice of + C1of5 a -> coarbitrary a + C2of5 b -> coarbitrary b + C3of5 c -> coarbitrary c + C4of5 d -> coarbitrary d + C5of5 e -> coarbitrary e + +-- These functions are used to pass types around as undefined arguments. +like = const :: a -> a -> a +likeElem = const :: OrderedMap map k => a -> map a -> a +likeMaybeElem = const :: OrderedMap map k => Maybe a -> map a -> Maybe a + +-- Test type (allows specifying type of map used in tests) +data Test m1 m2 where + -- A simple test - pass in a map and get out something testable + SimpleTest :: Testable b => (m1 -> b) -> Test m1 m2 + -- A simple test that requires two maps. Used for set ops etc + SimpleTest2 :: Testable b => ((m1,m1) -> b) -> Test m1 m2 + -- CompareTest the behaviour of two different maps + CompareTest :: (Arbitrary a, Show a, Eq b) => + (m1 -> a -> b) -> (m2 -> a -> b) -> Test m1 m2 + CompareTest2 :: (Arbitrary a, Show a, Eq b) => + ((m1,m1) -> a -> b) -> ((m2,m2) -> a -> b) -> Test m1 m2 + +compareTest :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => (mp e) -> a -> b) -> Test (mp1 e) (mp2 e) +compareTest f = CompareTest f f +compareTest2 :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => ((mp e),(mp e)) -> a -> b) -> Test (mp1 e) (mp2 e) +compareTest2 f = CompareTest2 f f + +-- Unsurprisingly Tests are Testable +instance (OrderedMap mp1 k, OrderedMap mp2 k, Show (mp1 a), Show (mp2 a), Arbitrary k, Arbitrary a, Show k, Show a) => Testable (Test (mp1 a) (mp2 a)) where + property (SimpleTest f) = property f + property (SimpleTest2 f) = property f + property (CompareTest f1 f2) = property (\ kas a -> f1 (fromAssocs kas) a == f2 (fromAssocs kas) a) + property (CompareTest2 f1 f2) = property (\ kas1 kas2 a -> f1 (fromAssocs kas1, fromAssocs kas2) a == f2 (fromAssocs kas1, fromAssocs kas2) a) + +-- Used to generate lists of tests by parsing the source file +-- Its unfortunate that its necessary, better introspection would make life easier +testList file prefix code = do + source <- readFile file + let props = L.filter (\l -> (L.isPrefixOf prefix l) && (not $ L.isPrefixOf (prefix ++ " ::") l)) $ + L.map head $ L.filter (not.null) $ L.map words $ lines source + let printProp prop = do + putStr "(" + putStr (code ++ prop) + putStr ",\"" + putStr prop + putStr "\")" + putStr "[" + printProp $ head props + mapM_ (\prop -> do + putStr "," + printProp prop) $ tail props + putStrLn "]" + +config n = Config + { configMaxTest = n + , configMaxFail = 1000 + , configSize = (+ 3) . (`div` 2) + , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ] + } + +-- A list of named tests +type Tests m1 m2 = [(Test m1 m2, String)] + +runTests :: (Testable (Test m1 m2)) => Tests m1 m2 -> Int -> IO () +runTests tests n = + mapM_ ( \ (prop,name) -> do + putStr name + putStr " : " + check (config n) prop ) tests + +-- Narrows the type of runTests using the type of the first argument +runAListTest :: (OrderedMap mp k, Testable (Test (mp a) (AList k a))) => (mp a) -> Tests (mp a) (AList k a) -> Int -> IO () +runSListTest :: (OrderedMap mp k, Testable (Test (mp a) (SList mp k a))) => (mp a) -> Tests (mp a) (SList mp k a) -> Int -> IO () +runAListTest _ = runTests +runSListTest _ = runTests