diff --git a/Data/COrdering.hs b/Data/COrdering.hs new file mode 100644 --- /dev/null +++ b/Data/COrdering.hs @@ -0,0 +1,208 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.COrdering +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines a useful variant of the "Prelude" `Ordering` data type. +-- +-- Typically this data type is used as the result of a \"combining comparison\" +-- which combines values that are deemed to be equal (somehow). Note that the +-- functions defined here adhere to the same ordering convention as the overloaded +-- 'compare' (from the 'Ord' class). That is.. +-- +-- @ +-- a \`compare\` b -> LT (or Lt) implies a < b +-- a \`compare\` b -> GT (or Gt) implies a > b +-- @ +-- +-- The combinators exported from this module have a \"CC\" suffix if they +-- return a combining comparison (most of them) and a \"C\" suffix if they return +-- an ordinary comparison. All the combinators defined here are INLINEd, in the hope +-- that the compiler can avoid the overhead of using HOFs for frequently +-- used comparisons (dunno if this does any good though :-) +----------------------------------------------------------------------------- +module Data.COrdering + ( -- * Types + COrdering(..), + + -- * Useful combinators + + -- ** Misc. + unitCC,unitByCC, + fstCC,fstByCC, + sndCC,sndByCC, + flipC,flipCC, + + -- ** For combining \"equal\" values with a user supplied function. + withCC,withCC',withByCC,withByCC', + + ) where + +import Data.Typeable + +-- | Result of a combining comparison. +data COrdering a = Lt | Eq a | Gt deriving (Eq,Ord,Read,Show) + +-- A name for the COrdering type constructor, fully qualified +cOrderingTyConName :: String +cOrderingTyConName = "Data.COrdering.COrdering" + +-- A Typeable1 instance +instance Typeable1 COrdering where + typeOf1 _ = mkTyConApp (mkTyCon cOrderingTyConName) [] + +#ifndef ghc +-- A Typeable instance (not needed by ghc, but Haddock fails to document this instance) +instance Typeable e => Typeable (COrdering e) where + typeOf = typeOfDefault +#endif + +-- | A combining comparison for an instance of 'Ord' which returns unit () where appropriate. +-- +-- >unitCC a b = case compare a b of LT -> Lt +-- > EQ -> Eq () +-- > GT -> Gt +{-# INLINE unitCC #-} +unitCC :: Ord a => (a -> a -> COrdering ()) +unitCC a b = case compare a b of LT -> Lt + EQ -> Eq () + GT -> Gt + +-- | Create a combining comparison from an ordinary comparison by returning unit () where appropriate. +-- +-- >unitByCC cmp a b = case cmp a b of LT -> Lt +-- > EQ -> Eq () +-- > GT -> Gt +{-# INLINE unitByCC #-} +unitByCC :: (a -> b -> Ordering) -> (a -> b -> COrdering ()) +unitByCC cmp a b = case cmp a b of LT -> Lt + EQ -> Eq () + GT -> Gt + +-- | A combining comparison for an instance of 'Ord' which keeps the first argument +-- if they are deemed equal. The second argument is discarded in this case. +-- +-- >fstCC a a' = case compare a a' of LT -> Lt +-- > EQ -> Eq a +-- > GT -> Gt +{-# INLINE fstCC #-} +fstCC :: Ord a => (a -> a -> COrdering a) +fstCC a a' = case compare a a' of LT -> Lt + EQ -> Eq a + GT -> Gt + +-- | Create a combining comparison from an ordinary comparison by keeping the first argument +-- if they are deemed equal. The second argument is discarded in this case. +-- +-- >fstByCC cmp a b = case cmp a b of LT -> Lt +-- > EQ -> Eq a +-- > GT -> Gt +{-# INLINE fstByCC #-} +fstByCC :: (a -> b -> Ordering) -> (a -> b -> COrdering a) +fstByCC cmp a b = case cmp a b of LT -> Lt + EQ -> Eq a + GT -> Gt + +-- | A combining comparison for an instance of 'Ord' which keeps the second argument +-- if they are deemed equal. The first argument is discarded in this case. +-- +-- >sndCC a a' = case compare a a' of LT -> Lt +-- > EQ -> Eq a' +-- > GT -> Gt +{-# INLINE sndCC #-} +sndCC :: Ord a => (a -> a -> COrdering a) +sndCC a a' = case compare a a' of LT -> Lt + EQ -> Eq a' + GT -> Gt + +-- | Create a combining comparison from an ordinary comparison by keeping the second argument +-- if they are deemed equal. The first argument is discarded in this case. +-- +-- >sndByCC cmp a b = case cmp a b of LT -> Lt +-- > EQ -> Eq b +-- > GT -> Gt +{-# INLINE sndByCC #-} +sndByCC :: (a -> b -> Ordering) -> (a -> b -> COrdering b) +sndByCC cmp a b = case cmp a b of LT -> Lt + EQ -> Eq b + GT -> Gt + +-- | Create a combining comparison using the supplied combining function, which is applied if +-- 'compare' returns 'EQ'. See 'withCC'' for a stricter version of this function. +-- +-- >withCC f a a' = case compare a a' of LT -> Lt +-- > EQ -> Eq (f a a') +-- > GT -> Gt +{-# INLINE withCC #-} +withCC :: Ord a => (a -> a -> b) -> (a -> a -> COrdering b) +withCC f a a' = case compare a a' of LT -> Lt + EQ -> Eq (f a a') + GT -> Gt + +-- | Same as 'withCC', except the combining function is applied strictly. +-- +-- >withCC' f a a' = case compare a a' of LT -> Lt +-- > EQ -> let b = f a a' in b `seq` Eq b +-- > GT -> Gt +{-# INLINE withCC' #-} +withCC' :: Ord a => (a -> a -> b) -> (a -> a -> COrdering b) +withCC' f a a' = case compare a a' of LT -> Lt + EQ -> let b = f a a' in b `seq` Eq b + GT -> Gt + +-- | Create a combining comparison using the supplied comparison and combining function, +-- which is applied if the comparison returns 'EQ'. See 'withByCC'' for a stricter version +-- of this function. +-- +-- >withByCC cmp f a b = case cmp a b of LT -> Lt +-- > EQ -> Eq (f a b) +-- > GT -> Gt +{-# INLINE withByCC #-} +withByCC :: (a -> b -> Ordering) -> (a -> b -> c) -> (a -> b -> COrdering c) +withByCC cmp f a b = case cmp a b of LT -> Lt + EQ -> Eq (f a b) + GT -> Gt + +-- | Same as 'withByCC', except the combining function is applied strictly. +-- +-- >withByCC' cmp f a b = case cmp a b of LT -> Lt +-- > EQ -> let c = f a b in c `seq` Eq c +-- > GT -> Gt +{-# INLINE withByCC' #-} +withByCC' :: (a -> b -> Ordering) -> (a -> b -> c) -> (a -> b -> COrdering c) +withByCC' cmp f a b = case cmp a b of LT -> Lt + EQ -> let c = f a b in c `seq` Eq c + GT -> Gt + +-- | Converts a comparison to one which takes arguments in flipped order, but +-- preserves the ordering that would be given by the \"unflipped\" version (disregarding type issues). +-- So it's not the same as using the prelude 'flip' (which would reverse the ordering too). +-- +-- >flipC cmp b a = case cmp a b of LT -> GT +-- > EQ -> EQ +-- > GT -> LT +{-# INLINE flipC #-} +flipC :: (a -> b -> Ordering) -> (b -> a -> Ordering) +flipC cmp b a = case cmp a b of LT -> GT + EQ -> EQ + GT -> LT + +-- | Converts a combining comparison to one which takes arguments in flipped order, but +-- preserves the ordering that would be given by the \"unflipped\" version (disregarding type issues). +-- So it's not the same as using the prelude 'flip' (which would reverse the ordering too). +-- +-- >flipCC cmp b a = case cmp a b of Lt -> Gt +-- > e@(Eq _) -> e +-- > Gt -> Lt +{-# INLINE flipCC #-} +flipCC :: (a -> b -> COrdering c) -> (b -> a -> COrdering c) +flipCC cmp b a = case cmp a b of Lt -> Gt + e@(Eq _) -> e + Gt -> Lt + + diff --git a/Data/Collections.hs b/Data/Collections.hs new file mode 100644 --- /dev/null +++ b/Data/Collections.hs @@ -0,0 +1,1081 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections +-- Copyright : (c) Jean-Philippe Bernardy, 2006 +-- License : BSD3 +-- Maintainer : jeanphilippe.bernardy; google mail. +-- Stability : experimental +-- Portability : MPTC, FD, undecidable instances +-- +-- This module defines a class framework for collection types. It provides: +-- +-- * Classes for the most common type of collections +-- +-- * /View/ types to change the type of a collection, so it implements other classes. +-- This allows to use types for purposes that they are not originally designed for. (eg. 'ElemsView') +-- +-- * A few generic functions for handling collections. +-- +-- * Infix (operator) version of common functions. +-- +-- Should you need a more precise documentation, "Data.Collections.Properties" lists laws that +-- implementations are entitled to assume. +-- +-- The classes defined in this module are intended to give hints about performance. +-- eg. if a function has a @'Map' c k v@ context, this indicates that the function +-- will perform better if @c@ has an efficitent lookup function. +-- +-- This class framework is based on ideas found in Simon Peyton Jones, \"/Bulk types with class/\". +-- +-- +-- Another inspiration source are the examples of MPTC and fuctional dependencies in Oleg Kiselyov's +-- many articles posted to the haskell mailing list. +-- +-- +-- This module name-clashes with a lot of Prelude functions, subsuming those. +-- The user is encouraged to import Prelude hiding the clashing functions. +-- Alternatively, it can be imported @qualified@. +-- + + +{- + + +Selling points: + * Unification of Map and Set (required by the below) + * inclusion of Arrays + * Good integration with existing base libraries + * Relative simplicity: few classes, not too many methods, very little redundancy. + * Reuses the same identifiers as other standard hierarchy modules. + Conversion from the module-based API to this class-based one should be easy. + * Comprehensive set of properties that define the behaviour of the classes. + * Compatibility with GHC and Hugs. + +Bad points + * Extra complexity due to heavy usage of MTPC (although imho it's a matter of getting used to it) + +TODO: + * test with nhc98/hugs + * add missing functions (partition, ..., ?) + * optimizations (rules pragmas) + * see how multimap/multiset fits this scheme. + * Think about class Map' :: (* -> *) -> * -> $ + * Fix infelicity about null map test; (== mempty). +-} + +module Data.Collections + ( +-- * Classes +-- ** Unfoldable + Unfoldable(..), +-- ** Collection + Collection(..), +-- ** Map + Map(..), + lookupWithDefault, + unionsWith, + intersectionWith', + differenceWith', + mapWithKey', + (!), +-- ** Set + Set(..), + unions, + notMember, + (\\), +-- ** Sequence + Sequence(..), + head, + tail, + append, + concat, + concatMap, +-- length, + (<|), + (|>), + (><), +-- ** Others + Array(..), + Indexed(..), + + +-- * Conversions + fromFoldable, + fromAscFoldable, + fromList, + fromListWith, + fromAscList, + +-- * Views + KeysView(..), ElemsView(..), + withKeys, withElems, +-- * Foldable + module Data.Collections.Foldable, + +-- * Concrete collection types + Seq.Seq, + IntMap.IntMap, IntSet.IntSet, + StdSet, StdMap, AvlSet, AvlMap, RangedSet + ) where + +-- import Prelude (Bool(..), Int, Maybe(..), +-- (==), (.), (+), ($), (-), (&&), (||), +-- Eq, Ord, +-- error, const, not, fst, snd, maybe, head, otherwise, curry, uncurry, flip, +-- min, max, Show) + +import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap,drop,head,tail,init) + +import Control.Monad +import Data.Monoid +import Data.Collections.Foldable + +import Data.Sequence (ViewL(..), ViewR(..)) +import qualified Data.Sequence as Seq +import qualified Data.Foldable as AltFoldable + +import qualified Data.Array as Array +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Set.AVL as AvlSet +import qualified Data.Map.AVL as AvlMap +import qualified Data.Set.Enum as EnumSet +import qualified Data.ByteString as BS +import qualified Data.Ranged as Ranged +import Data.Ranged (DiscreteOrdered) +--import qualified Data.ByteString.Char8 as BSC +-- Char8 version cannot be made as long as all bytestrings use the same type. +import qualified Data.ByteString.Lazy as BSL +import Data.Word (Word8) +-- import Data.Int (Int64) +-- import Control.Monad.Identity + +type StdSet = Set.Set +type StdMap = Map.Map +type AvlSet = AvlSet.Set +type AvlMap = AvlMap.Map +type RangedSet = Ranged.RSet + +infixl 9 ! +infixl 9 \\ -- + +infixr 5 >< +infixr 5 <| +infixl 5 |> + +------------------------------------------------------------------------ +-- * Type classes + +-- | Class of collection types. + +class (Foldable c a, Unfoldable c a) => Collection c a | c -> a where + -- | @filter f c@ returns the collection of those elements that satisfy the predicate @f@. + filter :: (a -> Bool) -> c -> c + +-- | Class of collection with unobservable elements. It is the dual of the 'Foldable' class. + +class Unfoldable c i | c -> i where + + -- | \'natural\' insertion of an element into a collection. + insert :: i -> c -> c + --insert i c = cofold (\Right c -> Right c; Left (i,c) -> Left (i,Right c)) (Left (i,c)) + -- | The empty collection. + empty :: c + empty = unfold (const Nothing) undefined + + -- | Creates a collection with a single element. + singleton :: i -> c + singleton i = insert i empty + + -- | Insert all the elements of a foldable. + insertMany :: Foldable c' i => c' -> c -> c + insertMany c' c = foldr insert c c' + -- At first sight, it looks like the above could just use List instead of any Foldable. + -- However, it would then be more difficult to ensure that the conversion could be made + -- very efficient between certain types. + + -- | Same as insertMany, but with the unchecked precondition that the input 'Foldable' is sorted. + insertManySorted :: Foldable c' i => c' -> c -> c + insertManySorted = insertMany + +unfold :: Unfoldable c a => (b -> Maybe (a, b)) -> b -> c +unfold f b = insertMany (List.unfoldr f b) empty + +class Collection c o => SortingCollection c o where + minView :: Monad m => c -> m (o,c) + -- maxView :: Monad m => c -> m (o,c) + + +-- isSorted :: (Ord a, Foldable c a) => c -> Bool +-- isSorted = fst . foldr cmp (True, Nothing) +-- where curr `cmp` (acc, prev) = (acc && maybe True (curr <=) prev, Just curr) + +-- | Conversion from a Foldable to a Collection. +fromFoldable :: (Foldable f a, Collection c' a) => f -> c' +fromFoldable = flip insertMany empty + +-- TODO: Should be specialized (RULE pragmas) so it's efficient when converting from/to set/maps + + +-- | Conversion from a Foldable to a Collection, with the /unchecked/ precondition that the input is sorted +fromAscFoldable :: (Foldable f a, Collection c' a) => f -> c' +fromAscFoldable = flip insertManySorted empty + +-- | Converts a list into a collection. +fromList :: Collection c a => [a] -> c +fromList = fromFoldable + +-- | Converts a list into a collection, with the precondition that the input is sorted. +fromAscList :: Collection c a => [a] -> c +fromAscList = fromAscFoldable + + +-- | Class of sequential-access types. +-- In addition of the 'Collection' services, it provides deconstruction and concatenation. +class (Monoid c, Collection c a) => Sequence c a where + -- | The first @i@ elements of a sequence. + take :: Int -> c -> c + -- | Elements of a sequence after the first @i@. + drop :: Int -> c -> c + -- | Split a sequence at a given index. + splitAt :: Int -> c -> (c,c) + -- | Reverse a sequence. + reverse :: c -> c + -- | Analyse the left end of a sequence. + front :: Monad m => c -> m (a,c) + -- | Analyse the right end of a sequence. + back :: Monad m => c -> m (c,a) + -- | Add an element to the left end of a sequence. + cons :: a -> c -> c + -- | Add an element to the right end of a sequence. + snoc :: c -> a -> c + -- | The 'isPrefix' function takes two seqences and returns True iff + -- the first is a prefix of the second. + isPrefix :: Eq a => c -> c -> Bool + + cons = insert + isPrefix s1 s2 + = case front s1 of + Nothing -> True + Just (x,xs) -> + case front s2 of + Nothing -> False + Just (y,ys) -> x == y && isPrefix xs ys + + +-- -- | Length of a sequence +-- length :: Sequence c i o => c -> Int +-- length = size + +-- | Concatenate two sequences. +append :: Sequence c a => c -> c -> c +append = mappend + +-- TODO: span ? + +-- | Infix version of 'cons': add an element to the left end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(<|) :: Sequence c i => i -> c -> c +(<|) = cons + +-- | Infix version of 'snoc': add an element to the right end of a sequence. +-- Mnemonic: a triangle with the single element at the pointy end. +(|>) :: Sequence c i => c -> i -> c +(|>) = snoc + +-- | Infix verion of 'append'. Concatenate two sequences. +(><) :: Sequence c a => c -> c -> c +(><) = append + + +-- | The concatenation of all the elements of a container of sequences. +concat :: (Sequence s a, Foldable t s) => t -> s +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting sequences. +concatMap :: (Sequence s b, Foldable t a) => (a -> s) -> t -> s +concatMap = foldMap + +head :: Sequence s a => s -> a +head = fst . Maybe.fromJust . front + +tail :: Sequence s a => s -> s +tail = drop 1 + +-- | Class of indexed types. +-- The collection is 'dense': there is no way to /remove/ an element nor for lookup +-- to return "not found". +-- +-- In practice however, most shallow collection types will instanciate this +-- class in addition of 'Map', and leave the responsibility of failure to the caller. +class Indexed c k v | c -> k v where + -- | @index c k@ returns element associated to @k@ + index :: k -> c -> v + -- | @adjust f k c@ applies @f@ to element associated to @k@ and returns the resulting collection. + adjust :: (v -> v) -> k -> c -> c + -- | if @inDomain k c@, then @index c k@ is guaranteed not to fail. + inDomain :: k -> c -> Bool + -- | Constructs a collection identical to the first argument except that it has + -- been updated by the associations in the right argument. + -- For example, if @m@ is a 1-origin, @n@ by @n@ matrix, then + -- + -- > m//[((i,i), 0) | i <- [1..n]] + -- + -- is the same matrix, except with the diagonal zeroed. + (//) :: Foldable l (k,v) => c -> l -> c + (//) = foldr replace + where replace (k,v) = adjust (const v) k + -- | @'accum' f@ takes an array and an association list and accumulates + -- pairs from the list into the array with the accumulating function @f@. + -- Thus 'accumArray' can be defined using 'accum': + accum :: Foldable l (k,v') => (v -> v' -> v) -> c -> l -> c + accum f = foldr adjust' + where adjust' (k,v') = adjust (\v->f v v') k + +-- | Infix version of 'index', with arguments swapped. +(!) :: Indexed c k v => c -> k -> v +(!) = flip index + +class (Array.Ix k, Foldable c (k,v), Indexed c k v) => Array c k v | c -> k v where + -- | if @(l,r) = bounds c@, then @inDomain k c <==> l <= k <= r@ + bounds :: c -> (k,k) + -- | Construct an array with the specified bounds and containing values + -- for given indices within these bounds. + -- + -- The array is undefined (i.e. bottom) if any index in the list is + -- out of bounds. The Haskell 98 Report further specifies that if any + -- two associations in the list have the same index, the value at that + -- index is undefined (i.e. bottom). However in GHC's implementation, + -- the value at such an index is the value part of the last association + -- with that index in the list. + -- + -- Because the indices must be checked for these errors, 'array' is + -- strict in the bounds argument and in the indices of the association + -- list, but nonstrict in the values. Thus, recurrences such as the + -- following are possible: + -- + -- > a = array (1,100) ((1,1) : [(i, i * a!(i-1)) | i <- [2..100]]) + -- + -- Not every index within the bounds of the array need appear in the + -- association list, but the values associated with indices that do not + -- appear will be undefined (i.e. bottom). + -- + -- If, in any dimension, the lower bound is greater than the upper bound, + -- then the array is legal, but empty. Indexing an empty array always + -- gives an array-bounds error, but 'bounds' still yields the bounds + -- with which the array was constructed. + array :: Foldable l (k,v) => (k,k) -> l -> c + + +-- | Class of map-like types. (aka. for sparse associative types). +-- +-- In opposition of Indexed, Map supports unexisting value for some indices. +class Monoid c => Map c k a | c -> k a where + -- | Remove a key from the keySet (and therefore the associated value in the Map). + delete :: k -> c -> c + delete = alter (const Nothing) + + -- | Tells whether an key is member of the keySet. + member :: k -> c -> Bool + member k = Maybe.isJust . lookup k + + -- | Union of two keySets. + -- When duplicates are encountered, the keys may come from any of the two input sets. + -- Values come from the map given as first arguement. + union :: c -> c -> c + union = unionWith const + + -- | Intersection of two keySets. + -- + -- When duplicates are encountered, the keys may come from any of the two input sets. + -- Values come from the map given as first arguement. + intersection :: c -> c -> c + intersection = intersectionWith const + + -- | Difference of two keySets. + -- Difference is to be read infix: @a `difference` b@ returns a set containing the + -- elements of @a@ that are also absent from @b@. + difference :: c -> c -> c + difference = differenceWith (\_ _-> Nothing) + + + -- | @s1 `isSubset` s2@ returns True iff. the keys in s1 form a subset of the keys in s2. + isSubset :: c -> c -> Bool + isSubset = isSubmapBy (\_ _->True) + +-- Follows functions for fully-fledged maps. + -- | Lookup the value at a given key. + lookup :: Monad m => k -> c -> m a + + -- | Change the value associated to a given key. 'Nothing' represents no associated value. + alter :: (Maybe a -> Maybe a) -> k -> c -> c + alter f k m = case f (lookup k m) of + Just a -> insertWith (\x _->x) k a m + Nothing -> delete k m + + -- | Insert with a combining function. + -- + -- @insertWith f key value m@ + -- will insert the pair @(key, value)@ into @m@ if @key@ does + -- not exist in the map. If the key does exist, the function will + -- insert the pair @(key, f new_value old_value)@. + insertWith :: (a -> a -> a) -> k -> a -> c -> c + insertWith f k a c = alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k c + + -- | Convert a 'Foldable' to a 'Map', with a combining function. + -- Note the applications of the combining function: + -- @fromFoldableWith (+) [(k,x1), (k,x2), ..., (k,xn)] = fromFoldable [(k, xn + (... + (x2 + x1)))]@ + -- or more generally @fromFoldableWith f [(k,x) | x <- l] = fromFoldable [(k,foldl1 (flip f) l)]@ + -- 'foldGroups' is probably less surprising, so use it. + fromFoldableWith :: Foldable l (k,a) => (a -> a -> a) -> l -> c + fromFoldableWith f = foldr (uncurry (insertWith f)) mempty + + -- | Convert a 'Foldable' to a 'Map', with a combining function. + -- @foldGroups f a l = let mkGroup g = (fst $ head g, foldr f a (map snd g)) in fromList . map mkGroup . groupBy ((==) `on` fst)) . toList@ + foldGroups :: Foldable l (k,b) => (b -> a -> a) -> a -> l -> c + foldGroups f a = foldr' (\(k,b) c -> (alter (\x -> Just $ case x of {Nothing->f b a;Just a' -> f b a'}) k c)) mempty + + -- | Apply a function over all values in the map. + mapWithKey :: (k -> a -> a) -> c -> c + + -- | Union with a combining function. + unionWith :: (a -> a -> a) -> c -> c -> c + + -- | Intersection with a combining function. + intersectionWith :: (a -> a -> a) -> c -> c -> c + + -- | Difference with a combining function. + differenceWith :: (a -> a -> Maybe a) -> c -> c -> c + + -- | isSubmapBy + isSubmapBy :: (a -> a -> Bool) -> c -> c -> Bool + + +-- | Tells whether a key is not a member of the keySet. +notMember :: (Map c k a) => k -> c -> Bool +notMember k s = not $ member k s + +-- | The expression @('lookupWithDefault' def k map)@ returns +-- the value at key @k@ or returns @def@ when the key is not in the map. +lookupWithDefault :: (Map c k a) => a -> k -> c -> a +lookupWithDefault a k c = Maybe.fromMaybe a (lookup k c) + +-- | Specialized version of fromFoldableWith for lists. +fromListWith :: (Map c k a) => (a -> a -> a) -> [(k,a)] -> c +fromListWith = fromFoldableWith + +data O a b c = L !a | R !b | O !c + +-- | Same as 'intersectionWith', but with a more general type. +intersectionWith' :: (Functor m, Map (m (O a b c)) k (O a b c)) => + (a->b->c) -> m a -> m b -> m c +intersectionWith' f m1 m2 = fmap extract (intersectionWith combine (fmap L m1) (fmap R m2)) + where combine (L l) (R r) = O (f l r) + extract (O a) = a + +-- | Same as 'differenceWith', but with a more general type. +differenceWith' :: (Functor m, Map (m (O a b c)) k (O a b c)) => + (a->b->Maybe c) -> m a -> m b -> m c +differenceWith' f m1 m2 = fmap extract (differenceWith combine (fmap L m1) (fmap R m2)) + where combine (L l) (R r) = fmap O (f l r) + extract (O a) = a + +mapWithKey' :: (Functor m, Map (m (Either a b)) k (Either a b)) => + (k -> a -> b) -> m a -> m b +mapWithKey' f = fmap (either (error "mapWithKey': bug.") id) . mapWithKey f' . fmap Left + where f' k (Left x) = Right (f k x) + +-- | Class for set-like collection types. A set is really a map +-- with no value associated to the keys, +-- so Set just states so. + +-- Note that this should be a class alias, if it existed. +-- See: http://repetae.net/john/recent/out/classalias.html +class Map c k () => Set c k | c -> k where + -- | Dummy method for haddock to accept the class. + haddock_candy :: c -> k + +-- | Infix version of 'difference'. Difference of two (key) sets. +(\\) :: Map c k a => c -> c -> c +(\\) = difference + +-- NOTE: the following two are only tentative, and thus not exported. + +-- | Infix version of 'union'. Union of two (key) sets. +(\/) :: Map c k a => c -> c -> c +(\/) = union + +-- | Infix version of 'intersection'. Intersection of two (key) sets. +(/\) :: Map c k a => c -> c -> c +(/\) = intersection + + +{- + +Maybe it would be a good idea to bite the bullet and use a Lattice class for intersection and union. +Maybe leave it unrelated to the Map class. In a separate module/package? Something like: + + +class Lattice a where + (/\) :: a -> a -> a + (\/) :: a -> a -> a + +instance Lattice () where + _ /\ _ = () + _ \/ _ = () + +instance Lattice Bool where + (/\) = (&&) + (\/) = (||) + +instance (Lattice a, Map c k a) => Lattice c where + (/\) = intersectionWith (/\) + (\/) = unionWith (\/) + +-} + + + +-- | Union of many (key) sets. +unions :: (Unfoldable s i, Map s k a, Foldable cs s) => cs -> s +unions sets = foldl' union empty sets + +-- | Union of many (key) sets, with combining function +unionsWith :: (Unfoldable s i, Map s k a, Foldable cs s) => (a->a->a) -> cs -> s +unionsWith f sets = foldl' (unionWith f) empty sets + +----------------------------------------------------------------------------- +-- Instances +----------------------------------------------------------------------------- + + +-- We follow with (sample) instances of the classes. + +----------------------------------------------------------------------------- +-- Data.List + +instance Unfoldable [a] a where + empty = [] + singleton = return + insert = (:) + +instance Collection [a] a where + filter = List.filter + +instance Sequence [a] a where + take = List.take + drop = List.drop + splitAt = List.splitAt + reverse = List.reverse + front (x:xs) = return (x,xs) + front [] = fail "front: empty sequence" + back s = return swap `ap` front (reverse s) + where swap (x,s) = (reverse s,x) + cons = (:) + snoc xs x = xs List.++ [x] + isPrefix = List.isPrefixOf + +instance Indexed [a] Int a where + index = flip (List.!!) + adjust f k l = left >< (f x:right) + where (left,x:right) = List.splitAt k l + inDomain k l = k >= 0 && k < List.length l + +-------------------------------------- +-- Data.Sequence + +instance Unfoldable (Seq.Seq a) a where + empty = Seq.empty + singleton = return + insert = (<|) + +instance Foldable (Seq.Seq a) a where + foldr = AltFoldable.foldr + foldl = AltFoldable.foldl + foldr1 = AltFoldable.foldr1 + foldl1 = AltFoldable.foldl1 + foldMap = AltFoldable.foldMap + null = Seq.null + +instance Collection (Seq.Seq a) a where + filter f = fromList . filter f . fromFoldable + +instance Sequence (Seq.Seq a) a where + take = Seq.take + drop = Seq.drop + splitAt = Seq.splitAt + reverse = Seq.reverse + front s = case Seq.viewl s of + EmptyL -> fail "front: empty sequence" + a :< s -> return (a,s) + back s = case Seq.viewr s of + EmptyR -> fail "back: empty sequence" + s :> a -> return (s,a) + cons = (Seq.<|) + snoc = (Seq.|>) + +instance Indexed (Seq.Seq a) Int a where + index = flip Seq.index + adjust = Seq.adjust + inDomain k l = k >= 0 && k < Seq.length l + +------------------------ +-- Data.ByteString + +instance Foldable BS.ByteString Word8 where + fold = foldr (+) 0 + foldr = BS.foldr + foldl = BS.foldl + foldr1 = BS.foldr1 + foldl1 = BS.foldl1 + null = BS.null + size = BS.length + +instance Unfoldable BS.ByteString Word8 where + empty = BS.empty + singleton = BS.singleton + insert = BS.cons + +instance Collection BS.ByteString Word8 where + filter = BS.filter + +instance Sequence BS.ByteString Word8 where + take = BS.take + drop = BS.drop + splitAt = BS.splitAt + reverse = BS.reverse + front s = if BS.null s then fail "front: empty ByteString" else return (BS.head s,BS.tail s) + back s = if BS.null s + then fail "back: empty sequence" + else let (s',x) = BS.splitAt (BS.length s - 1) s in return (s', BS.head x) + cons = BS.cons + snoc = BS.snoc + +instance Indexed BS.ByteString Int Word8 where + index = flip BS.index + adjust = error "Indexed.ajust: not supported by ByteString" + inDomain k l = k >= 0 && k < BS.length l + +------------------------ +-- Data.ByteString.Lazy + +instance Foldable BSL.ByteString Word8 where + fold = foldr (+) 0 + foldr = BSL.foldr + foldl = BSL.foldl + foldr1 = BSL.foldr1 + foldl1 = BSL.foldl1 + null = BSL.null + size = fromIntegral . BSL.length + +instance Unfoldable BSL.ByteString Word8 where + empty = BSL.empty + singleton = BSL.singleton + insert = BSL.cons + +instance Collection BSL.ByteString Word8 where + filter = BSL.filter + +instance Sequence BSL.ByteString Word8 where + take = BSL.take . fromIntegral + drop = BSL.drop . fromIntegral + splitAt = BSL.splitAt . fromIntegral + reverse = BSL.reverse + front s = if BSL.null s then fail "front: empty ByteString" else return (BSL.head s,BSL.tail s) + back s = if BSL.null s + then fail "back: empty sequence" + else let (s',x) = BSL.splitAt (BSL.length s - 1) s in return (s', BSL.head x) + cons = BSL.cons + snoc = BSL.snoc + +instance Indexed BSL.ByteString Int Word8 where + index = flip BSL.index . fromIntegral + adjust = error "Indexed.ajust: not supported by ByteString.Lazy yet" + inDomain k l = k >= 0 && k < size l + +-------------------------------------- +-- Data.Array + +instance Array.Ix i => Indexed (Array.Array i e) i e where + index = flip (Array.!) + adjust f k a = a Array.// [(k,f (a ! k))] + inDomain k a = Array.inRange (Array.bounds a) k + (//) a l = (Array.//) a (toList l) + +instance Array.Ix i => Array (Array.Array i e) i e where + array b l = Array.array b (toList l) + bounds = Array.bounds + +----------------------------------------------------------------------------- +-- Data.Map + +-- TODO: write the instance based on foldMap +instance Foldable (Map.Map k a) (k,a) where + foldr f i m = Map.foldWithKey (curry f) i m + null = Map.null + +instance Ord k => Unfoldable (Map.Map k a) (k,a) where + insert = uncurry Map.insert + singleton (k,a) = Map.singleton k a + empty = Map.empty + +instance Ord k => Collection (Map.Map k a) (k,a) where + filter f = Map.filterWithKey (curry f) + +instance Ord k => Indexed (Map.Map k a) k a where + index = flip (Map.!) + adjust = Map.adjust + inDomain = member + +instance Ord k => Map (Map.Map k a) k a where + isSubmapBy = Map.isSubmapOfBy + isSubset = Map.isSubmapOfBy (\_ _->True) + member = Map.member + union = Map.union + difference = Map.difference + delete = Map.delete + intersection = Map.intersection + lookup = Map.lookup + alter = Map.alter + insertWith = Map.insertWith + unionWith = Map.unionWith + intersectionWith = Map.intersectionWith + differenceWith = Map.differenceWith + mapWithKey = Map.mapWithKey + +instance Ord k => SortingCollection (Map.Map k a) (k,a) where + minView x = return swap `ap` Map.minView x + where swap (x,y) = (y,x) + +----------------------------------------------------------------------------- +-- Data.AvlMap +instance Foldable (AvlMap.Map k a) (k,a) where + foldr f i m = AvlMap.foldWithKey (curry f) i m + null = AvlMap.null + +instance Ord k => Unfoldable (AvlMap.Map k a) (k,a) where + insert = uncurry AvlMap.insert + singleton (k,a) = AvlMap.singleton k a + empty = AvlMap.empty + +instance Ord k => Collection (AvlMap.Map k a) (k,a) where + filter f = AvlMap.filterWithKey (curry f) + +instance Ord k => Indexed (AvlMap.Map k a) k a where + index = flip (AvlMap.!) + adjust = AvlMap.adjust + inDomain = member + +instance Ord k => Map (AvlMap.Map k a) k a where + isSubmapBy = AvlMap.isSubmapOfBy + isSubset = AvlMap.isSubmapOfBy (\_ _->True) + member = AvlMap.member + union = AvlMap.union + difference = AvlMap.difference + delete = AvlMap.delete + intersection = AvlMap.intersection + lookup = AvlMap.lookup + alter = AvlMap.alter + insertWith = AvlMap.insertWith + unionWith = AvlMap.unionWith + intersectionWith = AvlMap.intersectionWith + differenceWith = AvlMap.differenceWith + mapWithKey = AvlMap.mapWithKey + +instance Ord k => SortingCollection (AvlMap.Map k a) (k,a) where + minView c = if null c then fail "Data.AVL.Map.minView: empty map" else return (AvlMap.findMin c, AvlMap.deleteMin c) + -- FIXME: add support for this in AvlMap.Map + + +----------------------------------------------------------------------------- +-- Data.IntMap +instance Foldable (IntMap.IntMap a) (Int,a) where + null = IntMap.null + size = IntMap.size + foldr f i m = IntMap.foldWithKey (curry f) i m + +instance Unfoldable (IntMap.IntMap a) (Int,a) where + insert = uncurry IntMap.insert + singleton (k,a) = IntMap.singleton k a + empty = IntMap.empty + +instance Collection (IntMap.IntMap a) (Int,a) where + filter f = IntMap.filterWithKey (curry f) + +instance Indexed (IntMap.IntMap a) Int a where + index = flip (IntMap.!) + adjust = IntMap.adjust + inDomain = member + +instance Map (IntMap.IntMap a) Int a where + isSubmapBy = IntMap.isSubmapOfBy + isSubset = IntMap.isSubmapOfBy (\_ _->True) + member = IntMap.member + union = IntMap.union + difference = IntMap.difference + delete = IntMap.delete + intersection = IntMap.intersection + lookup = IntMap.lookup + alter = IntMap.alter + insertWith = IntMap.insertWith + unionWith = IntMap.unionWith + intersectionWith = IntMap.intersectionWith + differenceWith = IntMap.differenceWith + mapWithKey = IntMap.mapWithKey + +----------------------------------------------------------------------------- +-- Data.Set + +instance Foldable (Set.Set a) a where + foldr f i s = Set.fold f i s + null = Set.null + size = Set.size + +instance Ord a => Unfoldable (Set.Set a) a where + insert = Set.insert + singleton = Set.singleton + empty = Set.empty + +instance Ord a => Collection (Set.Set a) a where + filter = Set.filter + +instance Ord a => Set (Set.Set a) a where + haddock_candy = haddock_candy + +instance Ord a => Map (Set.Set a) a () where + isSubset = Set.isSubsetOf + isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y)) + member = Set.member + union = Set.union + difference = Set.difference + intersection = Set.intersection + delete = Set.delete + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + alter f k m = case f (lookup k m) of + Just _ -> insert k m + Nothing -> delete k m + mapWithKey _f = id + + +instance Ord a => SortingCollection (Set.Set a) a where + minView c = if null c then fail "Data.Set.minView: empty set" else return (Set.findMin c, Set.deleteMin c) + -- FIXME: add support for this in Data.Set + +-------------------------------------- +--------------------------------------- +-- AvlSet + +instance Foldable (AvlSet.Set a) a where + foldr f i s = AvlSet.fold f i s + null = AvlSet.null + +instance Ord a => Unfoldable (AvlSet.Set a) a where + insert = AvlSet.insert + singleton = AvlSet.singleton + empty = AvlSet.empty + +instance Ord a => Collection (AvlSet.Set a) a where + filter = AvlSet.filter + +instance Ord a => Set (AvlSet.Set a) a where + haddock_candy = haddock_candy + +instance Ord a => Map (AvlSet.Set a) a () where + isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y)) + isSubset = AvlSet.isSubsetOf + member = AvlSet.member + union = AvlSet.union + difference = AvlSet.difference + intersection = AvlSet.intersection + delete = AvlSet.delete + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + alter f k m = case f (lookup k m) of + Just _ -> insert k m + Nothing -> delete k m + mapWithKey _f = id + +instance Ord a => SortingCollection (AvlSet.Set a) a where + minView c = if null c then fail "Data.AVL.Set.minView: empty map" else return (AvlSet.findMin c, AvlSet.deleteMin c) + -- FIXME: add support for this in Data.Map + + +----------------------------------------------------------------------------- +-- Data.IntSet + +instance Foldable IntSet.IntSet Int where + foldr f i s = IntSet.fold f i s + fold = foldl (+) 0 + null = IntSet.null + size = IntSet.size + +instance Unfoldable IntSet.IntSet Int where + insert = IntSet.insert + singleton = IntSet.singleton + empty = IntSet.empty + +instance Collection IntSet.IntSet Int where + filter = IntSet.filter + +instance Set IntSet.IntSet Int where + haddock_candy = haddock_candy + +instance Map IntSet.IntSet Int () where + isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y)) + isSubset = IntSet.isSubsetOf + member = IntSet.member + union = IntSet.union + difference = IntSet.difference + intersection = IntSet.intersection + delete = IntSet.delete + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + alter f k m = case f (lookup k m) of + Just _ -> insert k m + Nothing -> delete k m + mapWithKey _f = id + +----------------------------------------------------------------------------- +-- Data.EnumSet + +instance Enum a => Foldable (EnumSet.Set a) a where + foldr f i s = EnumSet.foldr f i s + null = EnumSet.null + size = EnumSet.size + +instance Enum a => Unfoldable (EnumSet.Set a) a where + insert = EnumSet.insert + singleton = EnumSet.singleton + empty = EnumSet.empty + +instance Enum a => Collection (EnumSet.Set a) a where + filter = EnumSet.filter + +instance Enum a => Set (EnumSet.Set a) a where + haddock_candy = haddock_candy + +instance Enum a => Map (EnumSet.Set a) a () where + isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y)) + isSubset = EnumSet.isSubsetOf + member = EnumSet.member + union = EnumSet.union + difference = EnumSet.difference + intersection = EnumSet.intersection + delete = EnumSet.delete + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + alter f k m = case f (lookup k m) of + Just _ -> insert k m + Nothing -> delete k m + mapWithKey _f = id + +------------------- +-- Data.Ranged + +instance DiscreteOrdered a => Unfoldable (RangedSet a) a where + insert x = Ranged.rSetUnion (Ranged.rSingleton x) + singleton = Ranged.rSingleton + empty = Ranged.rSetEmpty + +instance DiscreteOrdered a => Map (RangedSet a) a () where + isSubset = Ranged.rSetIsSubset + isSubmapBy f x y = isSubset x y && (f () () || Ranged.rSetIsEmpty (intersection x y)) + member = flip Ranged.rSetHas + union = Ranged.rSetUnion + difference = Ranged.rSetDifference + intersection = Ranged.rSetIntersection + delete = flip Ranged.rSetDifference . Ranged.rSingleton + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + alter f k m = case f (lookup k m) of + Just _ -> insert k m + Nothing -> delete k m + mapWithKey _f = id + +instance DiscreteOrdered a => Set (RangedSet a) a where + haddock_candy = haddock_candy + +------------------------------------------------------------------------ +-- Trickier stuff for alternate dictionnary usages + +-- | "View" to the keys of a dictionnary +newtype KeysView m k v = KeysView {fromKeysView :: m} + +-- | "View" to the elements of a dictionnary +newtype ElemsView m k v = ElemsView {fromElemsView :: m} + +-- The following requires undecidable instances. An alternative +-- implementation is to define these instances directly on the +-- concrete map types and drop the requirement for the aforementioned +-- extension. + +type T a = a->a + +withKeys :: Collection m (k,v) => T (KeysView m k v) -> T m +withKeys f c = fromKeysView $ f (KeysView c) + +withElems :: Collection m (k,v) => T (ElemsView m k v) -> T m +withElems f c = fromElemsView $ f (ElemsView c) + +instance Foldable m (k,v) => Foldable (KeysView m k v) k where + foldr f i (KeysView c) = foldr (f . fst) i c + null (KeysView c) = null c + +instance Unfoldable m (k,v) => Unfoldable (KeysView m k v) (k,v) where + empty = KeysView empty + insert x (KeysView m) = KeysView $ insert x m + singleton x = KeysView (singleton x) + +instance Foldable m (k,v) => Foldable (ElemsView m k v) v where + foldr f i (ElemsView c) = foldr (f . snd) i c + null (ElemsView c) = null c + +instance Unfoldable m (k,v) => Unfoldable (ElemsView m k v) (k,v) where + empty = ElemsView empty + insert x (ElemsView m) = ElemsView $ insert x m + singleton x = ElemsView (singleton x) + +instance (Monoid m, Map m k v) => Monoid (KeysView m k v) where + mempty = KeysView mempty + mappend = union + +instance Map m k v => Map (KeysView m k v) k v where + isSubmapBy f (KeysView m) (KeysView m') = isSubmapBy f m m' + member k (KeysView m) = Maybe.isJust $ lookup k m + union (KeysView m) (KeysView m') = KeysView $ union m m' + difference (KeysView m) (KeysView m') = KeysView $ difference m m' + intersection (KeysView m) (KeysView m') = KeysView $ intersection m m' + delete k (KeysView m) = KeysView $ delete k m + insertWith f k a (KeysView m) = KeysView $ insertWith f k a m + lookup k (KeysView m) = lookup k m + alter f k (KeysView m) = KeysView $ alter f k m + unionWith f (KeysView m) (KeysView m') = KeysView $ unionWith f m m' + differenceWith f (KeysView m) (KeysView m') = KeysView $ differenceWith f m m' + intersectionWith f (KeysView m) (KeysView m') = KeysView $ intersectionWith f m m' + mapWithKey f (KeysView m) = KeysView $ mapWithKey f m + + + diff --git a/Data/Collections/Foldable.hs b/Data/Collections/Foldable.hs new file mode 100644 --- /dev/null +++ b/Data/Collections/Foldable.hs @@ -0,0 +1,311 @@ +{-# OPTIONS -fglasgow-exts -cpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections.Foldable +-- Copyright : Ross Paterson 2005, adaptation to MPTC+FD by Jean-Philippe Bernardy +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : jeanphilippe.bernardy (google mail address) +-- Stability : experimental +-- Portability : MPTC+FD +-- +-- Class of data structures that can be folded to a summary value. + +module Data.Collections.Foldable ( + -- * Folds + Foldable(..), + -- ** Special biased folds + foldr', + foldl', + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + --More general versions exist in Data.Collections + --concat, + --concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where + +import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, + elem, notElem, concat, concatMap, and, or, any, all, + sum, product, maximum, minimum) +import qualified Prelude (foldl, foldr, foldl1, foldr1) +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid +import Data.Array + +#ifdef __NHC__ +import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +#endif + +-- | Data structures that can be folded. +-- +-- Minimal complete definition: 'foldMap' or 'foldr'. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. +-- +class Foldable t a | t -> a where + -- | Combine the elements of a structure using a monoid. + fold :: Monoid a => t -> a + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (b -> a -> b) -> b -> t -> b + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where mf Nothing y = Just y + mf (Just x) y = Just (f x y) + + -- | Tells whether the structure is empty. + null :: t -> Bool + null = all (const False) + + -- | Returns the size of the structure. + size :: t -> Int + size = foldr (const (+1)) 0 + + -- | Tells whether the structure contains a single element. + isSingleton :: t -> Bool + isSingleton = (1 ==) . size -- FIXME: more efficient default. + +-- instances for Prelude types + +instance Foldable (Maybe a) a where + foldr f z Nothing = z + foldr f z (Just x) = f x z + + foldl f z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [a] a where + null = Prelude.null + size = Prelude.length + foldr = Prelude.foldr + foldl = Prelude.foldl + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 + +instance Ix i => Foldable (Array i a) (i,a) where + foldr f z = Prelude.foldr f z . assocs + +-- | Fold over the elements of a structure, +-- associating to the right, but strictly. +foldr' :: Foldable t a => (a -> b -> b) -> b -> t -> b +foldr' f z xs = foldl f' id xs z + where f' k x z = k $! f x z + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t a, Monad m) => (a -> b -> m b) -> b -> t -> m b +foldrM f z xs = foldl f' return xs z + where f' k x z = f x z >>= k + +-- | Fold over the elements of a structure, +-- associating to the left, but strictly. +foldl' :: Foldable t b => (a -> b -> a) -> a -> t -> a +foldl' f z xs = foldr f' id xs z + where f' x k z = k $! f z x + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t b, Monad m) => (a -> b -> m a) -> a -> t -> m a +foldlM f z xs = foldr f' return xs z + where f' x k z = f z x >>= k + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverse_ :: (Foldable t a, Applicative f) => (a -> f b) -> t -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. +for_ :: (Foldable t a, Applicative f) => t -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. +mapM_ :: (Foldable t a, Monad m) => (a -> m b) -> t -> m () +mapM_ f = foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. +forM_ :: (Foldable t a, Monad m) => t -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | Evaluate each action in the structure from left to right, +-- and ignore the results. +sequenceA_ :: forall f a t. (Foldable t (f a), Applicative f) => t -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. +sequence_ :: forall m a t. (Foldable t (m a), Monad m) => t -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t (f a), Alternative f) => t -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +msum :: (Foldable t (m a), MonadPlus m) => t -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | List of elements of a structure. +toList :: Foldable t a => t -> [a] +#ifdef __GLASGOW_HASKELL__ +toList t = build (\ c n -> foldr c n t) +#else +toList = foldr (:) [] +#endif + +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t [a] => t -> [a] +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t a => (a -> [b]) -> t -> [b] +concatMap = foldMap + +-- | 'and' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +and :: Foldable t Bool => t -> Bool +and = getAll . foldMap All + +-- | 'or' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +or :: Foldable t Bool => t -> Bool +or = getAny . foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t a => (a -> Bool) -> t -> Bool +any p = getAny . foldMap (Any . p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t a => (a -> Bool) -> t -> Bool +all p = getAll . foldMap (All . p) + +-- | The 'sum' function computes the sum of the numbers of a structure. +sum :: (Foldable t a, Num a) => t -> a +sum = getSum . foldMap Sum + +-- | The 'product' function computes the product of the numbers of a structure. +product :: (Foldable t a, Num a) => t -> a +product = getProduct . foldMap Product + +-- | The largest element of the structure. +maximum :: (Foldable t a, Ord a) => t -> a +maximum = foldr1 max + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t a => (a -> a -> Ordering) -> t -> a +maximumBy cmp = foldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-null structure. +minimum :: (Foldable t a, Ord a) => t -> a +minimum = foldr1 min + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +minimumBy :: Foldable t a => (a -> a -> Ordering) -> t -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | Does the element occur in the structure? +elem :: (Foldable t a, Eq a) => a -> t -> Bool +elem = any . (==) + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t a, Eq a) => a -> t -> Bool +notElem x = not . elem x + +-- | The 'find' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +find :: Foldable t a => (a -> Bool) -> t -> Maybe a +find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) diff --git a/Data/Collections/Properties.hs b/Data/Collections/Properties.hs new file mode 100644 --- /dev/null +++ b/Data/Collections/Properties.hs @@ -0,0 +1,679 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Collections +-- Copyright : (c) Jean-Philippe Bernardy, 2006 +-- License : BSD3 +-- Maintainer : jeanphilippe.bernardy; google mail. +-- Stability : experimental +-- Portability : MPTC, FD, undecidable instances +-- +-- The purpose of this module is twofold: +-- +-- (1) Check instances of the classes in the collection framework. +-- +-- (2) Give those classes more formal semantics. +-- +-- Therefore, this acts as a contract between the collections users and implementers. +-- +-- Each function in this module returns a list of @(property_name, propterty)@ +-- for a given class (or set of classes). Each function is parameterized on the +-- type of +-- the collection to check, so a value witnessing the type must be passed. This +-- value is guaranteed not to be evaluated, so it can always be 'undefined'. +-- +-- These properties allow to verify, with a high degree of confidence, that +-- instances of the classes defined in 'Data.Collections' satisfy +-- the prescribed properties. +-- +-- You will note that properties depend on the 'Eq' class. This means that +-- +-- * properties are verified up-to 'Eq' equivalence. +-- +-- * Infinite structures and other @bottom@s are not testable with this module. +-- +-- For convenience, this module provides an instance of @'Arbitrary' ('Maybe' a)@. + + +module Data.Collections.Properties + ( + unfoldable_properties, + foldable_properties, + collection_properties, + map_properties, + map_unfold_properties, + set_unfold_properties, + map_fold_properties, + set_fold_properties, + indexed_map_properties, + sequence_properties, + indexed_properties, + indexed_sequence_properties + ) where + +-- +-- The documentation in this module is mostly generated from the function definitions, +-- see tools/AnnotateProps.hs. +-- TODO: +-- +-- + interactions with other classes (mainly Functor) +-- + see if prop_foldable could be defined better. +-- + array + + +import Prelude hiding (null, foldr, lookup, concatMap, concat, and, drop, take, reverse, elem, notElem, all, any, filter) + +import Control.Monad + +import Data.Collections + +import Data.Collections.Foldable as Foldable + +import Data.Maybe + +import Data.Monoid + +import qualified Data.List as List + +import Test.QuickCheck + +import qualified Data.Collections as C + +infix 1 <==> + +infix 1 <== + +instance Arbitrary a => Arbitrary (Maybe a) + where arbitrary = do test <- arbitrary + if test + then return Nothing + else return Just `ap` arbitrary + coarbitrary Nothing = variant 0 + coarbitrary (Just x) = variant 1 . coarbitrary x + +instance Show (a->b) where + show _ = "" + +-- | Logic equivalence + +(<==>) :: Bool -> Bool -> Bool +(<==>) x y = x == y + +(<==) = flip (==>) + +-- | foldable_properties returns the following properties: +-- +-- [/size/] +-- +-- > size c == foldr (const (+1)) 0 c +-- +-- [/null/] +-- +-- > null c <==> all (const False) c +-- +-- [/isSingleton/] +-- +-- > isSingleton c <==> size c == 1 +-- +-- [/eq_elem/] +-- +-- > c1 == c2 ==> elem x c1 == elem x c2 -- note that the order of folding is not enforced, and that the converse is not true + +foldable_properties :: forall c a. (Arbitrary c, Arbitrary a, + Show a, Show c, + Eq c, Eq a, + Foldable c a) => c -> [(Property,String)] +foldable_properties _ = [(property prop_size,"size"), (property prop_null,"null"), (property prop_isSingleton,"isSingleton"), (property prop_eq_elem,"eq_elem")] + where size = C.size :: c -> Int + null = C.null :: c -> Bool + foldr = C.foldr :: (a -> b -> b) -> b -> c -> b + toList = C.toList :: c -> [a] + elem = C.elem :: a -> c -> Bool + prop_size c = size c == foldr (const (+1)) 0 c + prop_null c = null c <==> all (const False) c + prop_isSingleton c = isSingleton c <==> size c == 1 + prop_eq_elem c1 c2 x = c1 == c2 ==> elem x c1 == elem x c2 -- note that the order of folding is not enforced, and that the converse is not true + +-- | unfoldable_properties returns the following properties: +-- +-- [/singleton/] +-- +-- > singleton a == insert a empty +-- +-- [/insertMany/] +-- +-- > insertMany l c == Foldable.foldr insert c l +-- +-- [/insertManySorted/] +-- +-- > insertManySorted l c == Foldable.foldr insert c l +-- > where l = List.sort l0 + +unfoldable_properties :: forall c a. (Arbitrary c, Arbitrary a, + Ord a, Show a, Show c, + Eq c, Eq a, + Unfoldable c a) => c -> [(Property,String)] +unfoldable_properties _ = [(property prop_singleton,"singleton"), (property prop_insertMany,"insertMany"), (property prop_insertManySorted,"insertManySorted")] + where empty = C.empty :: c + insert = C.insert :: a -> c -> c + singleton = C.singleton :: a -> c + prop_singleton a = singleton a == insert a empty + prop_insertMany c (l::[a]) = insertMany l c == Foldable.foldr insert c l + prop_insertManySorted c (l0::[a]) = insertManySorted l c == Foldable.foldr insert c l + where l = List.sort l0 + +-- | collection_properties returns the following properties: +-- +-- [/collection/] +-- +-- > foldr insert empty c == c +-- +-- [/empty/] +-- +-- > null empty +-- +-- [/insert1/] +-- +-- > a `elem` (insert a c) -- insert puts the element in the collection +-- +-- [/insert2/] +-- +-- > a /= a' ==> (a' `elem` c <== a' `elem` (insert a c)) -- insert does not insert other elements +-- +-- [/insert3/] +-- +-- > let c' = insert a c in x `elem` c && y `elem` c ==> x `elem` c' || y `elem` c' -- insert alters at most one element +-- +-- [/filter/] +-- +-- > (a `elem` filter f c) <==> ((a `elem` c) && f a) + +collection_properties :: forall c i. (Arbitrary c, Arbitrary i, + Show i, Show c, + Eq c, Eq i, + Collection c i) => c -> [(Property,String)] +collection_properties _ = [(property prop_collection,"collection"), (property prop_empty,"empty"), (property prop_insert1,"insert1"), (property prop_insert2,"insert2"), (property prop_insert3,"insert3"), (property prop_filter,"filter")] + where empty = C.empty :: c + foldr = C.foldr :: (i -> b -> b) -> b -> c -> b + filter = C.filter :: (i -> Bool) -> c -> c + insert = C.insert :: i -> c -> c + + prop_collection c = foldr insert empty c == c + prop_empty = null empty + + prop_insert1 a c = a `elem` (insert a c) -- insert puts the element in the collection + prop_insert2 a a' c = a /= a' ==> (a' `elem` c <== a' `elem` (insert a c)) -- insert does not insert other elements + prop_insert3 a x y c = let c' = insert a c in x `elem` c && y `elem` c ==> x `elem` c' || y `elem` c' -- insert alters at most one element + --NOTE: This leaves the door open to insert actually 'removing' an element. + + prop_filter f c a = (a `elem` filter f c) <==> ((a `elem` c) && f a) + +-- | map_properties returns the following properties: +-- +-- [/alter/] +-- +-- > lookup k (alter f k m) == f (lookup k m) +-- +-- [/mapWithKey/] +-- +-- > lookup k (mapWithKey f m) == fmap (f k) (lookup k m) +-- +-- [/unionWith/] +-- +-- > lookup k (unionWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Nothing,Nothing) -> Nothing +-- > (Just x, Nothing) -> Just x +-- > (Nothing,Just x) -> Just x +-- > (Just x, Just y) -> Just (f x y) +-- +-- [/intersectionWith/] +-- +-- > lookup k (intersectionWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Just x, Just y) -> Just (f x y) +-- > _ -> Nothing +-- +-- [/differenceWith/] +-- +-- > lookup k (differenceWith f m1 m2) == case (lookup k m1, lookup k m2) of +-- > (Just x, Nothing) -> Just x +-- > (Just x, Just y) -> f x y +-- > (Nothing, _) -> Nothing +-- +-- [/isSubmapBy/] +-- +-- > isSubmapBy f m1 m2 <==> differenceWith (\x y->if f x y then Nothing else Just v) m1 m2 == mempty +-- +-- [/insertWith/] +-- +-- > insertWith f k a m == alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k m +-- +-- [/fromFoldableWith/] +-- +-- > fromFoldableWith f l == foldr (uncurry (insertWith f)) mempty l +-- +-- [/delete/] +-- +-- > delete k m == alter (const Nothing) k m +-- +-- [/member/] +-- +-- > member k m <==> isJust (lookup k m) +-- +-- [/union/] +-- +-- > union m1 m2 == unionWith const m1 m2 +-- +-- [/intersection/] +-- +-- > intersection m1 m2 == intersectionWith const m1 m2 +-- +-- [/difference/] +-- +-- > difference m1 m2 == differenceWith (\_ _ -> Nothing) m1 m2 +-- +-- [/subset/] +-- +-- > isSubset m1 m2 <==> isSubmapBy (\_ _ -> True) m1 m2 +-- +-- [/mempty/] +-- +-- > lookup k mempty == Nothing +-- +-- [/mappend/] +-- +-- > mappend m1 m2 == union m1 m2 +-- +-- [/eq_lookup/] +-- +-- > c1 == c2 ==> lookup x c1 == lookup x c2 -- should really be: c1 == c2 <==> forall x. lookup x c1 == lookup x c2 + +map_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Map m k v + ) => m -> [(Property,String)] +map_properties _ = [(property prop_alter,"alter"), (property prop_mapWithKey,"mapWithKey"), (property prop_unionWith,"unionWith"), (property prop_intersectionWith,"intersectionWith"), (property prop_differenceWith,"differenceWith"), (property prop_isSubmapBy,"isSubmapBy"), (property prop_insertWith,"insertWith"), (property prop_fromFoldableWith,"fromFoldableWith"), (property prop_delete,"delete"), (property prop_member,"member"), (property prop_union,"union"), (property prop_intersection,"intersection"), (property prop_difference,"difference"), (property prop_subset,"subset"), (property prop_mempty,"mempty"), (property prop_mappend,"mappend"), (property prop_eq_lookup,"eq_lookup")] + where +-- empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + isSubset = C.isSubset :: m -> m -> Bool + unionWith = C.unionWith :: (v -> v -> v) -> m -> m -> m + union = C.union :: m -> m -> m + intersectionWith = C.intersectionWith :: (v -> v -> v) -> m -> m -> m + differenceWith = C.differenceWith :: (v -> v -> Maybe v) -> m -> m -> m + fromFoldableWith = C.fromFoldableWith :: (v -> v -> v) -> [(k,v)] -> m + + prop_alter f k m = lookup k (alter f k m) == f (lookup k m) + + prop_mapWithKey f k m = lookup k (mapWithKey f m) == fmap (f k) (lookup k m) + + prop_unionWith f k m1 m2 = lookup k (unionWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Nothing,Nothing) -> Nothing + (Just x, Nothing) -> Just x + (Nothing,Just x) -> Just x + (Just x, Just y) -> Just (f x y) + + prop_intersectionWith f k m1 m2 = lookup k (intersectionWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Just x, Just y) -> Just (f x y) + _ -> Nothing + + prop_differenceWith f k m1 m2 = lookup k (differenceWith f m1 m2) == case (lookup k m1, lookup k m2) of + (Just x, Nothing) -> Just x + (Just x, Just y) -> f x y + (Nothing, _) -> Nothing + + prop_isSubmapBy f m1 m2 v = isSubmapBy f m1 m2 <==> differenceWith (\x y->if f x y then Nothing else Just v) m1 m2 == mempty + + prop_insertWith f k a m = insertWith f k a m == alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k m + prop_fromFoldableWith f l = fromFoldableWith f l == foldr (uncurry (insertWith f)) mempty l + prop_delete k m = delete k m == alter (const Nothing) k m + prop_member k m = member k m <==> isJust (lookup k m) + prop_union m1 m2 = union m1 m2 == unionWith const m1 m2 + prop_intersection m1 m2 = intersection m1 m2 == intersectionWith const m1 m2 + prop_difference m1 m2 = difference m1 m2 == differenceWith (\_ _ -> Nothing) m1 m2 + prop_subset m1 m2 = isSubset m1 m2 <==> isSubmapBy (\_ _ -> True) m1 m2 + + prop_mempty k = lookup k mempty == Nothing + prop_mappend m1 m2 = mappend m1 m2 == union m1 m2 + prop_eq_lookup x c1 c2 = c1 == c2 ==> lookup x c1 == lookup x c2 -- should really be: c1 == c2 <==> forall x. lookup x c1 == lookup x c2 + + --prop_eq' c1 c2 = c1 == c2 <==> forAll (\x -> lookup x c1 == lookup x c2) + +count :: Foldable f a => (a -> Bool) -> f -> Int +count p = getSum . foldMap (\x->Sum $ if p x then 1 else 0) + +-- | map_unfold_properties returns the following properties: +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/insert/] +-- +-- > insert (k,v) m == insertWith (\x _ -> x) k v m + +map_unfold_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, Eq k, + Map m k v, + Collection m (k,v) + ) => m -> [(Property,String)] +map_unfold_properties _ = [(property prop_mempty,"mempty"), (property prop_insert,"insert")] + where + empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + insertWith = C.insertWith :: (v -> v -> v) -> k -> v -> m -> m + toList = C.toList :: m -> [(k,v)] + + prop_mempty = mempty == empty + prop_insert k v m = insert (k,v) m == insertWith (\x _ -> x) k v m + +-- | map_fold_properties returns the following properties: +-- +-- [/foldable/] +-- +-- > maybeToList (lookup k m) == map snd (filter ((== k) . fst) (toList m)) +-- +-- [/size/] +-- +-- > sizeExcept (alter f k m) == sizeExcept m +-- > where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +map_fold_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, Eq k, + Map m k v, + Collection m (k,v) + ) => m -> [(Property,String)] +map_fold_properties _ = [(property prop_foldable,"foldable"), (property prop_size,"size")] + where + empty = C.empty :: m +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe v -> Maybe v) -> k -> m -> m + lookup = C.lookup :: k -> m -> Maybe v + insertWith = C.insertWith :: (v -> v -> v) -> k -> v -> m -> m + toList = C.toList :: m -> [(k,v)] + + prop_foldable k m = maybeToList (lookup k m) == map snd (filter ((== k) . fst) (toList m)) + prop_size f k m = sizeExcept (alter f k m) == sizeExcept m + where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +-- | set_unfold_properties returns the following properties: +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/insert/] +-- +-- > insert k m == insertWith (\x _->x) k () m + +set_unfold_properties :: forall m k. (Arbitrary m, Arbitrary k, + Show k, Show m, + Eq m, Eq k, + Map m k (), + Unfoldable m k + ) => m -> [(Property,String)] +set_unfold_properties _ = [(property prop_mempty,"mempty"), (property prop_insert,"insert")] + where + empty = C.empty :: m + insertWith = C.insertWith :: (() -> () -> ()) -> k -> () -> m -> m + + prop_mempty = mempty == empty + prop_insert k m = insert k m == insertWith (\x _->x) k () m + +-- | set_fold_properties returns the following properties: +-- +-- [/foldable/] +-- +-- > maybeToList (lookup k m) == map (const ()) (filter (== k) (toList m)) +-- +-- [/size/] +-- +-- > sizeExcept (alter f k m) == sizeExcept m +-- > where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +set_fold_properties :: forall m k. (Arbitrary m, Arbitrary k, + Show k, Show m, + Eq m, Eq k, + Map m k (), + Foldable m k + ) => m -> [(Property,String)] +set_fold_properties _ = [(property prop_foldable,"foldable"), (property prop_size,"size")] + where +-- singleton = C.singleton :: i -> m +-- size = C.size :: m -> Int + alter = C.alter :: (Maybe () -> Maybe ()) -> k -> m -> m + member = C.member :: k -> m -> Bool + lookup = C.lookup :: k -> m -> Maybe () + + prop_foldable k m = maybeToList (lookup k m) == map (const ()) (filter (== k) (toList m)) + prop_size f k m = sizeExcept (alter f k m) == sizeExcept m + where sizeExcept m = size m - maybe 0 (const 1) (lookup k m) + +-- | indexed_properties returns the following properties: +-- +-- [/adjust/] +-- +-- > k `inDomain` m ==> index k (adjust f k m) == f (index k m) + +indexed_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Indexed m k v + ) => m -> [(Property,String)] +indexed_properties _ = [(property prop_adjust,"adjust")] + where adjust = C.adjust :: (v -> v) -> k -> m -> m + + prop_adjust f k m = k `inDomain` m ==> index k (adjust f k m) == f (index k m) + +-- | sequence_properties returns the following properties: +-- +-- [/fold0/] +-- +-- > foldMap f empty == mempty +-- +-- [/fold1/] +-- +-- > foldMap f (x <| s) == f x `mappend` foldMap f s +-- +-- [/fold2/] +-- +-- > foldMap f (s |> x) == foldMap f s `mappend` f x +-- +-- [/fold3/] +-- +-- > foldMap f (s >< t) == foldMap f s `mappend` foldMap f t +-- +-- [/front0/] +-- +-- > front empty == Nothing +-- +-- [/front1/] +-- +-- > front (x <| s) == Just (x,s) +-- +-- [/front2/] +-- +-- > front (s |> x) == case front s of {Nothing -> Just (x, empty); Just (x',s') -> Just (x', s' |> x)} +-- +-- [/front3/] +-- +-- > front (s >< t) == case front s of {Nothing -> front t; Just (x',s') -> Just (x', s' >< t)} +-- +-- [/back0/] +-- +-- > back empty == Nothing +-- +-- [/back1/] +-- +-- > back (s |> x) == Just (s,x) +-- +-- [/back2/] +-- +-- > back (x <| s) == case back s of {Nothing -> Just (empty, x); Just (s',x') -> Just (x <| s', x')} +-- +-- [/back3/] +-- +-- > back (t >< s) == case back s of {Nothing -> back t; Just (s',x') -> Just (t >< s', x')} +-- +-- [/drop1/] +-- +-- > drop 0 s == s +-- +-- [/drop2/] +-- +-- > n>0 ==> drop (n+1) s == case front (drop n s) of Nothing -> empty; Just (_,s') -> s' +-- +-- [/take1/] +-- +-- > take 0 s == empty +-- +-- [/take2/] +-- +-- > n>0 ==> take (n+1) s == case front s of Nothing -> empty; Just (x,s') -> x <| take n s' +-- +-- [/reverse/] +-- +-- > foldMap f (reverse s) == getDual (foldMap (Dual . f) s) +-- +-- [/mempty/] +-- +-- > mempty == empty +-- +-- [/eq_fold/] +-- +-- > s1 == s2 ==> foldMap f s1 == foldMap f s2 + +sequence_properties :: forall s a . (Arbitrary s, Arbitrary a, + Show s, Show a, + Eq s, Eq a, + Sequence s a + ) => s -> [(Property,String)] +sequence_properties _ = [(property prop_fold0,"fold0"), (property prop_fold1,"fold1"), (property prop_fold2,"fold2"), (property prop_fold3,"fold3"), (property prop_front0,"front0"), (property prop_front1,"front1"), (property prop_front2,"front2"), (property prop_front3,"front3"), (property prop_back0,"back0"), (property prop_back1,"back1"), (property prop_back2,"back2"), (property prop_back3,"back3"), (property prop_drop1,"drop1"), (property prop_drop2,"drop2"), (property prop_take1,"take1"), (property prop_take2,"take2"), (property prop_reverse,"reverse"), (property prop_mempty,"mempty"), (property prop_eq_fold,"eq_fold")] + where + empty = C.empty :: s + front = C.front :: s -> Maybe (a,s) + back = C.back :: s -> Maybe (s,a) +-- size = C.size :: s -> Int + drop = C.drop :: Int -> s -> s + take = C.take :: Int -> s -> s + reverse = C.reverse :: s -> s + foldMap :: forall m. Monoid m => (a -> m) -> s -> m + foldMap = C.foldMap + + f :: a -> [a] -- testing this single function ensure that fold properties are ok for all monoids and functions + -- (because mappend is associative) + f = singleton + + prop_fold0 = foldMap f empty == mempty + prop_fold1 s x = foldMap f (x <| s) == f x `mappend` foldMap f s + prop_fold2 s x = foldMap f (s |> x) == foldMap f s `mappend` f x + prop_fold3 s t = foldMap f (s >< t) == foldMap f s `mappend` foldMap f t + + prop_front0 = front empty == Nothing + prop_front1 s x = front (x <| s) == Just (x,s) + prop_front2 s x = front (s |> x) == case front s of {Nothing -> Just (x, empty); Just (x',s') -> Just (x', s' |> x)} + prop_front3 s t = front (s >< t) == case front s of {Nothing -> front t; Just (x',s') -> Just (x', s' >< t)} + + prop_back0 = back empty == Nothing + prop_back1 s x = back (s |> x) == Just (s,x) + prop_back2 s x = back (x <| s) == case back s of {Nothing -> Just (empty, x); Just (s',x') -> Just (x <| s', x')} + prop_back3 s t = back (t >< s) == case back s of {Nothing -> back t; Just (s',x') -> Just (t >< s', x')} + + prop_drop1 s = drop 0 s == s + prop_drop2 s n = n>0 ==> drop (n+1) s == case front (drop n s) of Nothing -> empty; Just (_,s') -> s' + + prop_take1 s = take 0 s == empty + prop_take2 s n = n>0 ==> take (n+1) s == case front s of Nothing -> empty; Just (x,s') -> x <| take n s' + + prop_reverse s = foldMap f (reverse s) == getDual (foldMap (Dual . f) s) + + prop_mempty = mempty == empty + + prop_eq_fold s1 s2 = s1 == s2 ==> foldMap f s1 == foldMap f s2 + +-- | indexed_sequence_properties returns the following properties: +-- +-- [/domain/] +-- +-- > k `inDomain` s <==> k >= 0 && k < size s +-- +-- [/left1/] +-- +-- > k `inDomain` s ==> index (k+1) (x <| s) == index k s +-- +-- [/left2/] +-- +-- > index 0 (x <| s) == x +-- +-- [/right1/] +-- +-- > k `inDomain` s ==> index k (s |> x) == index k s +-- +-- [/right2/] +-- +-- > index (size s) (s |> x) == x +-- +-- [/append1/] +-- +-- > k `inDomain` t ==> index (k+size s) (s >< t) == index k t +-- +-- [/append2/] +-- +-- > k `inDomain` s ==> index k (s >< t) == index k s + +indexed_sequence_properties :: forall s a . (Arbitrary s, Arbitrary a, + Show s, Show a, + Eq s, Eq a, + Sequence s a, + Indexed s Int a + ) => s -> [(Property,String)] +indexed_sequence_properties _ = [(property prop_domain,"domain"), (property prop_left1,"left1"), (property prop_left2,"left2"), (property prop_right1,"right1"), (property prop_right2,"right2"), (property prop_append1,"append1"), (property prop_append2,"append2")] + where + index = C.index :: Int -> s -> a + (<|) = (C.<|) :: a -> s -> s + (|>) = (C.|>) :: s -> a -> s + (><) = (C.><) :: s -> s -> s + inDomain = C.inDomain :: Int -> s -> Bool + + prop_domain k s = k `inDomain` s <==> k >= 0 && k < size s + + prop_left1 k s x = k `inDomain` s ==> index (k+1) (x <| s) == index k s + prop_left2 s x = index 0 (x <| s) == x + prop_right1 k s x = k `inDomain` s ==> index k (s |> x) == index k s + prop_right2 s x = index (size s) (s |> x) == x + prop_append1 k s t = k `inDomain` t ==> index (k+size s) (s >< t) == index k t + prop_append2 k s t = k `inDomain` s ==> index k (s >< t) == index k s + +-- | indexed_map_properties returns the following properties: +-- +-- [/domain/] +-- +-- > k `inDomain` m <==> k `member` m +-- +-- [/index/] +-- +-- > case lookup k m of {Just x -> x == index k m; _ -> True} + +indexed_map_properties :: forall m k v. (Arbitrary m, Arbitrary k, Arbitrary v, + Show k, Show v, Show m, + Eq m, Eq v, + Map m k v, + Indexed m k v + ) => m -> [(Property,String)] +indexed_map_properties _ = [(property prop_domain,"domain"), (property prop_index,"index")] + where + index = C.index :: k -> m -> v + inDomain = C.inDomain :: k -> m -> Bool + prop_domain k m = k `inDomain` m <==> k `member` m + prop_index k m = case lookup k m of {Just x -> x == index k m; _ -> True} + diff --git a/Data/Map/AVL.hs b/Data/Map/AVL.hs new file mode 100644 --- /dev/null +++ b/Data/Map/AVL.hs @@ -0,0 +1,639 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Map.AVL +-- Copyright : (c) Adrian Hey 2005,2006 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : provisional +-- Portability : portable +-- +-- This module provides an AVL tree based clone of the base package Data.Map. +-- +-- There are some differences though.. +-- +-- * 'size' is O(n), not O(1). Consequently, indexed access is disabled. +-- +-- * The showTree and showTreeWith functions are not implemented. +-- +-- * Some other functions are not yet implemented. +-- +----------------------------------------------------------------------------- +module Data.Map.AVL ( + -- * Map type + Map + + -- * Operators + , (!) + , (\\) + + + -- * Query + , null + , size + , member + , lookup + , findWithDefault + + -- * Construction + , empty + , singleton + + -- ** Insertion + , insert + , insertWith, insertWithKey, insertLookupWithKey + + -- ** Delete\/Update + , delete + , adjust + , alter + , adjustWithKey + , update + , updateWithKey + , updateLookupWithKey + + -- * Combine + + -- ** Union + , union + , unionWith + , unionWithKey + , unions + , unionsWith + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , intersection + , intersectionWith + , intersectionWithKey + + -- * Traversal + -- ** Map + , map + , mapWithKey + , mapAccum +-- , mapAccumWithKey +-- , mapKeys +-- , mapKeysWith +-- , mapKeysMonotonic + + -- ** Fold + , fold + , foldWithKey + + -- * Conversion + , elems + , keys + , keysSet + , liftKeysSet + , assocs + , unsafeFromTree + , toTree + + , toList + , fromList + , fromListWith + , fromListWithKey + + -- ** Ordered lists + , toAscList + , fromAscList + , fromAscListWith + , fromAscListWithKey + , fromDistinctAscList + + -- * Filter + , filter + , filterWithKey + , partition + , partitionWithKey + + , split + , splitLookup + + -- * Submap + , isSubmapOf + , isSubmapOfBy +-- , isProperSubmapOf, isProperSubmapOfBy + + -- * Indexed +-- , lookupIndex +-- , findIndex +-- , elemAt +-- , updateAt +-- , deleteAt + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax +-- , updateMin +-- , updateMax +-- , updateMinWithKey +-- , updateMaxWithKey + + -- * Debugging +-- , showTree +-- , showTreeWith +-- , valid + ) where + +import Prelude hiding (lookup,map,filter,foldr,foldl,null) +import qualified Data.List as List +import Data.Monoid +-- import qualified Data.Maybe as Maybe +import qualified Data.Set.AVL as Set + +-- import Data.Monoid +import Data.Foldable hiding (toList, find, fold) +import qualified Data.COrdering as COrdering +import qualified Data.Tree.AVL as AVL +-- import qualified Data.Tree.AVL.Test.Utils as AVL + +import Data.Typeable + +#include "Typeable.h" +INSTANCE_TYPEABLE2(Map,mapTc,"Data.Map.AVL") + + +------------------------------------------------------ +---- local combining comparison utilities ---------- +------------------------------------------------------ +readValCC :: Ord k => k -> (k, a) -> COrdering.COrdering a +readValCC k (k', a) = case compare k k' of + LT -> COrdering.Lt + EQ -> COrdering.Eq a + GT -> COrdering.Gt + +mcmp :: Ord a => (a, b) -> (a, c) -> COrdering.COrdering (a, b) +mcmp (k, a) (k', _) = case compare k k' of + LT -> COrdering.Lt + EQ -> COrdering.Eq (k, a) + GT -> COrdering.Gt + +mfcmp :: Ord k => (k -> a -> b -> c) -> (k, a) -> (k, b) + -> COrdering.COrdering (k, c) +mfcmp f (k, a) (k', b) = case compare k k' of + LT -> COrdering.Lt + EQ -> COrdering.Eq (k, f k a b) + GT -> COrdering.Gt + +mmfcmp :: (Functor f, Ord k) => (k -> a -> b -> f c) -> (k, a) + -> (k, b) -> COrdering.COrdering (f (k, c)) +mmfcmp f (k, a) (k', b) = case compare k k' of + LT -> COrdering.Lt + EQ -> COrdering.Eq $ fmap (\c -> (k, c)) $ f k a b + GT -> COrdering.Gt + +infixl 9 !, \\ -- + +toOrdering :: COrdering.COrdering a -> Ordering +toOrdering c = case c of + COrdering.Lt -> LT + COrdering.Eq _ -> EQ + COrdering.Gt -> GT + +toOrd :: (a -> b -> COrdering.COrdering c) -> a -> b -> Ordering +toOrd f a = toOrdering . f a + +-- | A Map from keys @k@ to values @a@. +newtype Map k a = Map (AVL.AVL (k, a)) +-- deriving (Eq, Ord, Show) + +instance (Eq k, Eq a) => Eq (Map k a) where + m1 == m2 = toList m1 == toList m2 + +instance (Ord k, Ord a) => Ord (Map k a) where + compare m1 m2 = compare (toList m1) (toList m2) + +showSet :: (Show a) => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x':xs') = showString ", " . shows x' . showTail xs' + +instance (Show k, Show a) => Show (Map k a) where + showsPrec _ (Map t) = showSet (AVL.asListL t) + +-- | /O(1)/. The empty map. +empty :: Map k a +empty = Map (AVL.empty) + +-- | /O(1)/. A map with a single element. +singleton :: k -> a -> Map k a +singleton k a = k `seq` Map (AVL.singleton (k, a)) + +-- | /O(1)/. Is the map empty? +null :: Map k a -> Bool +null (Map t) = AVL.isEmpty t + +-- | /O(n)/. The number of elements in the map. +size :: Map k a -> Int +size (Map t) = AVL.size t + +-- | /O(log n)/. Is the key a member of the map? +member :: Ord k => k -> Map k a -> Bool +member k (Map t) = k `seq` AVL.genContains t (compare k . fst) + +-- | /O(log n)/. Find the value at a key. +-- Calls 'error' when the element can not be found. +(!) :: Ord k => Map k a -> k -> a +(!) m k = find k m + +-- | /O(log n)/. Find the value at a key. +-- Calls 'error' when the element can not be found. +find :: Ord k => k -> Map k a -> a +find = findWithDefault (error "Map.find: element not in the map") + +-- | /O(log n)/. Lookup the value at a key in the map. +lookup :: (Monad m,Ord k) => k -> Map k a -> m a +lookup k (Map t) = k `seq` maybe (fail "AvlMap.lookup: Key not found") + return (AVL.genTryRead t (readValCC k)) + +-- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns +-- the value at key @k@ or returns @def@ when the key is not in the map. +findWithDefault :: Ord k => a -> k -> Map k a -> a +findWithDefault def k (Map t) = k `seq` AVL.genDefaultRead def t (readValCC k) + +-- | /O(log n)/. Insert a new key and value in the map. +-- If the key is already present in the map, the associated value is +-- replaced with the supplied value, i.e. 'insert' is equivalent to +-- @'insertWith' 'const'@. +insert :: Ord k => k -> a -> Map k a -> Map k a +insert k a (Map t) = k `seq` Map (AVL.genPush (mcmp (k, a)) (k, a) t) + +-- | /O(log n)/. Insert with a combining function. +insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWith f = insertWithKey (\_ z y -> f z y) + +-- | /O(log n)/. Insert with a combining function. +insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a +insertWithKey f k a (Map t) = + k `seq` Map (AVL.genPush (mfcmp f (k, a)) (k, a) t) + +-- | /O(log n)/. The expression (@'insertLookupWithKey' f k x map@) +-- is a pair where the first element is equal to (@'lookup' k map@) +-- and the second element equal to (@'insertWithKey' f k x map@). +-- +-- TODO: only one traversal. This requires fiddling with AVL.Push. +insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a) +insertLookupWithKey f k a m = (lookup k m, insertWithKey f k a m) + + +-- | /O(log n)/. Delete a key and its value from the map. When the key is not +-- a member of the map, the original map is returned. +delete :: Ord k => k -> Map k a -> Map k a +delete k (Map t) = k `seq` Map (AVL.genDel (compare k . fst) t) + +-- | /O(n)/. Map a function over all values in the map. +map :: (a -> b) -> Map k a -> Map k b +map f = mapWithKey (\_ x -> f x) + +-- | /O(n)/. Map a function over all values in the map. +mapWithKey :: (k -> a -> b) -> Map k a -> Map k b +mapWithKey f (Map t) = Map (AVL.mapAVL mf t) + where mf (k', a') = (k', f k' a') + +-- | /O(n)/. The function 'mapAccum' threads an accumulating +-- argument through the map in ascending order of keys. +mapAccum :: Ord k => (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c) +mapAccum f a = foldWithKey ( \ k b (s, m) -> + let (r, c) = f s b in (r, insert k c m)) (a, empty) + +-- | /O(n)/. Filter all values that satisfy the predicate. +filter :: Ord k => (a -> Bool) -> Map k a -> Map k a +filter p (Map t) = Map (AVL.filterViaList (p . snd) t) + +-- | /O(n)/. Filter all keys\/values that satisfy the predicate. +filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a +filterWithKey p (Map t) = Map (AVL.filterViaList (mp p) t) + +mp :: (k -> a -> Bool) -> (k, a) -> Bool +mp p (k, a) = p k a + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. +partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a) +partition p = partitionWithKey (\_ x -> p x) + +-- | /O(n)/. partition the map according to a predicate. The first +-- map contains all elements that satisfy the predicate, the second all +-- elements that fail the predicate. +partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a) +partitionWithKey p (Map t) = let (t1, t2) = AVL.partitionAVL (mp p) t in + (Map t1, Map t2) + +-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where all elements in @set1@ are lower than @x@ and all elements in +-- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@. +split :: Ord k => k -> Map k a -> (Map k a,Map k a) +split k (Map t) = (Map lessT, Map greaterT) + where (lessT, _, greaterT) = AVL.genFork (readValCC k) t + + +-- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just +-- like 'split' but also returns @'lookup' k map@. +splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a) +splitLookup k (Map t) = (Map lessT, a, Map greaterT) + where (lessT, a, greaterT) = AVL.genFork (readValCC k) t + + +-- | /O(log n)/. The minimal key of the map. +findMin :: Map k a -> (k,a) +findMin (Map t) = AVL.assertReadL t + +-- | /O(log n)/. Delete the minimal key. +deleteMin :: Map k a -> Map k a +deleteMin (Map t) = Map $ maybe (error "Set.deleteMin") id $ AVL.tryDelL t + +-- | /O(log n)/. Delete and find the minimal element. +deleteFindMin :: Map k a -> ((k,a),Map k a) +deleteFindMin (Map t) = let ((m, v), s) = AVL.assertPopL t in ((m, v), Map s) + +-- | /O(log n)/. Delete and find the maximal element. +deleteFindMax :: Map k a -> ((k,a),Map k a) +deleteFindMax (Map t) = let (s, (m, v)) = AVL.assertPopR t in ((m, v), Map s) + +-- | /O(log n)/. The minimal key of the map. +findMax :: Map k a -> (k,a) +findMax (Map t) = AVL.assertReadR t + +-- | /O(log n)/. Delete the minimal key. +deleteMax :: Map k a -> Map k a +deleteMax (Map t) = Map $ maybe (error "Set.deleteMax") id $ AVL.tryDelR t + +-- | /O(n+m)/. Intersection of two maps. The values in the first +-- map are returned, i.e. +-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@). +intersection :: Ord k => Map k a -> Map k b -> Map k a +intersection (Map t1) (Map t2) = Map (AVL.genIntersection mcmp t1 t2) + +-- | /O(n+m)/. Intersection with a combining function. +intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c +intersectionWith f = intersectionWithKey (\_ x y -> f x y) + +-- | /O(n+m)/. Intersection with a combining function. +-- Intersection is more efficient on (bigset `intersection` smallset) +intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b + -> Map k c +intersectionWithKey f (Map t1) (Map t2) = + Map (AVL.genIntersection (mfcmp f) t1 t2) + +-- | /O(n)/. Convert to a list of key\/value pairs. +toList :: Map k a -> [(k,a)] +toList (Map t) = AVL.asListL t + +-- | /O(n)/. Convert to a list of key\/value pairs. +toAscList :: Map k a -> [(k,a)] +toAscList = toList + +-- | /O(n)/. Convert to a list of key\/value pairs. +assocs :: Map k a -> [(k,a)] +assocs = toList + +-- | /O(n)/. Convert to a list of keys. +keys :: Map k a -> [k] +keys = List.map fst . toList + + +-- | /O(n)/. The set of all keys of the map. +keysSet :: Map k a -> Set.Set k +keysSet = Set.unsafeFromTree . fmap fst . toTree + +-- | /O(n)/. Apply a function to each element of a set and return the resulting map. +liftKeysSet :: (k -> b) -> Set.Set k -> Map k b +liftKeysSet f = unsafeFromTree . fmap (\k -> (k,f k)) . Set.toTree + + +-- | /O(n)/. Convert to a list of values. +elems :: Map k a -> [a] +elems (Map t) = List.map snd (AVL.asListL t) + +-- | /O(n)/. Fold the values in the map, such that +-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@. +-- For example, +-- +-- > elems map = fold (:) [] map +-- +fold :: (a -> b -> b) -> b -> Map k a -> b +fold f = foldWithKey (\_ x c -> f x c) + +foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b +foldWithKey f z (Map t) = AVL.foldlAVL' (\ c (k, a) -> f k a c) z t + +-- | /O(n+m)/. See 'difference'. +(\\) :: Ord k => Map k a -> Map k b -> Map k a +m1 \\ m2 = difference m1 m2 + +-- | /O(n+m)/. Difference of two maps. +difference :: Ord k => Map k a -> Map k b -> Map k a +difference (Map t1) (Map t2) = Map (AVL.genDifference (toOrd mcmp) t1 t2) + +-- | /O(n+m)/. Difference with a combining function. +differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a +differenceWith f = differenceWithKey (\_ x y -> f x y) + +differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b + -> Map k a +differenceWithKey f (Map t1) (Map t2) = + Map (AVL.genDifferenceMaybe (mmfcmp f) t1 t2) + +-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time. +-- /The precondition is not checked./ +fromDistinctAscList :: [(k,a)] -> Map k a +fromDistinctAscList = Map . AVL.asTreeL + +-- | /O(n)/. Build a map from an ascending list in linear time. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: Eq k => [(k,a)] -> Map k a +fromAscList = fromAscListWithKey (\_ x _ -> x) + +-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWith f = fromAscListWithKey (\_ x y -> f x y) + +-- | /O(n)/. Build a map from an ascending list in linear time with a +-- combining function for equal keys. +-- /The precondition (input list is ascending) is not checked./ +fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromAscListWithKey f = fromDistinctAscList . combineEq + where + -- [combineEq xs] combines equal elements with function [f] in an ordered list [xs] + combineEq xs + = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> combineEq' x xx + + combineEq' z [] = [z] + combineEq' z@(kz,zz) (x@(kx,xx):xs) + | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs + | otherwise = z:combineEq' x xs + +fromList :: Ord k => [(k,a)] -> Map k a +fromList l = Map (AVL.genAsTree mcmp l) + +-- | The union of a list of maps: +-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@). +unions :: Ord k => [Map k a] -> Map k a +unions ts + = foldlStrict union empty ts + +-- | The union of a list of maps, with a combining operation: +-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@). +unionsWith :: Ord k => (a->a->a) -> [Map k a] -> Map k a +unionsWith f ts + = foldlStrict (unionWith f) empty ts + +-- | /O(n+m)/. +-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. +-- It prefers @t1@ when duplicate keys are encountered, +-- i.e. (@'union' == 'unionWith' 'const'@). +-- The implementation uses the efficient /hedge-union/ algorithm. +-- Hedge-union is more efficient on (bigset `union` smallset)? +union :: Ord k => Map k a -> Map k a -> Map k a +union = unionWith const + +-- | /O(n+m)/. Union with a combining function. +unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWith f = unionWithKey (\_ x y -> f x y) + +-- | /O(n+m)/. +-- Union with a combining function. +unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a +unionWithKey f (Map t1) (Map t2) = Map (AVL.genUnion (mfcmp f) t1 t2) + +-- | /O(n+m)/. +-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). +isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool +isSubmapOf = isSubmapOfBy (==) + +{- | /O(n+m)/. + The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if + all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when + applied to their respective values. For example, the following + expressions are all 'True': + + > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) + + But the following are all 'False': + + > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) + > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) + > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) +-} +isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool +isSubmapOfBy f (Map s) (Map t) = AVL.genIsSubsetOf + (\ (k, a) (k', b) -> case compare k k' of + LT -> LT + GT -> GT + EQ -> if f a b then EQ else LT) s t + +-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. +-- 'alter' can be used to insert, delete, or update a value in a 'Map'. +-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@ +alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a +alter f k m = case f (lookup k m) of + Just a -> insert k a m + Nothing -> delete k m +-- TODO: add support for this in Data.Tree.AVL + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a +adjust f = adjustWithKey (\_ x -> f x) + +-- | /O(log n)/. Adjust a value at a specific key. When the key is not +-- a member of the map, the original map is returned. +adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a +adjustWithKey f = updateWithKey (\k x -> Just (f k x)) + +-- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@ +-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is +-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. +update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a +update f = updateWithKey (\_ x -> f x) + +-- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the +-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', +-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound +-- to the new value @y@. +updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a +updateWithKey f k (Map t) = let + cc (k', a) = case compare k k' of + LT -> COrdering.Lt + EQ -> COrdering.Eq $ fmap ( \ c -> (k', c)) $ f k' a + GT -> COrdering.Gt + in Map (AVL.genDelMaybe cc t) + +-- | /O(log n)/. Lookup and update. +-- +-- TODO: only one traversal. This requires fiddling with AVL.Push. +updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a) +updateLookupWithKey f k m = (lookup k m, updateWithKey f k m) + + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. +fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a +fromListWith f xs + = fromListWithKey (\_k x y -> f x y) xs + +-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. +fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a +fromListWithKey f xs + = foldlStrict ins empty xs + where + ins t (k,x) = insertWithKey f k x t + + +------------------------------ +-- Conversion from/to raw tree. + +-- | /O(1)/. Convert a /sorted/ AVL tree to an AVL tree based Set (as provided by this module). +-- This function does not check the input AVL tree is sorted. +{-# INLINE unsafeFromTree #-} +unsafeFromTree :: AVL.AVL (k,a) -> Map k a +unsafeFromTree = Map + +-- | /O(1)/. Convert an AVL tree based Set (as provided by this module) to a sorted AVL tree. +{-# INLINE toTree #-} +toTree :: Map k a -> AVL.AVL (k,a) +toTree (Map t) = t + + +----------------------------- +-- Instances + +instance Foldable (Map k) where + foldMap f (Map t) = foldMap (f . snd) t + +instance Ord k => Monoid (Map k a) where + mempty = empty + mappend = union + +instance Functor (Map k) where + fmap f (Map t) = Map (fmap f' t) + where f' (k,a) = (k,f a) + +------------------------------------------------- +-- Utilities + +foldlStrict :: (a -> b -> a) -> a -> [b] -> a +foldlStrict f z xs + = case xs of + [] -> z + (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx) diff --git a/Data/Map/List.hs b/Data/Map/List.hs new file mode 100644 --- /dev/null +++ b/Data/Map/List.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} + +module Data.Map.List (AssocList(..)) where + +import Data.Monoid +import qualified Data.Maybe as Maybe +import qualified Data.List as List +import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap,head) +import Data.Collections +import Data.Typeable +import Data.Ord (comparing) + + +-- | View a list (actually any 'Sequence') of @(key,value)@ pairs as a 'Map' collection. +-- +-- This allows to feed sequences into algorithms that require a map without building a full-fledged map. +-- Most of the time this will be used only when the parameter list is known to be very small, such that +-- conversion to a Map would be to costly. +-- + +newtype AssocList s k v = AssocList s + +-- FIXME: GHC 6.4 cannot see that Sequence c (k,v) implies the FD: c -> k v +-- Hence it requires two extra parameters to AssocList. Drop them as possible. + +#include "Typeable.h" +INSTANCE_TYPEABLE3(AssocList,theTc,"Data.Map.List.AssocList") + +instance (Eq c, Eq k, Eq v, Foldable c (k,v)) => Eq (AssocList c k v) where + (AssocList l1) == (AssocList l2) = l1 == l2 || + (size l1 == size l2 && all (`elem` l1) l2) + + +instance Show l => Show (AssocList l k v) where + show (AssocList l) = "AssocList " >< show l + +instance Sequence c (k,v) => Foldable (AssocList c k v) (k,v) where + foldr f z (AssocList l) = foldr f z l + null (AssocList l) = null l + +instance (Ord k, Sequence c (k,v)) => Collection (AssocList c k v) (k,v) where + filter f (AssocList l) = AssocList $ filter f l + +instance (Ord k, Sequence c (k,v)) => Unfoldable (AssocList c k v) (k,v) where + empty = AssocList empty + insert (k,v) m = insertWith const k v m + +instance (Ord k, Sequence c (k,v)) => Indexed (AssocList c k v) k v where + index k c = Maybe.fromJust $ lookup k c + adjust f k c = alter (fmap f) k c + inDomain = member + +instance (Ord k, Sequence c (k,v)) => Monoid (AssocList c k v) where + mempty = empty + mappend = union + +instance (Ord k, Sequence c (k,v), Monoid (AssocList c k v)) => Map (AssocList c k v) k v where + isSubmapBy f c1 c2 = all (\(k,v) -> case lookup k c2 of + Nothing -> False + Just v' -> f v v') c1 + c1 `isSubset` c2 = all (`member` c2) (KeysView c1) + lookup k (AssocList l) = maybe (fail "Key not found") (return . snd) (find ((k ==) . fst) l) + intersectionWith f (AssocList m1) m2 + = AssocList $ fromList + [(k,f x y) | (k,x) <- toList m1, + y <- Maybe.maybeToList $ lookup k m2] + + unionWith f (AssocList m1) (AssocList m2) = AssocList $ fromList $ List.map unionOne $ + List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) $ toList (m1 >< m2) + where unionOne list = (fst (head list), foldr1 f (List.map snd list)) + differenceWith f (AssocList m1) m2 = AssocList $ fromList $ Maybe.catMaybes + [newEl k x (lookup k m2) | (k,x) <- toList m1] + where newEl k x Nothing = Just (k,x) + newEl k x (Just y) = fmap (\x->(k,x)) (f x y) + alter f k m@(AssocList l) = AssocList $ foldr construct + (if member k m then empty else maybe empty (\x -> singleton (k,x)) (f Nothing)) l + where construct :: (k,v) -> c -> c + construct a@(k',x) l + | k'== k = case f (Just x) of + Nothing -> l + Just x -> (k', x) <| l + | otherwise = a <| l + mapWithKey f (AssocList l) = AssocList (smap l) + where smap = foldr (\(k,x) s -> (k,f k x) <| s) mempty + +on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c) +on op f x y = op (f x) (f y) diff --git a/Data/Ranged.hs b/Data/Ranged.hs new file mode 100644 --- /dev/null +++ b/Data/Ranged.hs @@ -0,0 +1,10 @@ + +module Data.Ranged ( + module Data.Ranged.Boundaries, + module Data.Ranged.Ranges, + module Data.Ranged.RangedSet +) where + +import Data.Ranged.Boundaries +import Data.Ranged.Ranges +import Data.Ranged.RangedSet diff --git a/Data/Ranged/Boundaries.hs b/Data/Ranged/Boundaries.hs new file mode 100644 --- /dev/null +++ b/Data/Ranged/Boundaries.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ranged.Boundaries +-- Copyright : (c) Paul Johnson 2006 +-- License : BSD-style +-- Maintainer : paul@cogito.org.uk +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + + + +module Data.Ranged.Boundaries ( + DiscreteOrdered, + adjacent, + enumAdjacent, + boundedAdjacent, + Boundary (..), + above, + (/>/) +) where + +import Data.Ratio +import Test.QuickCheck + +infix 4 />/ + +{- | +Distinguish between dense and sparse ordered types. A dense type is +one in which any two values @v1 < v2@ have a third value @v3@ such that +@v1 < v3 < v2@. + +In theory the floating types are dense, although in practice they can only have +finitely many values. This class treats them as dense. + +Tuples up to 4 members are declared as instances. Larger tuples may be added +if necessary. + +This approach was suggested by Ben Rudiak-Gould on comp.lang.functional. +-} +class Ord a => DiscreteOrdered a where + -- | Two values @x@ and @y@ are adjacent if @x < y@ and there does not + -- exist a third value between them. Always @False@ for dense types. + adjacent :: a -> a -> Bool + +instance DiscreteOrdered Bool where adjacent = boundedAdjacent +instance DiscreteOrdered Ordering where adjacent = boundedAdjacent +instance DiscreteOrdered Char where adjacent = boundedAdjacent +instance DiscreteOrdered Int where adjacent = boundedAdjacent +instance DiscreteOrdered Integer where adjacent = enumAdjacent +instance Integral a => DiscreteOrdered (Ratio a) + where adjacent _ _ = False +instance DiscreteOrdered Float where adjacent _ _ = False +instance DiscreteOrdered Double where adjacent _ _ = False +instance Ord a => DiscreteOrdered [a] where adjacent _ _ = False +instance (Ord a, DiscreteOrdered b) => DiscreteOrdered (a, b) + where adjacent (x1, x2) (y1, y2) = (x1 == y1) && adjacent x2 y2 +instance (Ord a, Ord b, DiscreteOrdered c) => DiscreteOrdered (a, b, c) + where + adjacent (x1, x2, x3) (y1, y2, y3) = + (x1 == y1) && (x2 == y2) && adjacent x3 y3 +instance (Ord a, Ord b, Ord c, DiscreteOrdered d) => + DiscreteOrdered (a, b, c, d) + where + adjacent (x1, x2, x3, x4) (y1, y2, y3, y4) = + (x1 == y1) && (x2 == y2) && (x3 == y3) && adjacent x4 y4 + +-- | Check adjacency for sparse enumerated types (i.e. where there +-- is no value between @x@ and @succ x@). Use as the definition of +-- "adjacent" for most enumerated types. +enumAdjacent :: (Ord a, Enum a) => a -> a -> Bool +enumAdjacent x y = (succ x == y) + +-- | Check adjacency, allowing for case where x = maxBound. Use as the +-- definition of "adjacent" for bounded enumerated types such as Int and Char. +boundedAdjacent :: (Ord a, Enum a) => a -> a -> Bool +boundedAdjacent x y = if x < y then succ x == y else False + + +{- | +A Boundary is a division of an ordered type into values above +and below the boundary. No value can sit on a boundary. + +Known bug: for Bounded types + +* @BoundaryAbove maxBound < BoundaryAboveAll@ + +* @BoundaryBelow minBound > BoundaryBelowAll@ + +This is incorrect because there are no possible values in +between the left and right sides of these inequalities. +-} + +data Boundary a = + -- | The argument is the highest value below the boundary. + BoundaryAbove a | + -- | The argument is the lowest value above the boundary. + BoundaryBelow a | + -- | The boundary above all values. + BoundaryAboveAll | + -- | The boundary below all values. + BoundaryBelowAll + deriving (Show) + +-- | True if the value is above the boundary, false otherwise. +above :: Ord v => Boundary v -> v -> Bool +above (BoundaryAbove b) v = v > b +above (BoundaryBelow b) v = v >= b +above BoundaryAboveAll _ = False +above BoundaryBelowAll _ = True + +-- | Same as 'above', but with the arguments reversed for more intuitive infix +-- usage. +(/>/) :: Ord v => v -> Boundary v -> Bool +(/>/) = flip above + +instance (DiscreteOrdered a) => Eq (Boundary a) where + b1 == b2 = compare b1 b2 == EQ + +instance (DiscreteOrdered a) => Ord (Boundary a) where + -- Comparison alogrithm based on brute force and ignorance: + -- enumerate all combinations. + + compare boundary1 boundary2 = + case boundary1 of + BoundaryAbove b1 -> + case boundary2 of + BoundaryAbove b2 -> compare b1 b2 + BoundaryBelow b2 -> + if b1 < b2 + then + if adjacent b1 b2 then EQ else LT + else GT + BoundaryAboveAll -> LT + BoundaryBelowAll -> GT + BoundaryBelow b1 -> + case boundary2 of + BoundaryAbove b2 -> + if b1 > b2 + then + if adjacent b2 b1 then EQ else GT + else LT + BoundaryBelow b2 -> compare b1 b2 + BoundaryAboveAll -> LT + BoundaryBelowAll -> GT + BoundaryAboveAll -> + case boundary2 of + BoundaryAboveAll -> EQ + otherwise -> GT + BoundaryBelowAll -> + case boundary2 of + BoundaryBelowAll -> EQ + otherwise -> LT + +-- QuickCheck Generator + +instance Arbitrary a => Arbitrary (Boundary a) where + arbitrary = frequency [ + (1, return BoundaryAboveAll), + (1, return BoundaryBelowAll), + (18, do + v <- arbitrary + oneof [return $ BoundaryAbove v, return $ BoundaryBelow v] + )] + coarbitrary BoundaryBelowAll = variant 0 + coarbitrary BoundaryAboveAll = variant 1 + coarbitrary (BoundaryBelow v) = variant 2 . coarbitrary v + coarbitrary (BoundaryAbove v) = variant 3 . coarbitrary v + diff --git a/Data/Ranged/RangedSet.hs b/Data/Ranged/RangedSet.hs new file mode 100644 --- /dev/null +++ b/Data/Ranged/RangedSet.hs @@ -0,0 +1,544 @@ +module Data.Ranged.RangedSet ( + -- ** Ranged Set Type + RSet, + rSetRanges, + -- ** Ranged Set construction functions and their Preconditions + makeRangedSet, + unsafeRangedSet, + validRangeList, + normaliseRangeList, + rSingleton, + -- ** Predicates + rSetIsEmpty, + (-?-), rSetHas, + (-<=-), rSetIsSubset, + (-<-), rSetIsSubsetStrict, + -- ** Set Operations + (-\/-), rSetUnion, + (-/\-), rSetIntersection, + (-!-), rSetDifference, + rSetNegation, + -- ** Useful Sets + rSetEmpty, + rSetFull, + rSetUnfold + + -- ** QuickCheck Properties + + -- *** Construction + -- $ConstructionProperties + + -- *** Basic Operations + -- $BasicOperationProperties + + -- *** Some Identities and Inequalities + -- $SomeIdentitiesAndInequalities +) where + +import Data.Ranged.Boundaries +import Data.Ranged.Ranges +import Data.Monoid + +import Data.List +import Test.QuickCheck + +import Data.Typeable + +infixl 7 -/\- +infixl 6 -\/-, -!- +infixl 5 -<=-, -<-, -?- + +-- | An RSet (for Ranged Set) is a list of ranges. The ranges must be sorted +-- and not overlap. + +newtype DiscreteOrdered v => RSet v = RSet {rSetRanges :: [Range v]} + deriving (Eq, Show) + +instance DiscreteOrdered a => Monoid (RSet a) where + mappend = rSetUnion + mempty = rSetEmpty + +#include "Typeable.h" +INSTANCE_TYPEABLE1(RSet,theTc,"Data.RangedSet") + + +-- | Determine if the ranges in the list are both in order and non-overlapping. +-- If so then they are suitable input for the unsafeRangedSet function. +validRangeList :: DiscreteOrdered v => [Range v] -> Bool + +validRangeList [] = True +validRangeList [Range lower upper] = lower <= upper +validRangeList ranges = and $ zipWith okAdjacent ranges (tail ranges) + where + okAdjacent (Range lower1 upper1) (Range lower2 upper2) = + lower1 <= upper1 && upper1 <= lower2 && lower2 <= upper2 + + +-- | Rearrange and merge the ranges in the list so that they are in order and +-- non-overlapping. +normaliseRangeList :: DiscreteOrdered v => [Range v] -> [Range v] + +normaliseRangeList ranges = + normalise $ sort $ filter (not . rangeIsEmpty) ranges + + +-- Private routine: normalise a range list that is known to be already sorted. +-- This precondition is not checked. +normalise :: DiscreteOrdered v => [Range v] -> [Range v] +normalise (r1:r2:rs) = + if overlap r1 r2 + then normalise $ + Range (rangeLower r1) + (max (rangeUpper r1) (rangeUpper r2)) + : rs + else r1 : (normalise $ r2 : rs) + where + overlap (Range _ upper1) (Range lower2 _) = upper1 >= lower2 + +normalise rs = rs + + +-- | Create a new Ranged Set from a list of ranges. The list may contain +-- ranges that overlap or are not in ascending order. +makeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v +makeRangedSet = RSet . normaliseRangeList + +-- | Create a new Ranged Set from a list of ranges. @validRangeList ranges@ +-- must return @True@. This precondition is not checked. +unsafeRangedSet :: DiscreteOrdered v => [Range v] -> RSet v +unsafeRangedSet = RSet + +-- | Create a Ranged Set from a single element. +rSingleton :: DiscreteOrdered v => v -> RSet v +rSingleton v = unsafeRangedSet [singletonRange v] + +-- | True if the set has no members. +rSetIsEmpty :: DiscreteOrdered v => RSet v -> Bool +rSetIsEmpty = null . rSetRanges + + +-- | True if the negation of the set has no members. +rSetIsFull :: DiscreteOrdered v => RSet v -> Bool +rSetIsFull = rSetIsEmpty . rSetNegation + + +-- | True if the value is within the ranged set. Infix precedence is left 5. +rSetHas, (-?-) :: DiscreteOrdered v => RSet v -> v -> Bool +rSetHas (RSet ls) value = rSetHas1 ls + where + rSetHas1 [] = False + rSetHas1 (r:rs) + | value />/ rangeLower r = rangeHas r value || rSetHas1 rs + | otherwise = False + +(-?-) = rSetHas + +-- | True if the first argument is a subset of the second argument, or is +-- equal. +-- +-- Infix precedence is left 5. +rSetIsSubset, (-<=-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool +rSetIsSubset rs1 rs2 = rSetIsEmpty (rs1 -!- rs2) +(-<=-) = rSetIsSubset + + +-- | True if the first argument is a strict subset of the second argument. +-- +-- Infix precedence is left 5. +rSetIsSubsetStrict, (-<-) :: DiscreteOrdered v => RSet v -> RSet v -> Bool +rSetIsSubsetStrict rs1 rs2 = + rSetIsEmpty (rs1 -!- rs2) + && not (rSetIsEmpty (rs2 -!- rs1)) + +(-<-) = rSetIsSubsetStrict + +-- | Set union for ranged sets. Infix precedence is left 6. +rSetUnion, (-\/-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v +-- Implementation note: rSetUnion merges the two lists into a single +-- sorted list and then calls normalise to combine overlapping ranges. +rSetUnion (RSet ls1) (RSet ls2) = RSet $ normalise $ merge ls1 ls2 + where + merge ls1 [] = ls1 + merge [] ls2 = ls2 + merge ls1@(h1:t1) ls2@(h2:t2) = + if h1 < h2 + then h1 : merge t1 ls2 + else h2 : merge ls1 t2 + +(-\/-) = rSetUnion + +-- | Set intersection for ranged sets. Infix precedence is left 7. +rSetIntersection, (-/\-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v +rSetIntersection (RSet ls1) (RSet ls2) = + RSet $ filter (not . rangeIsEmpty) $ merge ls1 ls2 + where + merge ls1@(h1:t1) ls2@(h2:t2) = + rangeIntersection h1 h2 + : if rangeUpper h1 < rangeUpper h2 + then merge t1 ls2 + else merge ls1 t2 + merge _ _ = [] + +(-/\-) = rSetIntersection + + +-- | Set difference. Infix precedence is left 6. +rSetDifference, (-!-) :: DiscreteOrdered v => RSet v -> RSet v -> RSet v +rSetDifference rs1 rs2 = rs1 -/\- (rSetNegation rs2) +(-!-) = rSetDifference + + +-- | Set negation. +rSetNegation :: DiscreteOrdered a => RSet a -> RSet a +rSetNegation set = RSet $ ranges $ setBounds1 + where + ranges (b1:b2:bs) = Range b1 b2 : ranges bs + ranges [BoundaryAboveAll] = [] + ranges [b] = [Range b BoundaryAboveAll] + ranges _ = [] + setBounds1 = case setBounds of + (BoundaryBelowAll : bs) -> bs + _ -> BoundaryBelowAll : setBounds + setBounds = bounds $ rSetRanges set + bounds (r:rs) = rangeLower r : rangeUpper r : bounds rs + bounds _ = [] + + +-- | The empty set. +rSetEmpty :: DiscreteOrdered a => RSet a +rSetEmpty = RSet [] + +-- | The set that contains everything. +rSetFull :: DiscreteOrdered a => RSet a +rSetFull = RSet [Range BoundaryBelowAll BoundaryAboveAll] + + +-- | Construct a range set. +rSetUnfold :: DiscreteOrdered a => + Boundary a + -- ^ A first lower boundary. + -> (Boundary a -> Boundary a) + -- ^ A function from a lower boundary to an upper boundary, which must + -- return a result greater than the argument (not checked). + -> (Boundary a -> Maybe (Boundary a)) + -- ^ A function from a lower boundary to @Maybe@ the successor lower + -- boundary, which must return a result greater than the argument + -- (not checked). + -> RSet a +rSetUnfold bound upperFunc succFunc = RSet $ normalise $ ranges bound + where + ranges b = + Range b (upperFunc bound) + : case succFunc b of + Just b2 -> ranges b2 + Nothing -> [] + + +-- QuickCheck Generators + +instance (Arbitrary v, DiscreteOrdered v, Show v) => + Arbitrary (RSet v) + where + arbitrary = frequency [ + (1, return rSetEmpty), + (1, return rSetFull), + (18, do + ls <- arbitrary + return $ makeRangedSet $ rangeList $ sort ls + )] + where + -- Arbitrary lists of ranges don't give many interesting sets after + -- normalisation. So instead generate a sorted list of boundaries + -- and pair them off. Odd boundaries are dropped. + rangeList (b1:b2:bs) = Range b1 b2 : rangeList bs + rangeList _ = [] + + coarbitrary (RSet ls) = variant 0 . coarbitrary ls + +-- ================================================================== +-- QuickCheck Properties +-- ================================================================== + +-- Note for maintenance: Haddock does not include QuickCheck properties, +-- so they have to be copied into documentation blocks manually. This +-- process must be repeated for new or modified properties. + + +--------------------------------------------------------------------- +-- Construction properties +--------------------------------------------------------------------- + +{- $ConstructionProperties + +A normalised range list is valid for unsafeRangedSet + +> prop_validNormalised ls = validRangeList $ normaliseRangeList ls +> where types = ls :: [Range Double] + +Iff a value is in a range list then it is in a ranged set +constructed from that list. + +> prop_has ls v = (ls `rangeListHas` v) == rangedSet ls -?- v + +-} + +-- A normalised range list is valid for unsafeRangedSet +prop_validNormalised ls = validRangeList $ normaliseRangeList ls + where types = ls :: [Range Integer] + +-- Iff a value is in a range list then it is in a ranged set +-- constructed from that list. +prop_has ls v = (ls `rangeListHas` v) == makeRangedSet ls -?- v + where types = v :: Integer + +--------------------------------------------------------------------- +-- Basic operation properties +--------------------------------------------------------------------- + +{- $BasicOperationProperties +Iff a value is in either of two ranged sets then it is in the union of +those two sets. + +> prop_union rs1 rs2 v = +> (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) + +Iff a value is in both of two ranged sets then it is in the intersection +of those two sets. + +> prop_intersection rs1 rs2 v = +> (rs1 -?- v && rs2 -?- v) == ((rs1 -/\- rs2) -?- v) + + +Iff a value is in ranged set 1 and not in ranged set 2 then it is in the +difference of the two. + +> prop_difference rs1 rs2 v = +> (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) + + +Iff a value is not in a ranged set then it is in its negation. + +> prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) + + +A set that contains a value is not empty + +> prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) + +-} + +-- Iff a value is in either of two ranged sets then it is in the union of +-- those two sets. +prop_union rs1 rs2 v = (rs1 -?- v || rs2 -?- v) == ((rs1 -\/- rs2) -?- v) + where types = v :: Integer + +-- Iff a value is in both of two ranged sets then it is in the intersection +-- of those two sets. +prop_intersection rs1 rs2 v = + (rs1 -?- v && rs2 -?- v) == ((rs1 `rSetIntersection` rs2) -?- v) + where types = v :: Integer + + +-- Iff a value is in ranged set 1 and not in ranged set 2 then it is in the +-- difference of the two. +prop_difference rs1 rs2 v = + (rs1 -?- v && not (rs2 -?- v)) == ((rs1 -!- rs2) -?- v) + where types = v :: Integer + + +-- Iff a value is not in a ranged set then it is in its negation. +prop_negation rs v = rs -?- v == not (rSetNegation rs -?- v) + where types = v :: Integer + + +-- A set that contains a value is not empty +prop_not_empty rs v = (rs -?- v) ==> not (rSetIsEmpty rs) + where types = v :: Integer + + +--------------------------------------------------------------------- +-- Some identities and inequalities of sets +--------------------------------------------------------------------- + +{- $SomeIdentitiesAndInequalities + +The empty set has no members. + +> prop_empty v = not (rSetEmpty -?- v) + + +The full set has every member. + +> prop_full v = rSetFull -?- v + + +The intersection of a set with its negation is empty. + +> prop_empty_intersection rs = +> rSetIsEmpty (rs -/\- rSetNegation rs) + + +The union of a set with its negation is full. + +> prop_full_union rs v = +> rSetIsFull (rs -\/- rSetNegation rs) + + +The union of two sets is the non-strict superset of both. + +> prop_union_superset rs1 rs2 = +> rs1 -<=- u && rs2 -<=- u +> where +> u = rs1 -\/- rs2 + +The intersection of two sets is the non-strict subset of both. + +> prop_intersection_subset rs1 rs2 = +> i -<=- rs1 && i -<=- rs2 +> where +> i = rs1 -/\- rs2 + +The difference of two sets intersected with the subtractand is empty. + +> prop_diff_intersect rs1 rs2 = +> rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) + +A set is the non-strict subset of itself. + +> prop_subset rs = rs -<=- rs + + +A set is not the strict subset of itself. + +> prop_strict_subset rs = not (rs -<- rs) + + +If rs1 - rs2 is not empty then the union of rs1 and rs2 will be a strict +superset of rs2. + +> prop_union_strict_superset rs1 rs2 = +> (not $ rSetIsEmpty (rs1 -!- rs2)) +> ==> (rs2 -<- (rs1 -\/- rs2)) + +Intersection commutes + +> prop_intersection_commutes rs1 rs2 = +> (rs1 -/\- rs2) == (rs2 -/\- rs1) + +Union commutes + +> prop_union_commutes rs1 rs2 = +> (rs1 -\/- rs2) == (rs2 -\/- rs1) + +Intersection associates + +> prop_intersection_associates rs1 rs2 rs3 = +> ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) + +Union associates + +> prop_union_associates rs1 rs2 rs3 = +> ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) + +De Morgan's Law for Intersection + +> prop_de_morgan_intersection rs1 rs2 = +> rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) + +De Morgan's Law for Union + +> prop_de_morgan_union rs1 rs2 = +> rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) + +-} + +-- The empty set has no members. +prop_empty v = not (rSetEmpty -?- v) + where types = v :: Integer + + +-- The full set has every member. +prop_full v = rSetFull -?- v + where types = v :: Integer + + +-- The intersection of a set with its negation is empty. +prop_empty_intersection rs = + rSetIsEmpty (rs -/\- rSetNegation rs) + where types = rs :: RSet Integer + + +-- The union of a set with its negation is full. +prop_full_union rs = + rSetIsFull (rs -\/- rSetNegation rs) + where types = rs :: RSet Integer + + +-- The union of two sets is the non-strict superset of both. +prop_union_superset rs1 rs2 = + rs1 -<=- u && rs2 -<=- u + where + u :: RSet Integer + u = rs1 -\/- rs2 + +-- The intersection of two sets is the non-strict subset of both. +prop_intersection_subset rs1 rs2 = + i -<=- rs1 && i -<=- rs2 + where + i :: RSet Integer + i = rs1 -/\- rs2 + +-- The difference of two sets intersected with the subtractand is empty. +prop_diff_intersect rs1 rs2 = + rSetIsEmpty ((rs1 -!- rs2) -/\- rs2) + where types = rs1 :: RSet Integer + + +-- A set is the non-strict subset of itself. +prop_subset rs = + rs -<=- rs + where types = rs :: RSet Integer + +-- A set is not the strict subset of itself. +prop_strict_subset rs = + not (rs -<- rs) + where types = rs :: RSet Integer + + +-- If rs1 - rs2 is not empty then the union of rs1 and rs2 will be a strict +-- superset of rs2. +prop_union_strict_superset rs1 rs2 = + (not $ rSetIsEmpty (rs1 -!- rs2)) + ==> (rs2 -<- (rs1 -\/- rs2)) + where types = rs1 :: RSet Integer + +-- Intersection commutes +prop_intersection_commutes :: RSet Integer -> RSet Integer -> Bool +prop_intersection_commutes rs1 rs2 = + (rs1 -/\- rs2) == (rs2 -/\- rs1) + where types = rs1 :: RSet Integer + +-- Union commutes +prop_union_commutes rs1 rs2 = + (rs1 -\/- rs2) == (rs2 -\/- rs1) + where types = rs1 :: RSet Integer + +-- Intersection associates +prop_intersection_associates rs1 rs2 rs3 = + ((rs1 -/\- rs2) -/\- rs3) == (rs1 -/\- (rs2 -/\- rs3)) + where types = rs1 :: RSet Integer + +-- Union associates +prop_union_associates rs1 rs2 rs3 = + ((rs1 -\/- rs2) -\/- rs3) == (rs1 -\/- (rs2 -\/- rs3)) + where types = rs1 :: RSet Integer + +-- De Morgan's Law for Intersection +prop_de_morgan_intersection rs1 rs2 = + rSetNegation (rs1 -/\- rs2) == (rSetNegation rs1 -\/- rSetNegation rs2) + where types = rs1 :: RSet Integer + +-- De Morgan's Law for Union +prop_de_morgan_union rs1 rs2 = + rSetNegation (rs1 -\/- rs2) == (rSetNegation rs1 -/\- rSetNegation rs2) + where types = rs1 :: RSet Integer diff --git a/Data/Ranged/Ranges.hs b/Data/Ranged/Ranges.hs new file mode 100644 --- /dev/null +++ b/Data/Ranged/Ranges.hs @@ -0,0 +1,247 @@ +{-# OPTIONS_GHC -cpp -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Ranged.Ranges +-- Copyright : (c) Paul Johnson 2006 +-- License : BSD-style +-- Maintainer : paul@cogito.org.uk +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + + +-- | A range has an upper and lower boundary. +module Data.Ranged.Ranges ( + -- ** Construction + Range (..), + emptyRange, + fullRange, + -- ** Predicates + rangeIsEmpty, + rangeOverlap, + rangeEncloses, + -- ** Membership + rangeHas, + rangeListHas, + -- ** Set Operations + singletonRange, + rangeIntersection, + rangeUnion, + rangeDifference + -- ** QuickCheck properties + -- $properties +) where + +import Data.Ranged.Boundaries +import Data.Maybe +import Test.QuickCheck + +-- | A Range has upper and lower boundaries. +data Ord v => Range v = Range {rangeLower, rangeUpper :: Boundary v} + +instance (DiscreteOrdered a) => Eq (Range a) where + r1 == r2 = (rangeIsEmpty r1 && rangeIsEmpty r2) || + (rangeLower r1 == rangeLower r2 && + rangeUpper r1 == rangeUpper r2) + + +instance (DiscreteOrdered a) => Ord (Range a) where + compare r1 r2 + | r1 == r2 = EQ + | rangeIsEmpty r1 = LT + | rangeIsEmpty r2 = GT + | otherwise = compare (rangeLower r1, rangeUpper r1) + (rangeLower r2, rangeUpper r2) + +instance (Show a, DiscreteOrdered a) => Show (Range a) where + show r + | rangeIsEmpty r = "Empty" + | otherwise = lowerBound ++ "x" ++ upperBound + where + lowerBound = case rangeLower r of + BoundaryBelowAll -> "" + BoundaryBelow v -> show v ++ " <= " + BoundaryAbove v -> show v ++ " < " + BoundaryAboveAll -> error "show Range: lower bound is BoundaryAboveAll" + upperBound = case rangeUpper r of + BoundaryBelowAll -> error "show Range: upper bound is BoundaryBelowAll" + BoundaryBelow v -> " < " ++ show v + BoundaryAbove v -> " <= " ++ show v + BoundaryAboveAll -> "" + + +-- | True if the value is within the range. +rangeHas :: Ord v => Range v -> v -> Bool + +rangeHas (Range b1 b2) v = + (v />/ b1) && not (v />/ b2) + + +-- | True if the value is within one of the ranges. +rangeListHas :: Ord v => + [Range v] -> v -> Bool +rangeListHas ls v = or $ map (\r -> rangeHas r v) ls + +-- | The empty range +emptyRange :: DiscreteOrdered v => Range v +emptyRange = Range BoundaryAboveAll BoundaryBelowAll + +-- | The full range. All values are within it. +fullRange :: DiscreteOrdered v => Range v +fullRange = Range BoundaryBelowAll BoundaryAboveAll + +-- | A range containing a single value +singletonRange :: DiscreteOrdered v => v -> Range v +singletonRange v = Range (BoundaryBelow v) (BoundaryAbove v) + +-- | A range is empty unless its upper boundary is greater than its lower +-- boundary. +rangeIsEmpty :: DiscreteOrdered v => Range v -> Bool +rangeIsEmpty (Range lower upper) = upper <= lower + + +-- | Two ranges overlap if their intersection is non-empty. +rangeOverlap :: DiscreteOrdered v => Range v -> Range v -> Bool +rangeOverlap r1 r2 = + not (rangeIsEmpty r1) + && not (rangeIsEmpty r2) + && not (rangeUpper r1 <= rangeLower r2 || rangeUpper r2 <= rangeLower r1) + + +-- | The first range encloses the second if every value in the second range is +-- also within the first range. If the second range is empty then this is +-- always true. +rangeEncloses :: DiscreteOrdered v => Range v -> Range v -> Bool +rangeEncloses r1 r2 = + (rangeLower r1 <= rangeLower r2 && rangeUpper r2 <= rangeUpper r1) + || rangeIsEmpty r2 + + +-- | Intersection of two ranges, if any. +rangeIntersection :: DiscreteOrdered v => Range v -> Range v -> Range v + +rangeIntersection (Range lower1 upper1) (Range lower2 upper2) = + Range (max lower1 lower2) (min upper1 upper2) + + +-- | Union of two ranges. Returns one or two results. +-- +-- If there are two results then they are guaranteed to have a non-empty +-- gap in between, but may not be in ascending order. +rangeUnion :: DiscreteOrdered v => Range v -> Range v -> [Range v] + +rangeUnion r1@(Range lower1 upper1) r2@(Range lower2 upper2) = + if touching + then [Range lower upper] + else [r1, r2] + where + touching = (max lower1 lower2) <= (min upper1 upper2) + lower = min lower1 lower2 + upper = max upper1 upper2 + + +-- | @range1@ minus @range2@. Returns zero, one or two results. Multiple +-- results are guaranteed to have non-empty gaps in between, but may not be in +-- ascending order. +rangeDifference :: DiscreteOrdered v => Range v -> Range v -> [Range v] + +rangeDifference r1@(Range lower1 upper1) r2@(Range lower2 upper2) = + -- There are six possibilities + -- 1: r2 completely less than r1 + -- 2: r2 overlaps bottom of r1 + -- 3: r2 encloses r1 + -- 4: r1 encloses r2 + -- 5: r2 overlaps top of r1 + -- 6: r2 completely greater than r1 + if intersects + then -- Cases 2,3,4,5 + filter (not . rangeIsEmpty) [Range lower1 lower2, Range upper2 upper1] + else -- Cases 1, 6 + [r1] + where + intersects = (max lower1 lower2) < (min upper1 upper2) + + +-- QuickCheck generators + +instance (Arbitrary v, DiscreteOrdered v, Show v) => + Arbitrary (Range v) where + + arbitrary = frequency [ + (18, do + b1 <- arbitrary + b2 <- arbitrary + if b1 < b2 + then return $ Range b1 b2 + else return $ Range b2 b1 + ), + (1, return emptyRange), + (1, return fullRange) + ] + + coarbitrary (Range lower upper) = + variant 0 . coarbitrary lower . coarbitrary upper + + + +-- QuickCheck Properties + +{- $properties +Range union + +> prop_union r1 r2 n = +> (r1 `rangeHas` n || r2 `rangeHas` n) +> == (r1 `rangeUnion` r2) `rangeListHas` n + +Range intersection + +> prop_intersection r1 r2 n = +> (r1 `rangeHas` n && r2 `rangeHas` n) +> == (r1 `rangeIntersection` r2) `rangeHas` n + +Range difference + +> prop_difference r1 r2 n = +> (r1 `rangeHas` n && not (r2 `rangeHas` n)) +> == (r1 `rangeDifference` r2) `rangeListHas` n + +-} + +-- Range union +prop_union_int r1 r2 n = + (r1 `rangeHas` n || r2 `rangeHas` n) + == (r1 `rangeUnion` r2) `rangeListHas` n + where t :: Integer ; t = n + + +-- Range intersection +prop_intersection_int r1 r2 n = + (r1 `rangeHas` n && r2 `rangeHas` n) + == (r1 `rangeIntersection` r2) `rangeHas` n + where t :: Integer ; t = n + +-- Range difference +prop_difference_int r1 r2 n = + (r1 `rangeHas` n && not (r2 `rangeHas` n)) + == (r1 `rangeDifference` r2) `rangeListHas` n + where t :: Integer ; t = n + + +prop_union_real r1 r2 n = + (r1 `rangeHas` n || r2 `rangeHas` n) + == (r1 `rangeUnion` r2) `rangeListHas` n + where t :: Double ; t = n + + +-- Range intersection +prop_intersection_real r1 r2 n = + (r1 `rangeHas` n && r2 `rangeHas` n) + == (r1 `rangeIntersection` r2) `rangeHas` n + where t :: Double ; t = n + +-- Range difference +prop_difference_real r1 r2 n = + (r1 `rangeHas` n && not (r2 `rangeHas` n)) + == (r1 `rangeDifference` r2) `rangeListHas` n + where t :: Double ; t = n diff --git a/Data/Set/AVL.hs b/Data/Set/AVL.hs new file mode 100644 --- /dev/null +++ b/Data/Set/AVL.hs @@ -0,0 +1,455 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Set.AVL +-- Copyright : (c) Adrian Hey 2005,2006 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : provisional +-- Portability : portable +-- +-- This module provides an AVL tree based clone of the base package Data.Set. +-- +-- There are some differences though.. +-- +-- * 'size' is O(n), not O(1) +-- +-- * The showTree and showTreeWith functions are not implemented. +-- +-- * The complexities of 'isSubsetOf','isProperSubsetOf','union','intersection','difference' +-- are unknown (because my maths isn't good enough to figure it out), +-- but are probably no worse than the originals. +-- +-- * Conversion functions 'toTree', 'unsafeFromTree', 'toStdSet', 'fromStdSet'. +-- have been added. +----------------------------------------------------------------------------- + +-- TODO: rename conversion functions: with unsafe prefix + +module Data.Set.AVL ( + -- * Set type + Set + + -- * Operators + , (\\) + + -- * Query + , null + , size + , member + , isSubsetOf + , isProperSubsetOf + + -- * Construction + , empty + , singleton + , insert + , delete + + -- * Combine + , union, unions + , difference + , intersection + + -- * Filter + , filter + , partition + , split + , splitMember + + -- * Map + , map + , mapMonotonic + + -- * Fold + , fold + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + + -- * Conversion + + -- ** List + , elems + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList + + -- ** To\/From Data.Set.Set + , toStdSet + , fromStdSet + + -- ** To\/From raw AVL trees. + -- | These conversions allow you to use the functions provided by Data.Tree.AVL. + , toTree + , unsafeFromTree + + -- * Debugging +-- , showTree +-- , showTreeWith + , valid + + -- * Old interface, DEPRECATED + ,emptySet, -- :: Set a + mkSet, -- :: Ord a => [a] -> Set a + setToList, -- :: Set a -> [a] + unitSet, -- :: a -> Set a + elementOf, -- :: Ord a => a -> Set a -> Bool + isEmptySet, -- :: Set a -> Bool + cardinality, -- :: Set a -> Int + unionManySets, -- :: Ord a => [Set a] -> Set a + minusSet, -- :: Ord a => Set a -> Set a -> Set a + mapSet, -- :: Ord a => (b -> a) -> Set b -> Set a + intersect, -- :: Ord a => Set a -> Set a -> Set a + addToSet, -- :: Ord a => Set a -> a -> Set a + delFromSet, -- :: Ord a => Set a -> a -> Set a + ) where + +import Prelude hiding (filter,foldr,null,map) +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Set +import Data.Monoid + +import qualified Data.COrdering as COrdering +import qualified Data.Tree.AVL as AVL +import qualified Data.Tree.AVL.Test.Utils as AVL + +#ifdef __GLASGOW_HASKELL__ +import Data.Generics.Basics -- re-exports Data.Typeable +#else +import Data.Typeable +#endif + +-- | A set of values @a@. +newtype Set a = Set (AVL.AVL a) + +instance Eq a => Eq (Set a) where + t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2) + +instance Ord a => Ord (Set a) where + compare s1 s2 = compare (toAscList s1) (toAscList s2) + +instance Show a => Show (Set a) where + showsPrec _ s = showSet (toAscList s) + +showSet :: (Show a) => [a] -> ShowS +showSet [] + = showString "{}" +showSet (x:xs) + = showChar '{' . shows x . showTail xs + where + showTail [] = showChar '}' + showTail (x':xs') = showChar ',' . shows x' . showTail xs' + +instance Ord a => Monoid (Set a) where + mempty = empty + mappend = union + mconcat = unions + + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Set,theTc,"Data.Set.AVL") + + +#ifdef __GLASGOW_HASKELL__ +-- This instance preserves data abstraction at the cost of inefficiency. +-- We omit reflection services for the sake of data abstraction. +instance (Data a, Ord a) => Data (Set a) where + gfoldl f z set = z fromList `f` (toList set) + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "Data.Set.AVL.Set" +#endif + +-- | /O(1)/. The empty set. +empty :: Set a +empty = Set (AVL.empty) + +-- | /O(1)/. Create a singleton set. +singleton :: a -> Set a +singleton a = Set (AVL.singleton a) + +-- | /O(1)/. Is this the empty set? +null :: Set a -> Bool +null (Set t) = AVL.isEmpty t + +-- | /O(n)/. The number of elements in the set. +size :: Set a -> Int +size (Set t) = AVL.size t + +-- | /O(log n)/. Is the element in the set? +member :: Ord a => a -> Set a -> Bool +member a (Set t) = AVL.genContains t (compare a) + +-- | /O(?)/. Is this a subset? +-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +isSubsetOf :: Ord a => Set a -> Set a -> Bool +isSubsetOf (Set t1) (Set t2) = AVL.genIsSubsetOf compare t1 t2 + +-- | /O(?)/. Is this a proper subset? (ie. a subset but not equal). +isProperSubsetOf :: Ord a => Set a -> Set a -> Bool +isProperSubsetOf (Set t1) (Set t2) = (AVL.size t1 < AVL.size t2) && (AVL.genIsSubsetOf compare t1 t2) + +-- | /O(?)/. The union of two sets, preferring the first set when +-- equal elements are encountered. +union :: Ord a => Set a -> Set a -> Set a +union (Set t1) (Set t2) = Set (AVL.genUnion COrdering.fstCC t1 t2) + +-- | The union of a list of sets: (@'unions' == 'foldl'' 'union' 'empty'@). +unions :: Ord a => [Set a] -> Set a +unions ts = List.foldl' union empty ts + +infixl 9 \\ -- +-- | /O(?)/. See 'difference'. +(\\) :: Ord a => Set a -> Set a -> Set a +m1 \\ m2 = difference m1 m2 + +-- | /O(?)/. Difference of two sets. +difference :: Ord a => Set a -> Set a -> Set a +difference (Set t1) (Set t2) = Set (AVL.genDifference compare t1 t2) + +-- | /O(?)/. The intersection of two sets. +intersection :: Ord a => Set a -> Set a -> Set a +intersection (Set t1) (Set t2) = Set (AVL.genIntersection COrdering.fstCC t1 t2) + +-- | /O(log n)/. Insert an element in a set. +-- If the set already contains an element equal to the given value, +-- it is replaced with the new value. +insert :: Ord a => a -> Set a -> Set a +insert a (Set t) = Set (AVL.genPush (COrdering.fstCC a) a t) + +-- | /O(log n)/. Delete an element from a set. +delete :: Ord a => a -> Set a -> Set a +delete a (Set t) = Set (AVL.genDel (compare a) t) + +-- | /O(n)/. Build a set from an ascending list in linear time. +-- /The precondition (input list is ascending) is not checked./ +fromAscList :: Eq a => [a] -> Set a +fromAscList as + = fromDistinctAscList (combineEq as) + where + -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] + combineEq xs + = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> combineEq' x xx + combineEq' z [] = [z] + combineEq' z (x:xs) + | z==x = combineEq' z xs + | otherwise = z:combineEq' x xs + +-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time. +-- /The precondition (input list is strictly ascending) is not checked./ +fromDistinctAscList :: [a] -> Set a +fromDistinctAscList as = Set (AVL.asTreeL as) + +-- | /O(n*log n)/. Create a set from a list of elements. +fromList :: Ord a => [a] -> Set a +fromList as = Set (AVL.genAsTree COrdering.fstCC as) + +-- | /O(n)/. The elements of a set. +elems :: Set a -> [a] +elems s = toAscList s + +-- | /O(n)/. Convert the set to a list of elements. +toList :: Set a -> [a] +toList s = toAscList s + +-- | /O(n)/. Convert the set to an ascending list of elements. +toAscList :: Set a -> [a] +toAscList (Set t) = AVL.asListL t + +-- | /O(n)/. Filter all elements that satisfy the predicate. +filter :: Ord a => (a -> Bool) -> Set a -> Set a +filter p (Set t) = Set (AVL.filterViaList p t) + +-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy +-- the predicate and one with all elements that don't satisfy the predicate. +-- See also 'split'. +partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a) +partition p (Set t) = (Set trueT, Set falseT) + where (trueT,falseT) = AVL.partitionAVL p t + +-- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where all elements in @set1@ are lower than @x@ and all elements in +-- @set2@ larger than @x@. @x@ is not found in neither @set1@ nor @set2@. +split :: Ord a => a -> Set a -> (Set a,Set a) +split a (Set t) = (Set lessT, Set greaterT) + where (lessT, _, greaterT) = AVL.genFork (COrdering.unitCC a) t + +-- | /O(log n)/. Performs a 'split' but also returns whether the pivot +-- element was found in the original set. +splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a) +splitMember a (Set t) = (Set lessT, Maybe.isJust mbUnit, Set greaterT) + where (lessT, mbUnit, greaterT) = AVL.genFork (COrdering.unitCC a) t + +-- | /O(n*log n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. +-- +-- It's worth noting that the size of the result may be smaller if, +-- for some @(x,y)@, @x \/= y && f x == f y@ +map :: (Ord a, Ord b) => (a->b) -> Set a -> Set b +map f = fromList . List.map f . toList + +-- | /O(n)/. The identity +-- +-- @'mapMonotonic' f s == 'map' f s@, works only when @f@ is monotonic. +-- /The precondition is not checked./ +-- Semi-formally, we have: +-- +-- > and [x < y ==> f x < f y | x <- ls, y <- ls] +-- > ==> mapMonotonic f s == map f s +-- > where ls = toList s +mapMonotonic :: (a->b) -> Set a -> Set b +mapMonotonic f (Set t) = Set (AVL.mapAVL f t) + +-- | /O(n)/. Fold over the elements of a set in an unspecified order. +fold :: (a -> b -> b) -> b -> Set a -> b +fold f b (Set t) = AVL.foldrAVL f b t + +-- | /O(log n)/. The minimal element of a set. +findMin :: Set a -> a +findMin (Set t) = case AVL.tryReadL t of + Just a -> a + Nothing -> error "Set.findMin: empty set has no minimal element" + +-- | /O(log n)/. The maximal element of a set. +findMax :: Set a -> a +findMax (Set t) = case AVL.tryReadR t of + Just a -> a + Nothing -> error "Set.findMax: empty set has no maximal element" + +-- | /O(log n)/. Delete the minimal element. +deleteMin :: Set a -> Set a +deleteMin (Set t) = Set (case AVL.tryDelL t of + Just t' -> t' + Nothing -> t -- empty + ) + +-- | /O(log n)/. Delete the maximal element. +deleteMax :: Set a -> Set a +deleteMax (Set t) = Set (case AVL.tryDelR t of + Just t' -> t' + Nothing -> t -- empty + ) + +-- | /O(log n)/. Delete and find the minimal element. +-- +-- > deleteFindMin set = (findMin set, deleteMin set) +deleteFindMin :: Set a -> (a,Set a) +deleteFindMin (Set t) = + case AVL.tryPopL t of + Just (a,t') -> (a, Set t') + Nothing -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", empty) + +-- | /O(log n)/. Delete and find the maximal element. +-- +-- > deleteFindMax set = (findMax set, deleteMax set) +deleteFindMax :: Set a -> (a,Set a) +deleteFindMax (Set t) = + case AVL.tryPopR t of + Just (t',a) -> (a, Set t') + Nothing -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", empty) + +-- | /O(n)/. Test if the internal set structure is valid. +valid :: Ord a => Set a -> Bool +valid (Set t) = AVL.isSortedOK compare t + +-- | /O(n)/. Convert a Data.Set.Set to an AVL tree based Set (as provided by this module). +fromStdSet :: Data.Set.Set a -> Set a +fromStdSet s = Set (AVL.set2AVL s) + +-- | /O(n)/. Convert an AVL tree based Set (as provided by this module) to a Data.Set.Set. +toStdSet :: Set a -> Data.Set.Set a +toStdSet (Set t) = AVL.avl2Set t + +-- | /O(1)/. Convert a /sorted/ AVL tree to an AVL tree based Set (as provided by this module). +-- This function does not check the input AVL tree is sorted. +{-# INLINE unsafeFromTree #-} +unsafeFromTree :: AVL.AVL a -> Set a +unsafeFromTree t = Set t + +-- | /O(1)/. Convert an AVL tree based Set (as provided by this module) to a sorted AVL tree. +{-# INLINE toTree #-} +toTree :: Set a -> AVL.AVL a +toTree (Set t) = t + +{-------------------------------------------------------------------- + Old Data.Set compatibility interface +--------------------------------------------------------------------} + +{-# DEPRECATED emptySet "Use empty instead" #-} +-- | Obsolete equivalent of 'empty'. +emptySet :: Set a +emptySet = empty + +{-# DEPRECATED mkSet "Use fromList instead" #-} +-- | Obsolete equivalent of 'fromList'. +mkSet :: Ord a => [a] -> Set a +mkSet = fromList + +{-# DEPRECATED setToList "Use elems instead." #-} +-- | Obsolete equivalent of 'elems'. +setToList :: Set a -> [a] +setToList = elems + +{-# DEPRECATED unitSet "Use singleton instead." #-} +-- | Obsolete equivalent of 'singleton'. +unitSet :: a -> Set a +unitSet = singleton + +{-# DEPRECATED elementOf "Use member instead." #-} +-- | Obsolete equivalent of 'member'. +elementOf :: Ord a => a -> Set a -> Bool +elementOf = member + +{-# DEPRECATED isEmptySet "Use null instead." #-} +-- | Obsolete equivalent of 'null'. +isEmptySet :: Set a -> Bool +isEmptySet = null + +{-# DEPRECATED cardinality "Use size instead." #-} +-- | Obsolete equivalent of 'size'. +cardinality :: Set a -> Int +cardinality = size + +{-# DEPRECATED unionManySets "Use unions instead." #-} +-- | Obsolete equivalent of 'unions'. +unionManySets :: Ord a => [Set a] -> Set a +unionManySets = unions + +{-# DEPRECATED minusSet "Use difference instead." #-} +-- | Obsolete equivalent of 'difference'. +minusSet :: Ord a => Set a -> Set a -> Set a +minusSet = difference + +{-# DEPRECATED mapSet "Use map instead." #-} +-- | Obsolete equivalent of 'map'. +mapSet :: (Ord a, Ord b) => (b -> a) -> Set b -> Set a +mapSet = map + +{-# DEPRECATED intersect "Use intersection instead." #-} +-- | Obsolete equivalent of 'intersection'. +intersect :: Ord a => Set a -> Set a -> Set a +intersect = intersection + +{-# DEPRECATED addToSet "Use 'flip insert' instead." #-} +-- | Obsolete equivalent of @'flip' 'insert'@. +addToSet :: Ord a => Set a -> a -> Set a +addToSet = flip insert + +{-# DEPRECATED delFromSet "Use `flip delete' instead." #-} +-- | Obsolete equivalent of @'flip' 'delete'@. +delFromSet :: Ord a => Set a -> a -> Set a +delFromSet = flip delete diff --git a/Data/Set/Enum.hs b/Data/Set/Enum.hs new file mode 100644 --- /dev/null +++ b/Data/Set/Enum.hs @@ -0,0 +1,415 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Set.Enum +-- Copyright : (c) David F. Place 2006 +-- Derived from Data.Set by Daan Leijen +-- License : BSD +-- Maintainer : David F. Place +-- Stability : Experimental +-- Portability : ? +-- +-- An efficient implementation of sets over small enumerations. +-- +-- This module is intended to be imported @qualified@, to avoid name +-- clashes with "Prelude" functions. eg. +-- +-- > import Data.Set.Enum as Set +-- +-- The implementation of 'EnumSet' is based on bit-wise operations. +----------------------------------------------------------------------------- + +module Data.Set.Enum + ( + -- * Set type + Set + -- * Operators + , (\\) + + -- * Query + , null + , size + , member + , isSubsetOf + , isProperSubsetOf + + -- * Construction + , empty + , singleton + , insert + , delete + + -- * Combine + , union, unions + , difference + , intersection + , complement + , complementWith + + -- * Filter + , filter + , partition + , split + , splitMember + + -- * Map + , map + , mapMonotonic + + -- * Fold + , fold + , foldr + + -- * Min\/Max + , findMin + , findMax + , deleteMin + , deleteMax + , deleteFindMin + , deleteFindMax + + -- * Conversion + + -- ** List + , elems + , toList + , fromList + + -- ** Ordered list + , toAscList + , fromAscList + , fromDistinctAscList +) where +import Prelude hiding (filter,foldr,null,map) +import Data.Bits hiding (complement) +import qualified Data.Bits as Bits +import Data.Word +import Data.List (foldl',intersperse,sort) +import Data.Monoid (Monoid(..)) +import Data.Typeable + +{-------------------------------------------------------------------- + Operators +--------------------------------------------------------------------} +infixl 9 \\ -- + +(\\) :: Set a -> Set a -> Set a +m1 \\ m2 = difference m1 m2 + +{-------------------------------------------------------------------- + Sets are bit strings of width @wordLength@. +--------------------------------------------------------------------} +-- | A set of values @a@ implemented as bitwise operations. Useful +-- for members of class Enum with no more elements than there are bits +-- in @Word@. +newtype Set a = Set Word deriving (Eq) + +#include "Typeable.h" +INSTANCE_TYPEABLE1(Set,theTc,"Data.Set.Enum") + +wordLength :: Int +wordLength = bitSize (undefined::Word) + +check :: String -> Int -> Int +check msg x + | x < wordLength = x + | otherwise = error $ "EnumSet."++msg++"` beyond word size." + + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is this the empty set? +null :: Set a -> Bool +null (Set 0) = True +null _ = False + +-- | /O(1)/. The number of elements in the set. +size :: Enum a => Set a -> Int +size (Set w) = bitcount 0 w + + +-- | /O(1)/. Is the element in the set? +member :: Enum a => a -> Set a -> Bool +member x (Set w) = testBit w $ fromEnum x + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: Set a +empty = Set 0 + +-- | /O(1)/. Create a singleton set. +singleton :: Enum a => a -> Set a +singleton x = + Set $ setBit 0 $ check "singleton" $ fromEnum x + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(1)/. Insert an element in a set. +-- If the set already contains an element equal to the given value, +-- it is replaced with the new value. +insert :: Enum a => a -> Set a -> Set a +insert x (Set w) = + Set $ setBit w $ check "insert" $ fromEnum x + +-- | /O(1)/. Delete an element from a set. +delete :: Enum a => a -> Set a -> Set a +delete x (Set w) = + Set $ clearBit w $ fromEnum x + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(1)/. Is this a proper subset? (ie. a subset but not equal). +isProperSubsetOf :: Set a -> Set a -> Bool +isProperSubsetOf x y = (x /= y) && (isSubsetOf x y) + +-- | /O(1)/. Is this a subset? +-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@. +isSubsetOf :: Set a -> Set a -> Bool +isSubsetOf x y = (x `union` y) == y + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} +-- | The minimal element of a set. +findMin :: Enum a => Set a -> a +findMin (Set w) = toEnum $ findMinIndex w + +findMinIndex :: Word -> Int +findMinIndex 0 = + error "EnumSet.findMin: empty set has no minimal element" +findMinIndex w = ls1b w + +-- | The maximal element of a set. +findMax :: Enum a => Set a -> a +findMax (Set w) = toEnum $ findMaxIndex w + +findMaxIndex :: Word -> Int +findMaxIndex 0 = + error "EnumSet.findMax: empty set has no maximal element" +findMaxIndex w = ms1b w + +-- | Delete the minimal element. +deleteMin :: Set a -> Set a +deleteMin (Set 0) = empty +deleteMin (Set w) = Set $ clearBit w $ findMinIndex w + +-- | Delete the maximal element. +deleteMax :: Set a -> Set a +deleteMax (Set 0) = empty +deleteMax (Set w) = Set $ clearBit w $ findMaxIndex w + +deleteFindMin :: Enum a => Set a -> (a,Set a) +deleteFindMin s@(Set 0) = + (error + "EnumSet.deleteFindMin: can not return the minimal element of an empty set", + s) +deleteFindMin s = (min,delete min s) + where min = findMin s + +deleteFindMax :: Enum a => Set a -> (a,Set a) +deleteFindMax s@(Set 0) = + (error + "EnumSet.deleteFindMax: can not return the maximal element of an empty set", + s) +deleteFindMax s = (max,delete max s) + where max = findMax s + +{-------------------------------------------------------------------- + Union. +--------------------------------------------------------------------} +-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). +unions :: [Set a] -> Set a +unions = foldl' union empty + +-- | /O(1)/. The union of two sets. +union :: Set a -> Set a -> Set a +union (Set x) (Set y) = Set $ x .|. y + + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(1)/. Difference of two sets. +difference :: Set a -> Set a -> Set a +difference (Set x) (Set y) = Set $ (x .|. y) `xor` y + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(1)/. The intersection of two sets. +intersection :: Set a -> Set a -> Set a +intersection (Set x) (Set y) = Set $ x .&. y + +{-------------------------------------------------------------------- + Complement +--------------------------------------------------------------------} + +-- | /O(1)/. The complement of a set with its universe set. +-- @complement@ can be used with bounded types for which the universe set +-- will be automatically created. +complement :: (Bounded a, Enum a) => Set a -> Set a +complement x = complementWith u x + where u = (fromList [minBound .. maxBound]) `asTypeOf` x + +complementWith :: Set a -> Set a -> Set a +complementWith (Set u) (Set x) = Set $ u `xor` x + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy the predicate. +filter :: Enum a => (a -> Bool) -> Set a -> Set a +filter p (Set w) = Set $ foldBits f 0 w + where + f z i + | p $ toEnum i = setBit z i + | otherwise = z + +-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy +-- the predicate and one with all elements that don't satisfy the predicate. +-- See also 'split'. +partition :: Enum a => (a -> Bool) -> Set a -> (Set a,Set a) +partition p (Set w) = (Set yay,Set nay) + where + (yay,nay) = foldBits f (0,0) w + f (x,y) i + | p $ toEnum i = (setBit x i,y) + | otherwise = (x,setBit y i) + +{---------------------------------------------------------------------- + Map +----------------------------------------------------------------------} +-- | /O(n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. +-- +-- It's worth noting that the size of the result may be smaller if, +-- for some @(x,y)@, @x \/= y && f x == f y@ +map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b +map f (Set w) = Set $ foldBits fold 0 w + where + fold z i = setBit z $ check "map" $ fromEnum $ f (toEnum i) + +-- | @'mapMonotonic'@ is provided for compatibility with the +-- Data.Set interface. +mapMonotonic :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b +mapMonotonic = map + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} +-- | /O(n)/. Fold over the elements of a set in an unspecified order. +fold :: Enum a => (b -> a -> b) -> b -> Set a -> b +fold f z (Set w) = foldBits folder z w + where + folder z i = f z $ toEnum i + +foldr :: (Enum a) => (a -> c -> c) -> c -> Set a -> c +foldr f = fold (flip f) + +{-------------------------------------------------------------------- + List variations +--------------------------------------------------------------------} +-- | /O(n)/. The elements of a set. +elems :: Enum a => Set a -> [a] +elems = toList + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +-- | /O(n)/. Convert the set to a list of elements. +toList :: Enum a => Set a -> [a] +toList (Set w) = reverse $ foldBits f [] w + where + f z i = (toEnum i) : z + +-- | /O(n)/. Convert the set to an ascending list of elements. +toAscList :: (Ord a,Enum a) => Set a -> [a] +toAscList = sort . toList + +-- | /O(n)/. Create a set from a list of elements. +fromList :: Enum a => [a] -> Set a +fromList xs = Set $ foldl' f 0 xs + where + f z x = setBit z $ check "fromList" $ fromEnum x +-- | @fromAscList@ and @fromDistinctAscList@ maintained for compatibility +-- with Data.Set, but here give no advantage. +fromAscList :: Enum a => [a] -> Set a +fromAscList = fromList + +fromDistinctAscList :: Enum a => [a] -> Set a +fromDistinctAscList = fromList + +{-------------------------------------------------------------------- + Show +--------------------------------------------------------------------} +instance (Enum a, Show a) => Show (Set a) where + show xs = + "{"++(concat $ intersperse "," [show x | x <- toList xs])++"}" + +{-------------------------------------------------------------------- + Split +--------------------------------------------------------------------} +split :: (Ord a, Enum a) => a -> Set a -> (Set a,Set a) +split x s = (lesser,greater) + where (lesser,_,greater) = splitMember x s + +splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a) +splitMember x (Set w) = (Set lesser,isMember,Set greater) + where + (lesser,isMember,greater) = foldBits f (0,False,0) w + f (lesser,isMember,greater) i = + case compare (toEnum i) x of + GT -> (lesser,isMember,setBit greater i) + LT -> (setBit lesser i,isMember,greater) + EQ -> (lesser,True,greater) + +{-------------------------------------------------------------------- + Utility functions. +--------------------------------------------------------------------} + +foldBits :: (a -> Int -> a) -> a -> Word -> a +foldBits _ z 0 = z +foldBits f z bs = foldBits' f 0 bs z + +foldBits' :: (a -> Int -> a) -> Int -> Word -> a -> a +foldBits' f i bs z + | bs == 0 = z + | otherwise = z' `seq` foldBits' f i' bs' z' + where z' | 1 == bs .&. 1 = f z i + | otherwise = z + i' = i + 1 + bs' = bs `shiftR` 1 + +bitcount :: Int -> Word -> Int +bitcount a 0 = a +bitcount a x = bitcount (a + 1) (x .&. (x-1)) + +ls1b :: Word -> Int +ls1b x = bitcount 0 $ ((x-1) .&. (Bits.complement x)) + +ms1b :: Word -> Int +ms1b x = ms1b' 1 x + where + ms1b' l x + | l == (bitSize x) = bitcount 0 (x - 1) + | otherwise = ms1b' (l*2) (x .|. x `shiftR` l) + +{-------------------------------------------------------------------- + Ord +--------------------------------------------------------------------} +instance (Enum a,Ord a) => Ord (Set a) where + compare a b = compare (toAscList a) (toAscList b) + +{-------------------------------------------------------------------- + Monoid +--------------------------------------------------------------------} +instance Enum a => Monoid (Set a) where + mempty = empty + mappend = union + mconcat = unions + + diff --git a/Data/Set/List.hs b/Data/Set/List.hs new file mode 100644 --- /dev/null +++ b/Data/Set/List.hs @@ -0,0 +1,72 @@ +{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} + +module Data.Set.List (SetList(..)) where + + +import Data.Monoid +import qualified Data.List as List +import Prelude hiding (sum,concat,lookup,map,filter,foldr,foldr1,foldl,null,reverse,(++),minimum,maximum,all,elem,concatMap) +import Data.Collections +import Data.Typeable + +-- | View a list of as a 'Set' collection. +-- +-- This allows to feed sequences into algorithms that require a Set without building a full-fledged Set. +-- Most of the time this will be used only when the parameter list is known to be very small, such that +-- conversion to a Set would be to costly. + +--FIXME: Generalize to sequences. +newtype SetList s = SetList {fromSetList :: s} + +instance (Eq s, Eq a, Foldable s a) => Eq (SetList s) where + (SetList l1) == (SetList l2) = l1 == l2 || + (size l1 == size l2 && all (`elem` l1) l2) + + +#include "Typeable.h" +INSTANCE_TYPEABLE1(SetList,theTc,"Data.Set.List.SetList") + +instance Show l => Show (SetList l) where + show (SetList l) = "SetList " >< show l + +instance Foldable (SetList [a]) a where + foldr f z (SetList l) = foldr f z l + null (SetList l) = null l + +instance Eq a => Set (SetList [a]) a where + haddock_candy = haddock_candy + +instance Eq a => Monoid (SetList [a]) where + mempty = empty + mappend = union + +instance Eq a => Unfoldable (SetList [a]) a where + empty = SetList empty + insert x (SetList l) = SetList $ if x `elem` l then l else insert x l + +instance Eq a => Collection (SetList [a]) a where + filter f (SetList l) = SetList $ filter f l + +instance Eq a => Map (SetList [a]) a () where + isSubmapBy f x y = isSubset x y && (f () () || null (intersection x y)) + insertWith _f k () = insert k + unionWith _f = union + intersectionWith _f = intersection + mapWithKey _f = id + differenceWith f s1 s2 = if f () () == Nothing then difference s1 s2 else s1 + lookup k l = if member k l then return () else fail "element not found" + + (SetList l1) `isSubset` (SetList l2) = all (`elem` l2) l1 + difference (SetList l1) (SetList l2) = SetList $ (List.\\) l1 l2 + delete k (SetList l) = SetList $ filter (not . (k ==)) l + member k (SetList l) = List.elem k l + union (SetList l1) (SetList l2) = SetList $ List.union l1 l2 + intersection (SetList l1) (SetList l2) = SetList $ List.intersect l1 l2 + alter f k l = let lk = lookup k l in + case lk of + Nothing -> case f lk of + Nothing -> l + Just _ -> insert k l + Just _ -> case f lk of + Nothing -> delete k l + Just _ -> l diff --git a/Data/Tree/AVL.hs b/Data/Tree/AVL.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Many of the functions defined by this package make use of generalised comparison functions +-- which return a variant of the Prelude 'Prelude.Ordering' data type: 'Data.COrdering.COrdering'. These +-- are refered to as \"combining comparisons\". (This is because they combine \"equal\" +-- values in some manner defined by the user.) +-- +-- The idea is that using this simple mechanism you can define many practical and +-- useful variations of tree (or general set) operations from a few generic primitives, +-- something that would not be so easy using plain 'Prelude.Ordering' comparisons +-- (overloaded or otherwise). +-- +-- Functions which involve searching a tree really only require a single argument +-- function which takes the current tree element value as argument and returns +-- an 'Prelude.Ordering' or 'Data.COrdering.COrdering' to direct the next stage of the search down +-- the left or right sub-trees (or stop at the current element). For documentation +-- purposes, these functions are called \"selectors\" throughout this library. +-- Typically a selector will be obtained by partially applying the appropriate +-- combining comparison with the value or key being searched for. For example.. +-- +-- @ +-- mySelector :: Int -> Ordering Tree elements are Ints +-- or.. +-- mySelector :: (key,val) -> COrdering val Tree elements are (key,val) pairs +-- @ +-- +-- Please read the notes in the "Data.Tree.AVL.Types" module documentation too. +----------------------------------------------------------------------------- +module Data.Tree.AVL + (-- * Conversion utilities. + set2AVL,avl2Set, + map2AVL,avl2Map, + + -- * Modules. + module Data.Tree.AVL.Types, + module Data.Tree.AVL.Size, + module Data.Tree.AVL.Read, + module Data.Tree.AVL.Write, + module Data.Tree.AVL.Push, + module Data.Tree.AVL.Delete, + module Data.Tree.AVL.List, + module Data.Tree.AVL.Join, + module Data.Tree.AVL.Split, + module Data.Tree.AVL.Set, + module Data.Tree.AVL.Zipper, + ) where + +import Prelude -- so haddock finds the symbols there + +import qualified Data.Set as BaseSet +import qualified Data.Map as BaseMap + +import Data.Tree.AVL.Types hiding (E,N,P,Z) +import Data.Tree.AVL.Size +import Data.Tree.AVL.Read +import Data.Tree.AVL.Write +import Data.Tree.AVL.Push +import Data.Tree.AVL.Delete +import Data.Tree.AVL.List +import Data.Tree.AVL.Join +import Data.Tree.AVL.Split +import Data.Tree.AVL.Set +import Data.Tree.AVL.Zipper +#if __GLASGOW_HASKELL__ > 604 +import Data.Traversable +#endif +-- | Convert a 'Data.Set.Set' (from the base package Data.Set module) to a sorted AVL tree. +-- Elements and element ordering are preserved (ascending order is left to right). +-- +-- Complexity: O(n) +set2AVL :: BaseSet.Set a -> AVL a +set2AVL set = asTreeLenL (BaseSet.size set) (BaseSet.toAscList set) + +-- | Convert a /sorted/ AVL tree to a 'Data.Set.Set' (from the base package Data.Set module). +-- Elements and element ordering are preserved. +-- +-- Complexity: O(n) +avl2Set :: AVL a -> BaseSet.Set a +avl2Set avl = BaseSet.fromDistinctAscList (asListL avl) + +-- | Convert a 'Data.Map.Map' (from the base package Data.Map module) to a sorted (by key) AVL tree. +-- Elements and element ordering are preserved (ascending order is left to right). +-- +-- Complexity: O(n) +map2AVL :: BaseMap.Map key val -> AVL (key,val) +map2AVL mp = asTreeLenL (BaseMap.size mp) (BaseMap.toAscList mp) + +-- | Convert a /sorted/ (by key) AVL tree to a 'Data.Map.Map' (from the base package Data.Map module). +-- Elements and element ordering are preserved. +-- +-- Complexity: O(n) +avl2Map :: AVL (key,val) -> BaseMap.Map key val +avl2Map avl = BaseMap.fromDistinctAscList (asListL avl) + +-- | Eq is based on equality of the lists produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Eq e => Eq (AVL e) where + x == y = (size x == size y) && (asListL x == asListL y) -- Compare sizes first as this will usually resolve it + +-- | Ordering is based on ordering of the lists produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Ord e => Ord (AVL e) where + x `compare` y = asListL x `compare` asListL y + +-- | Show is based on showing the list produced by 'asListL'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Show e => Show (AVL e) where + -- showsPrec :: Int -> AVL e -> Shows -- type Shows = String -> String + showsPrec _ t = ("AVL " ++) . showList (asListL t) + +instance Read e => Read (AVL e) where + -- readsPrec :: Int -> ReadS a -- type ReadS a = String -> [(a,String)] + readsPrec _ str = case lex str of + [("AVL",str')] -> [(asTreeL es, str'') | (es,str'') <- readList str'] + _ -> [] +-- | AVL trees are an instance of 'Functor'. This definition has been placed here +-- to avoid introducing cyclic dependency between Types.hs and List.hs +instance Functor AVL where + fmap = mapAVL -- The lazy version. + +instance Traversable AVL where + traverse = traverseAVL + diff --git a/Data/Tree/AVL/Delete.hs b/Data/Tree/AVL/Delete.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Delete.hs @@ -0,0 +1,518 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Delete +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines functions for deleting elements from AVL trees and related +-- utilities. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Delete + (-- * Deleting. + + -- ** Deleting from extreme left or right. + assertDelL,assertDelR,tryDelL,tryDelR, + + -- ** Deleting from /sorted/ trees. + genDel,genDelFast,genDelIf,genDelMaybe, + + -- * Popping. + -- | \"Popping\" means reading and deleting a tree element in a single operation. + + -- ** Popping from extreme left or right. + assertPopL,assertPopR,tryPopL,tryPopR, + + -- ** Popping from /sorted/ trees. + genAssertPop,genTryPop,genAssertPopMaybe,genTryPopMaybe,genAssertPopIf,genTryPopIf, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genFindPath,genOpenPathWith,writePath) + +import Data.Tree.AVL.Internals.DelUtils + (-- Deleting Utilities + delRN,delRZ,delRP,delLN,delLZ,delLP, + -- Popping Utilities. + popRN,popRZ,popRP,popLN,popLZ,popLP, + -- Balancing Utilities + chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP, + chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP', + -- Node substitution utilities. + subN,subZR,subZL,subP, + -- BinPath related + deletePath + ) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- least element. This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertDelL :: AVL e -> AVL e +assertDelL E = error "assertDelL: Empty tree." +assertDelL (N l e r) = delLN l e r +assertDelL (Z l e r) = delLZ l e r +assertDelL (P l e r) = delLP l e r + +-- | Try to delete the left-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- least element. This function returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryDelL :: AVL e -> Maybe (AVL e) +tryDelL E = Nothing +tryDelL (N l e r) = Just $! delLN l e r +tryDelL (Z l e r) = Just $! delLZ l e r +tryDelL (P l e r) = Just $! delLP l e r + +-- | Delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- greatest element. This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertDelR :: AVL e -> AVL e +assertDelR E = error "assertDelR: Empty tree." +assertDelR (N l e r) = delRN l e r +assertDelR (Z l e r) = delRZ l e r +assertDelR (P l e r) = delRP l e r + +-- | Try to delete the right-most element of a /non-empty/ AVL tree. If the tree is sorted this will be the +-- greatest element. This function returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryDelR :: AVL e -> Maybe (AVL e) +tryDelR E = Nothing +tryDelR (N l e r) = Just $! delRN l e r +tryDelR (Z l e r) = Just $! delRZ l e r +tryDelR (P l e r) = Just $! delRP l e r + +-- | Pop the left-most element from a non-empty AVL tree, returning the popped element and the +-- modified AVL tree. If the tree is sorted this will be the least element. +-- This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertPopL :: AVL e -> (e,AVL e) +assertPopL E = error "assertPopL: Empty tree." +assertPopL (N l e r) = case popLN l e r of UBT2(v,t) -> (v,t) +assertPopL (Z l e r) = case popLZ l e r of UBT2(v,t) -> (v,t) +assertPopL (P l e r) = case popLP l e r of UBT2(v,t) -> (v,t) + +-- | Same as 'assertPopL', except this version returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryPopL :: AVL e -> Maybe (e,AVL e) +tryPopL E = Nothing +tryPopL (N l e r) = Just $! case popLN l e r of UBT2(v,t) -> (v,t) +tryPopL (Z l e r) = Just $! case popLZ l e r of UBT2(v,t) -> (v,t) +tryPopL (P l e r) = Just $! case popLP l e r of UBT2(v,t) -> (v,t) + + +-- | Pop the right-most element from a non-empty AVL tree, returning the popped element and the +-- modified AVL tree. If the tree is sorted this will be the greatest element. +-- This function raises an error if it's argument is an empty tree. +-- +-- Complexity: O(log n) +assertPopR :: AVL e -> (AVL e,e) +assertPopR E = error "assertPopR: Empty tree." +assertPopR (N l e r) = case popRN l e r of UBT2(t,v) -> (t,v) +assertPopR (Z l e r) = case popRZ l e r of UBT2(t,v) -> (t,v) +assertPopR (P l e r) = case popRP l e r of UBT2(t,v) -> (t,v) + +-- | Same as 'assertPopR', except this version returns 'Nothing' if it's argument is an empty tree. +-- +-- Complexity: O(log n) +tryPopR :: AVL e -> Maybe (AVL e,e) +tryPopR E = Nothing +tryPopR (N l e r) = Just $! case popRN l e r of UBT2(t,v) -> (t,v) +tryPopR (Z l e r) = Just $! case popRZ l e r of UBT2(t,v) -> (t,v) +tryPopR (P l e r) = Just $! case popRP l e r of UBT2(t,v) -> (t,v) + +-- | General purpose function for deletion of elements from a sorted AVL tree. +-- If a matching element is not found then this function returns the original tree. +-- +-- Complexity: O(log n) +genDel :: (e -> Ordering) -> AVL e -> AVL e +genDel c t = let p = genFindPath c t + in case COMPAREUINT p L(0) of + LT -> t -- Not found, p<0 + _ -> deletePath p t -- Found, so delete + +-- | This version only deletes the element if the supplied selector returns @('Eq' 'True')@. +-- If it returns @('Eq' 'False')@ or if no matching element is found then this function returns +-- the original tree. +-- +-- Complexity: O(log n) +genDelIf :: (e -> COrdering Bool) -> AVL e -> AVL e +genDelIf c t = case genOpenPathWith c t of + FullBP p True -> deletePath p t + _ -> t + +-- | This version only deletes the element if the supplied selector returns @('Eq' 'Nothing')@. +-- If it returns @('Eq' ('Just' e))@ then the matching element is replaced by e. +-- If no matching element is found then this function returns the original tree. +-- +-- Complexity: O(log n) +genDelMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genDelMaybe c t = case genOpenPathWith c t of + FullBP p Nothing -> deletePath p t + FullBP p (Just e) -> writePath p e t + _ -> t + +-- | Functionally identical to 'genDel', but returns an identical tree (one with all the nodes on +-- the path duplicated) if the search fails. This should probably only be used if you know the +-- search will succeed. +-- +-- Complexity: O(log n) +genDelFast :: (e -> Ordering) -> AVL e -> AVL e +-- This was the old genDel so it's been tested OK, but as a different name. +genDelFast c = genDel' where + genDel' E = E + genDel' (N l e r) = delN l e r + genDel' (Z l e r) = delZ l e r + genDel' (P l e r) = delP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- delN, delZ, delP -- + ----------------------------------------------------------------------- + + -- Delete from (N l e r) + delN l e r = case c e of + LT -> delNL l e r + EQ -> subN l r + GT -> delNR l e r + + -- Delete from (Z l e r) + delZ l e r = case c e of + LT -> delZL l e r + EQ -> subZR l r + GT -> delZR l e r + + -- Delete from (P l e r) + delP l e r = case c e of + LT -> delPL l e r + EQ -> subP l r + GT -> delPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- delNL, delZL, delPL -- + -- delNR, delZR, delPR -- + ----------------------------------------------------------------------- + + -- Delete from the left subtree of (N l e r) + delNL E e r = N E e r -- Left sub-tree is empty + delNL (N ll le lr) e r = case c le of + LT -> chkLN (delNL ll le lr) e r + EQ -> chkLN (subN ll lr) e r + GT -> chkLN (delNR ll le lr) e r + delNL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` N l' e r -- height can't change + EQ -> chkLN' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` N l' e r -- height can't change + delNL (P ll le lr) e r = case c le of + LT -> chkLN (delPL ll le lr) e r + EQ -> chkLN (subP ll lr) e r + GT -> chkLN (delPR ll le lr) e r + + -- Delete from the right subtree of (N l e r) + delNR _ _ E = error "delNR: Bug0" -- Impossible + delNR l e (N rl re rr) = case c re of + LT -> chkRN l e (delNL rl re rr) + EQ -> chkRN l e (subN rl rr) + GT -> chkRN l e (delNR rl re rr) + delNR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` N l e r' -- height can't change + EQ -> chkRN' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` N l e r' -- height can't change + delNR l e (P rl re rr) = case c re of + LT -> chkRN l e (delPL rl re rr) + EQ -> chkRN l e (subP rl rr) + GT -> chkRN l e (delPR rl re rr) + + -- Delete from the left subtree of (Z l e r) + delZL E e r = Z E e r -- Left sub-tree is empty + delZL (N ll le lr) e r = case c le of + LT -> chkLZ (delNL ll le lr) e r + EQ -> chkLZ (subN ll lr) e r + GT -> chkLZ (delNR ll le lr) e r + delZL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` Z l' e r -- height can't change + EQ -> chkLZ' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` Z l' e r -- height can't change + delZL (P ll le lr) e r = case c le of + LT -> chkLZ (delPL ll le lr) e r + EQ -> chkLZ (subP ll lr) e r + GT -> chkLZ (delPR ll le lr) e r + + -- Delete from the right subtree of (Z l e r) + delZR l e E = Z l e E -- Right sub-tree is empty + delZR l e (N rl re rr) = case c re of + LT -> chkRZ l e (delNL rl re rr) + EQ -> chkRZ l e (subN rl rr) + GT -> chkRZ l e (delNR rl re rr) + delZR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` Z l e r' -- height can't change + EQ -> chkRZ' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` Z l e r' -- height can't change + delZR l e (P rl re rr) = case c re of + LT -> chkRZ l e (delPL rl re rr) + EQ -> chkRZ l e (subP rl rr) + GT -> chkRZ l e (delPR rl re rr) + + -- Delete from the left subtree of (P l e r) + delPL E _ _ = error "delPL: Bug0" -- Impossible + delPL (N ll le lr) e r = case c le of + LT -> chkLP (delNL ll le lr) e r + EQ -> chkLP (subN ll lr) e r + GT -> chkLP (delNR ll le lr) e r + delPL (Z ll le lr) e r = case c le of + LT -> let l' = delZL ll le lr in l' `seq` P l' e r -- height can't change + EQ -> chkLP' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR ll le lr in l' `seq` P l' e r -- height can't change + delPL (P ll le lr) e r = case c le of + LT -> chkLP (delPL ll le lr) e r + EQ -> chkLP (subP ll lr) e r + GT -> chkLP (delPR ll le lr) e r + + -- Delete from the right subtree of (P l e r) + delPR l e E = P l e E -- Right sub-tree is empty + delPR l e (N rl re rr) = case c re of + LT -> chkRP l e (delNL rl re rr) + EQ -> chkRP l e (subN rl rr) + GT -> chkRP l e (delNR rl re rr) + delPR l e (Z rl re rr) = case c re of + LT -> let r' = delZL rl re rr in r' `seq` P l e r' -- height can't change + EQ -> chkRP' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR rl re rr in r' `seq` P l e r' -- height can't change + delPR l e (P rl re rr) = case c re of + LT -> chkRP l e (delPL rl re rr) + EQ -> chkRP l e (subP rl rr) + GT -> chkRP l e (delPR rl re rr) +----------------------------------------------------------------------- +------------------------- genDelFast Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | General purpose function for popping elements from a sorted AVL tree. +-- An error is raised if a matching element is not found. The pair returned +-- by this function consists of the popped value and the modified tree. +-- +-- Complexity: O(log n) +genAssertPop :: (e -> COrdering a) -> AVL e -> (a,AVL e) +genAssertPop c = genPop_ where + genPop_ E = error "genAssertPop: element not found." + genPop_ (N l e r) = case popN l e r of UBT2(v,t) -> (v,t) + genPop_ (Z l e r) = case popZ l e r of UBT2(v,t) -> (v,t) + genPop_ (P l e r) = case popP l e r of UBT2(v,t) -> (v,t) + + ----------------------------- LEVEL 1 --------------------------------- + -- popN, popZ, popP -- + ----------------------------------------------------------------------- + + -- Pop from (N l e r) + popN l e r = case c e of + Lt -> popNL l e r + Eq a -> let t = subN l r in t `seq` UBT2(a,t) + Gt -> popNR l e r + + -- Pop from (Z l e r) + popZ l e r = case c e of + Lt -> popZL l e r + Eq a -> let t = subZR l r in t `seq` UBT2(a,t) + Gt -> popZR l e r + + -- Pop from (P l e r) + popP l e r = case c e of + Lt -> popPL l e r + Eq a -> let t = subP l r in t `seq` UBT2(a,t) + Gt -> popPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- popNL, popZL, popPL -- + -- popNR, popZR, popPR -- + ----------------------------------------------------------------------- + + -- Pop from the left subtree of (N l e r) +-- popNL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty + popNL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLN (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + popNL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r) + Eq a -> let t = chkLN' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, N l_ e r) + popNL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLN (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLN l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (N l e r) +-- popNR _ _ E = error "genPop.popNR: Bug!" -- Impossible + popNR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRN l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + popNR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_) + Eq a -> let t = chkRN' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, N l e r_) + popNR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRN l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRN l e r_ in t `seq` UBT2(a,t) + + -- Pop from the left subtree of (Z l e r) +-- popZL E _ _ = error "genAssertPop: element not found." -- Left sub-tree is empty + popZL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLZ (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + popZL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r) + Eq a -> let t = chkLZ' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, Z l_ e r) + popZL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLZ (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLZ l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (Z l e r) +-- popZR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty + popZR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRZ l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + popZR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_) + Eq a -> let t = chkRZ' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, Z l e r_) + popZR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRZ l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRZ l e r_ in t `seq` UBT2(a,t) + + -- Pop from the left subtree of (P l e r) +-- popPL E _ _ = error "genPop.popPL: Bug!" -- Impossible + popPL (N ll le lr) e r = case c le of + Lt -> case popNL ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLP (subN ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popNR ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + popPL (Z ll le lr) e r = case c le of + Lt -> case popZL ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r) + Eq a -> let t = chkLP' (subZR ll lr) e r + in t `seq` UBT2(a,t) + Gt -> case popZR ll le lr of UBT2(a,l_) -> UBT2(a, P l_ e r) + popPL (P ll le lr) e r = case c le of + Lt -> case popPL ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + Eq a -> let t = chkLP (subP ll lr) e r in t `seq` UBT2(a,t) + Gt -> case popPR ll le lr of + UBT2(a,l_) -> let t = chkLP l_ e r in t `seq` UBT2(a,t) + + -- Pop from the right subtree of (P l e r) +-- popPR _ _ E = error "genAssertPop: element not found." -- Right sub-tree is empty + popPR l e (N rl re rr) = case c re of + Lt -> case popNL rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRP l e (subN rl rr) in t `seq` UBT2(a,t) + Gt -> case popNR rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + popPR l e (Z rl re rr) = case c re of + Lt -> case popZL rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_) + Eq a -> let t = chkRP' l e (subZL rl rr) + in t `seq` UBT2(a,t) + Gt -> case popZR rl re rr of UBT2(a,r_) -> UBT2(a, P l e r_) + popPR l e (P rl re rr) = case c re of + Lt -> case popPL rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) + Eq a -> let t = chkRP l e (subP rl rr) in t `seq` UBT2(a,t) + Gt -> case popPR rl re rr of + UBT2(a,r_) -> let t = chkRP l e r_ in t `seq` UBT2(a,t) +----------------------------------------------------------------------- +------------------------ genAssertPop Ends Here ----------------------- +----------------------------------------------------------------------- + +-- | Similar to 'genPop', but this function returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPop :: (e -> COrdering a) -> AVL e -> Maybe (a,AVL e) +genTryPop c t = case genOpenPathWith c t of + FullBP pth a -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + +-- | In this case the selector returns two values if a search succeeds. +-- If the second is @('Just' e)@ then the new value (@e@) is substituted in the same place in the tree. +-- If the second is 'Nothing' then the corresponding tree element is deleted. +-- This function raises an error if the search fails. +-- +-- Complexity: O(log n) +genAssertPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> (a,AVL e) +genAssertPopMaybe c t = case genOpenPathWith c t of + FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` (a,t') + FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` (a,t') + _ -> error "genAssertPopMaybe: element not found." + +-- | Similar to 'genAssertPopMaybe', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPopMaybe :: (e -> COrdering (a,Maybe e)) -> AVL e -> Maybe (a,AVL e) +genTryPopMaybe c t = case genOpenPathWith c t of + FullBP pth (a,Just e ) -> let t' = writePath pth e t in t' `seq` Just (a,t') + FullBP pth (a,Nothing) -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + + +-- | A simpler version of 'genAssertPopMaybe'. The corresponding element is deleted if the second value +-- returned by the selector is 'True'. If it\'s 'False', the original tree is returned. +-- This function raises an error if the search fails. +-- +-- Complexity: O(log n) +genAssertPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> (a,AVL e) +genAssertPopIf c t = case genOpenPathWith c t of + FullBP _ (a,False) -> (a,t) + FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` (a,t') + _ -> error "genAssertPopIf: element not found." + +-- | Similar to 'genPopIf', but returns 'Nothing' if the search fails. +-- +-- Complexity: O(log n) +genTryPopIf :: (e -> COrdering (a,Bool)) -> AVL e -> Maybe (a,AVL e) +genTryPopIf c t = case genOpenPathWith c t of + FullBP _ (a,False) -> Just (a,t) + FullBP pth (a,True ) -> let t' = deletePath pth t in t' `seq` Just (a,t') + _ -> Nothing + diff --git a/Data/Tree/AVL/Internals/BinPath.hs b/Data/Tree/AVL/Internals/BinPath.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/BinPath.hs @@ -0,0 +1,377 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.BinPath +-- Copyright : (c) Adrian Hey 2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module provides a cheap but extremely limited and dangerous alternative +-- to using the Zipper, hence it's for INTERNAL USE ONLY. A BinPath provides +-- a way of finding a particular element in an AVL tree again without doing +-- any comparisons. But a BinPath is ONLY VALID IF THE TREE SHAPE DOES NOT +-- CHANGE. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.BinPath + (BinPath(..),genFindPath,genOpenPath,genOpenPathWith,readPath,writePath,insertPath, + -- These are used by deletePath, which currently resides in Data.Tree.AVL.Internals.DelUtils + sel,goL,goR, + ) where +-- N.B. The deletePath function should really be here too, but has been put +-- in Data.Tree.AVL.Internals.DelUtils instead because deletion is a tangled web of circular +-- depencency. + +import Data.Tree.AVL.Types(AVL(..)) +import Data.COrdering + +#if __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" + +-- Test path LSB +bit0 :: Int# -> Bool +{-# INLINE bit0 #-} +bit0 p = word2Int# (and# (int2Word# p) (int2Word# 1#)) ==# 1# + +-- A pseudo comparison.. +-- N.B. If the path was bit reversed, this could be a straight comparison.?? +sel :: Int# -> Ordering +{-# INLINE sel #-} +sel p = if p ==# 0# then EQ + else if bit0 p then LT -- Left if Bit 0 == 1 + else GT -- Right if Bit 0 == 0 + + +-- Modify path for entering left subtree +goL :: Int# -> Int# +{-# INLINE goL #-} +goL p = iShiftRL# p 1# + +-- Modify path for entering right subtree +goR :: Int# -> Int# +{-# INLINE goR #-} +goR p = iShiftRL# (p -# 1#) 1# + +#else +#include "h98defs.h" +import Data.Bits + +-- A pseudo comparison.. +-- N.B. If the path was bit reversed, this could be a straight comparison.?? +sel :: Int -> Ordering +{-# INLINE sel #-} +sel p = if p == 0 then EQ + else if bit0 p then LT -- Left if Bit 0 == 1 + else GT -- Right if Bit 0 == 0 +bit0 :: Int -> Bool +{-# INLINE bit0 #-} +bit0 p = (p .&. 1) == 1 + +-- Modify path for entering left subtree +goL :: Int -> Int +{-# INLINE goL #-} +goL p = shiftL p 1 + +-- Modify path for entering right subtree +goR :: Int -> Int +{-# INLINE goR #-} +goR p = shiftL (p-1) 1 + +#endif + +-- | Int fields are search /depth/ and /path bits/ respecively. The /path bits/ consist of a +-- a string of /depth/ bits, left justified. MSB of 0 means go left, MSB of 1 means go right. +data BinPath a = FullBP {-# UNPACK #-} !UINT a -- Found + | EmptyBP {-# UNPACK #-} !UINT -- Not Found + +{------------------------------------------------------------------------------------------- + Notes: +-------------------------------------------------------------------------------------------- +The Binary paths are based on an indexing scheme that: + 1- Uniquely identifies each tree node + 2- Provides a simple algorithm for path generation. + 3- Provides a simple algorithm to locate a node in the tree, given it's path. + +Imagine an infinite Binary Tree, with nodes indexed as follows: + + _____00_____ <- d=1 + / \ + _01_ _02_ <- d=2 + / \ / \ + 03 05 04 06 <- d=4 + / \ / \ / \ / \ + 07 11 09 13 08 12 10 14 <- d=8 + <-------- More Layers -------> + +To generate the node index (path) as we move down the tree we.. + 1- Initialise index (i) to 0, and a parameter (d) to 1 + 2- If we've arrived where we want, output i. + 3- Either Move left: i <- i+d, d <- 2d, goto 2 + or Move right: i <- i+2d, d <- 2d, goto 2 + +To find a node, given its index (path) i, we.. + 1- If i=0 then stop, we've arrived. + 2- If i is odd then move left , i <- (i-1)>>1, goto 1 -- (i-1)>>1 = i>>1 if i is odd + else move right, i <- (i-1)>>1, goto 1 -- (i-1)>>1 = (i>>1)-1 if i is even +Examples: + i=05: (left ,i<-2):(right,i<-0):(stop) + i=12: (right,i<-5):(left ,i<-2):(right,i<-0):(stop) + +See also: pathTree in Data.Tree.AVL.Test.Utils for recursive implementation of the indexing scheme. +--------------------------------------------------------------------------------------------} + +-- | Find the path to a AVL tree element, returns -1 (invalid path) if element not found +-- +-- Complexity: O(log n) +genFindPath :: (e -> Ordering) -> AVL e -> UINT +-- ?? What about strictness if UINT is boxed (i.e. non-ghc)? +genFindPath c t = find L(1) L(0) t where + find _ _ E = L(-1) + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + EQ -> i + GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Get the BinPath of an element using the supplied selector. +-- +-- Complexity: O(log n) +genOpenPath :: (e -> Ordering) -> AVL e -> BinPath e +genOpenPath c t = find L(1) L(0) t where + find _ i E = EmptyBP i + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + LT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + EQ -> FullBP i e + GT -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Get the BinPath of an element using the supplied (combining) selector. +-- +-- Complexity: O(log n) +genOpenPathWith :: (e -> COrdering a) -> AVL e -> BinPath a +genOpenPathWith c t = find L(1) L(0) t where + find _ i E = EmptyBP i + find d i (N l e r) = find' d i l e r + find d i (Z l e r) = find' d i l e r + find d i (P l e r) = find' d i l e r + find' d i l e r = case c e of + Lt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d ) l + Eq a -> FullBP i a + Gt -> let d_ = ADDINT(d,d) in find d_ ADDINT(i,d_) r -- d_ = 2d + +-- | Overwrite a tree element. Assumes the path bits were extracted from 'FullBP' constructor. +-- Raises an error if the path leads to an empty tree. +-- +-- N.B This operation does not change tree shape (no insertion occurs). +-- +-- Complexity: O(log n) +writePath :: UINT -> e -> AVL e -> AVL e +writePath i0 e' t = wp i0 t where + wp L(0) E = error "writePath: Bug0" -- Needed to force strictness in path + wp L(0) (N l _ r) = N l e' r + wp L(0) (Z l _ r) = Z l e' r + wp L(0) (P l _ r) = P l e' r + wp _ E = error "writePath: Bug1" + wp i (N l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` N l' e r + else let r' = wp (goR i) r in r' `seq` N l e r' + wp i (Z l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` Z l' e r + else let r' = wp (goR i) r in r' `seq` Z l e r' + wp i (P l e r) = if bit0 i then let l' = wp (goL i) l in l' `seq` P l' e r + else let r' = wp (goR i) r in r' `seq` P l e r' + +-- | Read a tree element. Assumes the path bits were extracted from 'FullBP' constructor. +-- Raises an error if the path leads to an empty tree. +-- +-- Complexity: O(log n) +readPath :: UINT -> AVL e -> e +readPath L(0) E = error "readPath: Bug0" -- Needed to force strictness in path +readPath L(0) (N _ e _) = e +readPath L(0) (Z _ e _) = e +readPath L(0) (P _ e _) = e +readPath _ E = error "readPath: Bug1" +readPath i (N l _ r) = readPath_ i l r +readPath i (Z l _ r) = readPath_ i l r +readPath i (P l _ r) = readPath_ i l r +readPath_ :: UINT -> AVL e -> AVL e -> e +readPath_ i l r = if bit0 i then readPath (goL i) l + else readPath (goR i) r + +-- | Inserts a new tree element. Assumes the path bits were extracted from a 'EmptyBP' constructor. +-- This function replaces the first Empty node it encounters with the supplied value, regardless +-- of the current path bits (which are not checked). DO NOT USE THIS FOR REPLACING ELEMENTS ALREADY +-- PRESENT IN THE TREE (use 'writePath' for this). +-- +-- Complexity: O(log n) +insertPath :: UINT -> e -> AVL e -> AVL e +insertPath i0 e0 t = put i0 t where + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put _ E = Z E e0 E + put i (N l e r) = putN i l e r + put i (Z l e r) = putZ i l e r + put i (P l e r) = putP i l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + -- Put in (N l e r), BF=-1 , (never returns P) + putN i l e r = if bit0 i then putNL i l e r -- put in L subtree + else putNR i l e r -- put in R subtree + + -- Put in (Z l e r), BF= 0 + putZ i l e r = if bit0 i then putZL i l e r -- put in L subtree + else putZR i l e r -- put in R subtree + + -- Put in (P l e r), BF=+1 , (never returns N) + putP i l e r = if bit0 i then putPL i l e r -- put in L subtree + else putPR i l e r -- put in R subtree + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + {-# INLINE putNL #-} + putNL _ E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "insertPath: Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL _ E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL i (Z ll le lr) e r = let l' = putZ (goL i) ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "insertPath: Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR _ l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "insertPath: Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR _ l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR i l e (Z rl re rr) = let r' = putZ (goR i) rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "insertPath: Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e 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 l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ _ E = error "insertPath: Bug4" -- impossible if BF=-1 + putNR i l e (N rl re rr) = let r' = putN (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR i l e (P rl re rr) = let r' = putP (goR i) rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR i l e (Z rl re rr) = let i' = goR i in if bit0 i' then putNRL i' l e rl re rr -- RL (never returns P) + else putNRR i' l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL _ E _ _ = error "insertPath: Bug5" -- impossible if BF=+1 + putPL i (N ll le lr) e r = let l' = putN (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL i (P ll le lr) e r = let l' = putP (goL i) ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL i (Z ll le lr) e r = let i' = goL i in if bit0 i' then putPLL i' ll le lr e r -- LL (never returns N) + else putPLR i' ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR _ l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR i l e rl re (N rrl rre rrr) = let rr' = putN (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR i l e rl re (P rrl rre rrr) = let rr' = putP (goR i) rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR i l e rl re (Z rrl rre rrr) = let rr' = putZ (goR i) rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "insertPath: Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL _ E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL i (N lll lle llr) le lr e r = let ll' = putN (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL i (P lll lle llr) le lr e r = let ll' = putP (goL i) lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL i (Z lll lle llr) le lr e r = let ll' = putZ (goL i) lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "insertPath: Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL _ l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL i l e (N rll rle rlr) re rr = let rl' = putN (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL i l e (P rll rle rlr) re rr = let rl' = putP (goL i) rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL i l e (Z rll rle rlr) re rr = let rl' = putZ (goL i) rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "insertPath: Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR _ ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR i ll le (N lrl lre lrr) e r = let lr' = putN (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR i ll le (P lrl lre lrr) e r = let lr' = putP (goR i) lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR i ll le (Z lrl lre lrr) e r = let lr' = putZ (goR i) lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "insertPath: Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +----------------------- insertPath Ends Here -------------------------- +----------------------------------------------------------------------- + diff --git a/Data/Tree/AVL/Internals/DelUtils.hs b/Data/Tree/AVL/Internals/DelUtils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/DelUtils.hs @@ -0,0 +1,790 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.DelUtils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines utility functions for deleting elements from AVL trees. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.DelUtils + (-- * Deleting utilities. + delRN,delRZ,delRP,delLN,delLZ,delLP, + + -- * Popping utilities. + popRN,popRZ,popRP,popLN,popLZ,popLP, + popHL,popHLN,popHLZ,popHLP, + + -- * Balancing utilities. + chkLN,chkLZ,chkLP,chkRN,chkRZ,chkRP, + chkLN',chkLZ',chkLP',chkRN',chkRZ',chkRP', + + -- * Node substitution utilities. + subN,subZR,subZL,subP, + + -- * BinPath related. + deletePath, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(sel,goL,goR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +{------------------------------------------------------------------------------------------------------------------------------ + -------------------------------------- Notes about Deletion and Rebalancing ------------------------------------------------- + ------------------------------------------------------------------------------------------------------------------------------ +If you go through a similar analysis to that indicated in the Push.hs module (which I haven't illustrated +here with ASCII art) it can be seen that (as with insertion) the height change in a tree which occurs +as a result of deletion of a node can be infered from the change in BF, (whether or not a re-balancing +rotation was required). The rules are: + BF +/-1 -> 0, height decreased by 1 + BF 0 -> +/-1, height unchanged. + BF unchanged , height unchanged. + BF +/-1 -> -/+1, height unchanged. + +Unlike insertion, rebalancing on deletion requires pattern matching on nodes which aren't on the +current path, hence the existance of separate rebalancing functions (rebalN and rebalP). + +----------------------------------------------------------------------------------------------------------------------------- +-----------------------------------------------------------------------------------------------------------------------------} + + +----------------------------------------------------------------------- +------------------------ delL Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- delL LEVEL 1 ------------------------------- +-- delLN, delLZ, delLP -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +delLN :: AVL e -> e -> AVL e -> AVL e +delLN E _ r = r -- Terminal case, r must be of form (Z E re E) +delLN (N ll le lr) e r = chkLN (delLN ll le lr) e r +delLN (Z ll le lr) e r = delLNZ ll le lr e r +delLN (P ll le lr) e r = chkLN (delLP ll le lr) e r + +-- Delete leftmost from (Z l e r) +delLZ :: AVL e -> e -> AVL e -> AVL e +delLZ E _ _ = E -- Terminal case, r must be E +delLZ (N ll le lr) e r = delLZN ll le lr e r +delLZ (Z ll le lr) e r = delLZZ ll le lr e r +delLZ (P ll le lr) e r = delLZP ll le lr e r + +-- Delete leftmost from (P l e r) +delLP :: AVL e -> e -> AVL e -> AVL e +--delLP E _ _ = error "delLP: Bug0" -- Impossible if BF=+1 +delLP (N ll le lr) e r = chkLP (delLN ll le lr) e r +delLP (Z ll le lr) e r = delLPZ ll le lr e r +delLP (P ll le lr) e r = chkLP (delLP ll le lr) e r + +-------------------------- delL LEVEL 2 ------------------------------- +-- delLNZ, delLZZ, delLPZ -- +-- delLZN, delLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE delLNZ #-} +delLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLNZ E _ _ e r = rebalN E e r -- Terminal case, Needs rebalancing +delLNZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` N l' e r +delLNZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` N l' e r +delLNZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` N l' e r + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't inline +delLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZZ E _ _ e r = N E e r -- Terminal case +delLZZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` Z l' e r +delLZZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` Z l' e r +delLZZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` Z l' e r + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE delLPZ #-} +delLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLPZ E _ _ e _ = Z E e E -- Terminal case +delLPZ (N lll lle llr) le lr e r = let l' = delLZN lll lle llr le lr in l' `seq` P l' e r +delLPZ (Z lll lle llr) le lr e r = let l' = delLZZ lll lle llr le lr in l' `seq` P l' e r +delLPZ (P lll lle llr) le lr e r = let l' = delLZP lll lle llr le lr in l' `seq` P l' e r + +-- Delete leftmost from (Z (N ll le lr) e r) +{-# INLINE delLZN #-} +delLZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZN ll le lr e r = chkLZ (delLN ll le lr) e r + +-- Delete leftmost from (Z (P ll le lr) e r) +{-# INLINE delLZP #-} +delLZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delLZP ll le lr e r = chkLZ (delLP ll le lr) e r +----------------------------------------------------------------------- +-------------------------- delL Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ delR Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- delR LEVEL 1 ------------------------------- +-- delRN, delRZ, delRP -- +----------------------------------------------------------------------- +-- Delete rightmost from (N l e r) +delRN :: AVL e -> e -> AVL e -> AVL e +--delRN _ _ E = error "delRN: Bug0" -- Impossible if BF=-1 +delRN l e (N rl re rr) = chkRN l e (delRN rl re rr) +delRN l e (Z rl re rr) = delRNZ l e rl re rr +delRN l e (P rl re rr) = chkRN l e (delRP rl re rr) + +-- Delete rightmost from (Z l e r) +delRZ :: AVL e -> e -> AVL e -> AVL e +delRZ _ _ E = E -- Terminal case, l must be E +delRZ l e (N rl re rr) = delRZN l e rl re rr +delRZ l e (Z rl re rr) = delRZZ l e rl re rr +delRZ l e (P rl re rr) = delRZP l e rl re rr + +-- Delete rightmost from (P l e r) +delRP :: AVL e -> e -> AVL e -> AVL e +delRP l _ E = l -- Terminal case, l must be of form (Z E le E) +delRP l e (N rl re rr) = chkRP l e (delRN rl re rr) +delRP l e (Z rl re rr) = delRPZ l e rl re rr +delRP l e (P rl re rr) = chkRP l e (delRP rl re rr) + +-------------------------- delR LEVEL 2 ------------------------------- +-- delRNZ, delRZZ, delRPZ -- +-- delRZN, delRZP -- +----------------------------------------------------------------------- + +-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case +delRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRNZ #-} +delRNZ _ e _ _ E = Z E e E -- Terminal case +delRNZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` N l e r' +delRNZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` N l e r' +delRNZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` N l e r' + +-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case +delRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +delRZZ l e _ _ E = P l e E -- Terminal case +delRZZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` Z l e r' +delRZZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` Z l e r' +delRZZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` Z l e r' + +-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case +delRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRPZ #-} +delRPZ l e _ _ E = rebalP l e E -- Terminal case, Needs rebalancing +delRPZ l e rl re (N rrl rre rrr) = let r' = delRZN rl re rrl rre rrr in r' `seq` P l e r' +delRPZ l e rl re (Z rrl rre rrr) = let r' = delRZZ rl re rrl rre rrr in r' `seq` P l e r' +delRPZ l e rl re (P rrl rre rrr) = let r' = delRZP rl re rrl rre rrr in r' `seq` P l e r' + +-- Delete rightmost from (Z l e (N rl re rr)) +delRZN :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRZN #-} +delRZN l e rl re rr = chkRZ l e (delRN rl re rr) + +-- Delete rightmost from (Z l e (P rl re rr)) +delRZP :: AVL e -> e -> AVL e -> e -> AVL e -> AVL e +{-# INLINE delRZP #-} +delRZP l e rl re rr = chkRZ l e (delRP rl re rr) +----------------------------------------------------------------------- +-------------------------- delR Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ popL Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popL LEVEL 1 ------------------------------- +-- popLN, popLZ, popLP -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +popLN :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLN E e r = UBT2(e,r) -- Terminal case, r must be of form (Z E re E) +popLN (N ll le lr) e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t) +popLN (Z ll le lr) e r = popLNZ ll le lr e r +popLN (P ll le lr) e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLN l e r in t `seq` UBT2(v,t) + +-- Delete leftmost from (Z l e r) +popLZ :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZ E e _ = UBT2(e,E) -- Terminal case, r must be E +popLZ (N ll le lr) e r = popLZN ll le lr e r +popLZ (Z ll le lr) e r = popLZZ ll le lr e r +popLZ (P ll le lr) e r = popLZP ll le lr e r + +-- Delete leftmost from (P l e r) +popLP :: AVL e -> e -> AVL e -> UBT2(e,AVL e) +--popLP E _ _ = error "popLP: Bug!" -- Impossible if BF=+1 +popLP (N ll le lr) e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t) +popLP (Z ll le lr) e r = popLPZ ll le lr e r +popLP (P ll le lr) e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLP l e r in t `seq` UBT2(v,t) + +-------------------------- popL LEVEL 2 ------------------------------- +-- popLNZ, popLZZ, popLPZ -- +-- popLZN, popLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +popLNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +{-# INLINE popLNZ #-} +popLNZ E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing + in t `seq` UBT2(le,t) +popLNZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) +popLNZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) +popLNZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, N l e r) + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't INLINE this! +popLZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZZ E le _ e r = UBT2(le, N E e r) -- Terminal case +popLZZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) +popLZZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) +popLZZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, Z l e r) + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +popLPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +{-# INLINE popLPZ #-} +popLPZ E le _ e _ = UBT2(le, Z E e E) -- Terminal case +popLPZ (N lll lle llr) le lr e r = case popLZN lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) +popLPZ (Z lll lle llr) le lr e r = case popLZZ lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) +popLPZ (P lll lle llr) le lr e r = case popLZP lll lle llr le lr of + UBT2(v,l) -> UBT2(v, P l e r) + +-- Delete leftmost from (Z (N ll le lr) e r) +-- Don't INLINE this! +popLZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZN ll le lr e r = case popLN ll le lr of + UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t) +-- Delete leftmost from (Z (P ll le lr) e r) +-- Don't INLINE this! +popLZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(e,AVL e) +popLZP ll le lr e r = case popLP ll le lr of + UBT2(v,l) -> let t = chkLZ l e r in t `seq` UBT2(v,t) +----------------------------------------------------------------------- +-------------------------- popL Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +------------------------ popR Starts Here ----------------------------- +----------------------------------------------------------------------- +-------------------------- popR LEVEL 1 ------------------------------- +-- popRN, popRZ, popRP -- +----------------------------------------------------------------------- +-- Delete rightmost from (N l e r) +popRN :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +--popRN _ _ E = error "popRN: Bug!" -- Impossible if BF=-1 +popRN l e (N rl re rr) = case popRN rl re rr of + UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v) +popRN l e (Z rl re rr) = popRNZ l e rl re rr +popRN l e (P rl re rr) = case popRP rl re rr of + UBT2(r,v) -> let t = chkRN l e r in t `seq` UBT2(t,v) + +-- Delete rightmost from (Z l e r) +popRZ :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZ _ e E = UBT2(E,e) -- Terminal case, l must be E +popRZ l e (N rl re rr) = popRZN l e rl re rr +popRZ l e (Z rl re rr) = popRZZ l e rl re rr +popRZ l e (P rl re rr) = popRZP l e rl re rr + +-- Delete rightmost from (P l e r) +popRP :: AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRP l e E = UBT2(l,e) -- Terminal case, l must be of form (Z E le E) +popRP l e (N rl re rr) = case popRN rl re rr of + UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v) +popRP l e (Z rl re rr) = popRPZ l e rl re rr +popRP l e (P rl re rr) = case popRP rl re rr of + UBT2(r,v) -> let t = chkRP l e r in t `seq` UBT2(t,v) + +-------------------------- popR LEVEL 2 ------------------------------- +-- popRNZ, popRZZ, popRPZ -- +-- popRZN, popRZP -- +----------------------------------------------------------------------- + +-- Delete rightmost from (N l e (Z rl re rr)), height of right sub-tree can't change in this case +popRNZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +{-# INLINE popRNZ #-} +popRNZ _ e _ re E = UBT2(Z E e E, re) -- Terminal case +popRNZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) +popRNZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) +popRNZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(N l e r, v) + +-- Delete rightmost from (Z l e (Z rl re rr)), height of right sub-tree can't change in this case +-- Don't INLINE this! +popRZZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZZ l e _ re E = UBT2(P l e E, re) -- Terminal case +popRZZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) +popRZZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) +popRZZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(Z l e r, v) + +-- Delete rightmost from (P l e (Z rl re rr)), height of right sub-tree can't change in this case +popRPZ :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +{-# INLINE popRPZ #-} +popRPZ l e _ re E = let t = rebalP l e E -- Terminal case, Needs rebalancing + in t `seq` UBT2(t,re) +popRPZ l e rl re (N rrl rre rrr) = case popRZN rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) +popRPZ l e rl re (Z rrl rre rrr) = case popRZZ rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) +popRPZ l e rl re (P rrl rre rrr) = case popRZP rl re rrl rre rrr of + UBT2(r,v) -> UBT2(P l e r, v) + +-- Delete rightmost from (Z l e (N rl re rr)) +-- Don't INLINE this! +popRZN :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZN l e rl re rr = case popRN rl re rr of + UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v) + +-- Delete rightmost from (Z l e (P rl re rr)) +-- Don't INLINE this! +popRZP :: AVL e -> e -> AVL e -> e -> AVL e -> UBT2(AVL e,e) +popRZP l e rl re rr = case popRP rl re rr of + UBT2(r,v) -> let t = chkRZ l e r in t `seq` UBT2(t,v) +----------------------------------------------------------------------- +-------------------------- popR Ends Here ----------------------------- +----------------------------------------------------------------------- + + + +----------------------------------------------------------------------- +--------------------- deletePath Starts Here -------------------------- +----------------------------------------------------------------------- +-- | Deletes a tree element. Assumes the path bits were extracted from a 'FullBP' constructor. +-- +-- Complexity: O(log n) +deletePath :: UINT -> AVL e -> AVL e +deletePath _ E = error "deletePath: Element not found." +deletePath p (N l e r) = delN p l e r +deletePath p (Z l e r) = delZ p l e r +deletePath p (P l e r) = delP p l e r + +----------------------------- LEVEL 1 --------------------------------- +-- delN, delZ, delP -- +----------------------------------------------------------------------- + +-- Delete from (N l e r) +delN :: UINT -> AVL e -> e -> AVL e -> AVL e +delN p l e r = case sel p of + LT -> delNL p l e r + EQ -> subN l r + GT -> delNR p l e r + +-- Delete from (Z l e r) +delZ :: UINT -> AVL e -> e -> AVL e -> AVL e +delZ p l e r = case sel p of + LT -> delZL p l e r + EQ -> subZR l r + GT -> delZR p l e r + +-- Delete from (P l e r) +delP :: UINT -> AVL e -> e -> AVL e -> AVL e +delP p l e r = case sel p of + LT -> delPL p l e r + EQ -> subP l r + GT -> delPR p l e r + +----------------------------- LEVEL 2 --------------------------------- +-- delNL, delZL, delPL -- +-- delNR, delZR, delPR -- +----------------------------------------------------------------------- + +-- Delete from the left subtree of (N l e r) +delNL :: UINT -> AVL e -> e -> AVL e -> AVL e +delNL p t = dNL (goL p) t +{-# INLINE dNL #-} +dNL :: UINT -> AVL e -> e -> AVL e -> AVL e +dNL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty +dNL p (N ll le lr) e r = case sel p of + LT -> chkLN (delNL p ll le lr) e r + EQ -> chkLN (subN ll lr) e r + GT -> chkLN (delNR p ll le lr) e r +dNL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` N l' e r -- height can't change + EQ -> chkLN' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` N l' e r -- height can't change +dNL p (P ll le lr) e r = case sel p of + LT -> chkLN (delPL p ll le lr) e r + EQ -> chkLN (subP ll lr) e r + GT -> chkLN (delPR p ll le lr) e r + +-- Delete from the right subtree of (N l e r) +delNR :: UINT -> AVL e -> e -> AVL e -> AVL e +delNR p t = dNR (goR p) t +{-# INLINE dNR #-} +dNR :: UINT -> AVL e -> e -> AVL e -> AVL e +--dNR _ _ _ E = error "delNR: Bug0" -- Impossible +dNR p l e (N rl re rr) = case sel p of + LT -> chkRN l e (delNL p rl re rr) + EQ -> chkRN l e (subN rl rr) + GT -> chkRN l e (delNR p rl re rr) +dNR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` N l e r' -- height can't change + EQ -> chkRN' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` N l e r' -- height can't change +dNR p l e (P rl re rr) = case sel p of + LT -> chkRN l e (delPL p rl re rr) + EQ -> chkRN l e (subP rl rr) + GT -> chkRN l e (delPR p rl re rr) + +-- Delete from the left subtree of (Z l e r) +delZL :: UINT -> AVL e -> e -> AVL e -> AVL e +delZL p t = dZL (goL p) t +{-# INLINE dZL #-} +dZL :: UINT -> AVL e -> e -> AVL e -> AVL e +dZL _ E _ _ = error "deletePath: Element not found." -- Left sub-tree is empty +dZL p (N ll le lr) e r = case sel p of + LT -> chkLZ (delNL p ll le lr) e r + EQ -> chkLZ (subN ll lr) e r + GT -> chkLZ (delNR p ll le lr) e r +dZL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` Z l' e r -- height can't change + EQ -> chkLZ' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` Z l' e r -- height can't change +dZL p (P ll le lr) e r = case sel p of + LT -> chkLZ (delPL p ll le lr) e r + EQ -> chkLZ (subP ll lr) e r + GT -> chkLZ (delPR p ll le lr) e r + +-- Delete from the right subtree of (Z l e r) +delZR :: UINT -> AVL e -> e -> AVL e -> AVL e +delZR p t = dZR (goR p) t +{-# INLINE dZR #-} +dZR :: UINT -> AVL e -> e -> AVL e -> AVL e +dZR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty +dZR p l e (N rl re rr) = case sel p of + LT -> chkRZ l e (delNL p rl re rr) + EQ -> chkRZ l e (subN rl rr) + GT -> chkRZ l e (delNR p rl re rr) +dZR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` Z l e r' -- height can't change + EQ -> chkRZ' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` Z l e r' -- height can't change +dZR p l e (P rl re rr) = case sel p of + LT -> chkRZ l e (delPL p rl re rr) + EQ -> chkRZ l e (subP rl rr) + GT -> chkRZ l e (delPR p rl re rr) + +-- Delete from the left subtree of (P l e r) +delPL :: UINT -> AVL e -> e -> AVL e -> AVL e +delPL p t = dPL (goL p) t +{-# INLINE dPL #-} +dPL :: UINT -> AVL e -> e -> AVL e -> AVL e +--dPL _ E _ _ = error "delPL: Bug0" -- Impossible +dPL p (N ll le lr) e r = case sel p of + LT -> chkLP (delNL p ll le lr) e r + EQ -> chkLP (subN ll lr) e r + GT -> chkLP (delNR p ll le lr) e r +dPL p (Z ll le lr) e r = case sel p of + LT -> let l' = delZL p ll le lr in l' `seq` P l' e r -- height can't change + EQ -> chkLP' (subZR ll lr) e r -- << But it can here + GT -> let l' = delZR p ll le lr in l' `seq` P l' e r -- height can't change +dPL p (P ll le lr) e r = case sel p of + LT -> chkLP (delPL p ll le lr) e r + EQ -> chkLP (subP ll lr) e r + GT -> chkLP (delPR p ll le lr) e r + +-- Delete from the right subtree of (P l e r) +delPR :: UINT -> AVL e -> e -> AVL e -> AVL e +delPR p t = dPR (goR p) t +{-# INLINE dPR #-} +dPR :: UINT -> AVL e -> e -> AVL e -> AVL e +dPR _ _ _ E = error "deletePath: Element not found." -- Right sub-tree is empty +dPR p l e (N rl re rr) = case sel p of + LT -> chkRP l e (delNL p rl re rr) + EQ -> chkRP l e (subN rl rr) + GT -> chkRP l e (delNR p rl re rr) +dPR p l e (Z rl re rr) = case sel p of + LT -> let r' = delZL p rl re rr in r' `seq` P l e r' -- height can't change + EQ -> chkRP' l e (subZL rl rr) -- << But it can here + GT -> let r' = delZR p rl re rr in r' `seq` P l e r' -- height can't change +dPR p l e (P rl re rr) = case sel p of + LT -> chkRP l e (delPL p rl re rr) + EQ -> chkRP l e (subP rl rr) + GT -> chkRP l e (delPR p rl re rr) +----------------------------------------------------------------------- +----------------------- deletePath Ends Here -------------------------- +----------------------------------------------------------------------- + + + +------------------------------------------------------------------------------------- +-- This is a modified version of popL which returns the (popped) tree height as well. +------------------------------------------------------------------------------------- +popHL :: AVL e -> UBT3(e,AVL e,UINT) +--popHL E = error "popHL: Empty tree." +popHL (N l e r) = popHLN l e r +popHL (Z l e r) = popHLZ l e r +popHL (P l e r) = popHLP l e r + +popHLN :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLN l e r = case popHLN_ L(2) l e r of + UBT3(e_,t,h) -> case t of +-- E -> error "popHLN: Bug0" -- impossible + Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1 + _ -> UBT3(e_,t, h ) -- dH = 0 + +popHLZ :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZ l e r = case popHLZ_ L(1) l e r of + UBT3(e_,t,h) -> case t of + E -> UBT3(e,E,L(0)) -- Resulting tree is empty +-- P _ _ _ -> error "popHLZ: Bug0" -- impossible + _ -> UBT3(e_,t, h ) -- dH = 0 + +popHLP :: AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLP l e r = case popHLP_ L(1) l e r of + UBT3(e_,t,h) -> case t of + Z _ _ _ -> UBT3(e_,t,DECINT1(h)) -- dH = -1 + P _ _ _ -> UBT3(e_,t, h ) -- dH = 0 +-- _ -> error "popHLP: Bug0" -- impossible + +-------------------------- popHL LEVEL 1 ------------------------------ +-- popHLN_, popHLZ_, popHLP_ -- +----------------------------------------------------------------------- +-- Delete leftmost from (N l e r) +popHLN_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLN_ h E e r = UBT3(e,r,h) -- Terminal case, r must be of form (Z E re E) +popHLN_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl) +popHLN_ h (Z ll le lr) e r = popHLNZ INCINT1(h) ll le lr e r +popHLN_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLN l e r in t `seq` UBT3(e_,t,hl) + +-- Delete leftmost from (Z l e r) +{-# INLINE popHLZ_ #-} +popHLZ_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZ_ h E e _ = UBT3(e,E,h) -- Terminal case, r must be E +popHLZ_ h (N ll le lr) e r = popHLZN INCINT2(h) ll le lr e r +popHLZ_ h (Z ll le lr) e r = popHLZZ INCINT1(h) ll le lr e r +popHLZ_ h (P ll le lr) e r = popHLZP INCINT1(h) ll le lr e r + +-- Delete leftmost from (P l e r) +popHLP_ :: UINT -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +--popHLP_ _ E _ _ = error "popHLP_: Bug0" -- Impossible if BF=+1 +popHLP_ h (N ll le lr) e r = case popHLN_ INCINT2(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl) +popHLP_ h (Z ll le lr) e r = popHLPZ INCINT1(h) ll le lr e r +popHLP_ h (P ll le lr) e r = case popHLP_ INCINT1(h) ll le lr of + UBT3(e_,l,hl) -> let t = chkLP l e r in t `seq` UBT3(e_,t,hl) + +-------------------------- popHL LEVEL 2 ------------------------------ +-- popHLNZ, popHLZZ, popHLPZ -- +-- popHLZN, popHLZP -- +----------------------------------------------------------------------- + +-- Delete leftmost from (N (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE popHLNZ #-} +popHLNZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLNZ h E le _ e r = let t = rebalN E e r -- Terminal case, Needs rebalancing + in t `seq` UBT3(le,t,h) +popHLNZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) +popHLNZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) +popHLNZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, N l e r, hl) + +-- Delete leftmost from (Z (Z ll le lr) e r), height of left sub-tree can't change in this case +-- Don't INLINE this! +popHLZZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZZ h E le _ e r = UBT3(le, N E e r, h) -- Terminal case +popHLZZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) +popHLZZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) +popHLZZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, Z l e r, hl) + +-- Delete leftmost from (P (Z ll le lr) e r), height of left sub-tree can't change in this case +{-# INLINE popHLPZ #-} +popHLPZ :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLPZ h E le _ e _ = UBT3(le, Z E e E, h) -- Terminal case +popHLPZ h (N lll lle llr) le lr e r = case popHLZN INCINT2(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) +popHLPZ h (Z lll lle llr) le lr e r = case popHLZZ INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) +popHLPZ h (P lll lle llr) le lr e r = case popHLZP INCINT1(h) lll lle llr le lr of + UBT3(e_,l,hl) -> UBT3(e_, P l e r, hl) + +-- Delete leftmost from (Z (N ll le lr) e r) +-- Don't INLINE this! +popHLZN :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZN h ll le lr e r = case popHLN_ h ll le lr of + UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl) +-- Delete leftmost from (Z (P ll le lr) e r) +-- Don't INLINE this! +popHLZP :: UINT -> AVL e -> e -> AVL e -> e -> AVL e -> UBT3(e,AVL e,UINT) +popHLZP h ll le lr e r = case popHLP_ h ll le lr of + UBT3(e_,l,hl) -> let t = chkLZ l e r in t `seq` UBT3(e_,t,hl) +----------------------------------------------------------------------- +------------------------- popHL Ends Here ----------------------------- +----------------------------------------------------------------------- + +{-************************** Balancing Utilities Below Here ************************************-} + +-- Rebalance a tree of form (N l e 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 :: AVL e -> e -> AVL e -> AVL e +rebalN _ _ E = error "rebalN: Bug0" -- impossible case +rebalN l e (N rl re rr) = Z (Z l e rl) re rr -- N->Z, dH=-1 +rebalN l e (Z rl re rr) = P (N l e rl) re rr -- N->P, dH= 0 +rebalN _ _ (P E _ _) = error "rebalN: Bug1" -- impossible case +rebalN l e (P (N rll rle rlr) re rr) = Z (P l e rll) rle (Z rlr re rr) -- N->Z, dH=-1 +rebalN l e (P (Z rll rle rlr) re rr) = Z (Z l e rll) rle (Z rlr re rr) -- N->Z, dH=-1 +rebalN l e (P (P rll rle rlr) re rr) = Z (Z l e rll) rle (N rlr re rr) -- N->Z, dH=-1 + +-- Rebalance a tree of form (P l e 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 :: AVL e -> e -> AVL e -> AVL e +rebalP E _ _ = error "rebalP: Bug0" -- impossible case +rebalP (P ll le lr ) e r = Z ll le (Z lr e r) -- P->Z, dH=-1 +rebalP (Z ll le lr ) e r = N ll le (P lr e r) -- P->N, dH= 0 +rebalP (N _ _ E ) _ _ = error "rebalP: Bug1" -- impossible case +rebalP (N ll le (P lrl lre lrr)) e r = Z (Z ll le lrl) lre (N lrr e r) -- P->Z, dH=-1 +rebalP (N ll le (Z lrl lre lrr)) e r = Z (Z ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1 +rebalP (N ll le (N lrl lre lrr)) e r = Z (P ll le lrl) lre (Z lrr e r) -- P->Z, dH=-1 + +-- Check for height changes in left subtree of (N l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLN :: AVL e -> e -> AVL e -> AVL e +chkLN l e r = case l of + E -> error "chkLN: Bug0" -- impossible if BF<>0 + N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> rebalN l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (Z l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLZ :: AVL e -> e -> AVL e -> AVL e +chkLZ l e r = case l of + E -> error "chkLZ: Bug0" -- impossible if BF<>0 + N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> N l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in left subtree of (P l e r), +-- where l was (N ll le lr) or (P ll le lr) +chkLP :: AVL e -> e -> AVL e -> AVL e +chkLP l e r = case l of + E -> error "chkLP: Bug0" -- impossible if BF<>0 + N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (N l e r), +-- where r was (N rl re rr) or (P rl re rr) +chkRN :: AVL e -> e -> AVL e -> AVL e +chkRN l e r = case r of + E -> error "chkRN: Bug0" -- impossible if BF<>0 + N _ _ _ -> N l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> Z l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> N l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (Z l e r), +-- where r was (N rl re rr) or (P rl re rr) +chkRZ :: AVL e -> e -> AVL e -> AVL e +chkRZ l e r = case r of + E -> error "chkRZ: Bug0" -- impossible if BF<>0 + N _ _ _ -> Z l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> P l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> Z l e r -- BF +/-1 -> +1, so dH= 0 +-- Check for height changes in right subtree of (P l e r), +-- where l was (N rl re rr) or (P rl re rr) +chkRP :: AVL e -> e -> AVL e -> AVL e +chkRP l e r = case r of + E -> error "chkRP: Bug0" -- impossible if BF<>0 + N _ _ _ -> P l e r -- BF +/-1 -> -1, so dH= 0 + Z _ _ _ -> rebalP l e r -- BF +/-1 -> 0, so dH=-1 + P _ _ _ -> P l e r -- BF +/-1 -> +1, so dH= 0 + +-- Substitute deleted element from (N l _ r) +subN :: AVL e -> AVL e -> AVL e +subN _ E = error "subN: Bug0" -- Impossible +subN l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRN l e r_ +subN l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRN' l e r_ +subN l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRN l e r_ + +-- Substitute deleted element from (Z l _ r) +-- Pops the replacement from the right sub-tree, so result may be (P _ _ _) +subZR :: AVL e -> AVL e -> AVL e +subZR _ E = E -- Both left and right subtrees must have been empty +subZR l (N rl re rr) = case popLN rl re rr of UBT2(e,r_) -> chkRZ l e r_ +subZR l (Z rl re rr) = case popLZ rl re rr of UBT2(e,r_) -> chkRZ' l e r_ +subZR l (P rl re rr) = case popLP rl re rr of UBT2(e,r_) -> chkRZ l e 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 :: AVL e -> AVL e -> AVL e +subZL E _ = E -- Both left and right subtrees must have been empty +subZL (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLZ l_ e r +subZL (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLZ' l_ e r +subZL (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLZ l_ e r + +-- Substitute deleted element from (P l _ r) +subP :: AVL e -> AVL e -> AVL e +subP E _ = error "subP: Bug0" -- Impossible +subP (N ll le lr) r = case popRN ll le lr of UBT2(l_,e) -> chkLP l_ e r +subP (Z ll le lr) r = case popRZ ll le lr of UBT2(l_,e) -> chkLP' l_ e r +subP (P ll le lr) r = case popRP ll le lr of UBT2(l_,e) -> chkLP l_ e r + +-- Check for height changes in left subtree of (N l e r), +-- where l was (Z ll le lr) +chkLN' :: AVL e -> e -> AVL e -> AVL e +chkLN' l e r = case l of + E -> rebalN l e r -- BF 0 -> E, so dH=-1 + _ -> N l e r -- Otherwise dH=0 +-- Check for height changes in left subtree of (Z l e r), +-- where l was (Z ll le lr) +chkLZ' :: AVL e -> e -> AVL e -> AVL e +chkLZ' l e r = case l of + E -> N l e r -- BF 0 -> E, so dH=-1 + _ -> Z l e r -- Otherwise dH=0 +-- Check for height changes in left subtree of (P l e r), +-- where l was (Z ll le lr) +chkLP' :: AVL e -> e -> AVL e -> AVL e +chkLP' l e r = case l of + E -> Z l e r -- BF 0 -> E, so dH=-1 + _ -> P l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (N l e r), +-- where r was (Z rl re rr) +chkRN' :: AVL e -> e -> AVL e -> AVL e +chkRN' l e r = case r of + E -> Z l e r -- BF 0 -> E, so dH=-1 + _ -> N l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (Z l e r), +-- where r was (Z rl re rr) +chkRZ' :: AVL e -> e -> AVL e -> AVL e +chkRZ' l e r = case r of + E -> P l e r -- BF 0 -> E, so dH=-1 + _ -> Z l e r -- Otherwise dH=0 +-- Check for height changes in right subtree of (P l e r), +-- where l was (Z rl re rr) +chkRP' :: AVL e -> e -> AVL e -> AVL e +chkRP' l e r = case r of + E -> rebalP l e r -- BF 0 -> E, so dH=-1 + _ -> P l e r -- Otherwise dH=0 + diff --git a/Data/Tree/AVL/Internals/HAVL.hs b/Data/Tree/AVL/Internals/HAVL.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HAVL.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HAVL +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- HAVL data type and related utilities +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HAVL + ( + HAVL(HAVL),emptyHAVL,toHAVL,isEmptyHAVL,isNonEmptyHAVL, + spliceHAVL,joinHAVL, + pushLHAVL,pushRHAVL + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HeightUtils(addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | An HAVL represents an AVL tree of known height. +data HAVL e = HAVL (AVL e) {-# UNPACK #-} !UINT + +-- | Empty HAVL (height is 0). +emptyHAVL :: HAVL e +emptyHAVL = HAVL E L(0) + +-- | Returns 'True' if the AVL component of an HAVL tree is empty. Note that height component +-- is ignored, so it's OK to use this function in cases where the height is relative. +-- +-- Complexity: O(1) +{-# INLINE isEmptyHAVL #-} +isEmptyHAVL :: HAVL e -> Bool +isEmptyHAVL (HAVL E _) = True +isEmptyHAVL (HAVL _ _) = False + +-- | Returns 'True' if the AVL component of an HAVL tree is non-empty. Note that height component +-- is ignored, so it's OK to use this function in cases where the height is relative. +-- +-- Complexity: O(1) +{-# INLINE isNonEmptyHAVL #-} +isNonEmptyHAVL :: HAVL e -> Bool +isNonEmptyHAVL (HAVL E _) = False +isNonEmptyHAVL (HAVL _ _) = True + +-- | Converts an AVL to HAVL +toHAVL :: AVL e -> HAVL e +toHAVL t = HAVL t (addHeight L(0) t) + +-- | Splice two HAVL trees using the supplied bridging element. +-- That is, the bridging element appears "in the middle" of the resulting HAVL tree. +-- The elements of the first tree argument are to the left of the bridging element and +-- the elements of the second tree are to the right of the bridging element. +-- +-- This function does not require that the AVL 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. +{-# INLINE spliceHAVL #-} +spliceHAVL :: HAVL e -> e -> HAVL e -> HAVL e +spliceHAVL (HAVL l hl) e (HAVL r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> HAVL t ht + +-- | Join two HAVL trees. +-- 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. +{-# INLINE joinHAVL #-} +joinHAVL :: HAVL e -> HAVL e -> HAVL e +joinHAVL (HAVL l hl) (HAVL r hr) = case joinH l hl r hr of UBT2(t,ht) -> HAVL t ht + +-- | A version of 'pushL' for HAVL trees. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushLHAVL #-} +pushLHAVL :: e -> HAVL e -> HAVL e +pushLHAVL e (HAVL t ht) = case pushHL e t ht of UBT2(t_,ht_) -> HAVL t_ ht_ + +-- | A version of 'pushR' for HAVL trees. +-- It's OK if height is relative, with fixed offset. In this case the height of the result +-- will have the same fixed offset. +{-# INLINE pushRHAVL #-} +pushRHAVL :: HAVL e -> e -> HAVL e +pushRHAVL (HAVL t ht) e = case pushHR t ht e of UBT2(t_,ht_) -> HAVL t_ ht_ + diff --git a/Data/Tree/AVL/Internals/HJoin.hs b/Data/Tree/AVL/Internals/HJoin.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HJoin.hs @@ -0,0 +1,329 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HJoin +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for joining AVL trees of known height. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HJoin + ( spliceH,joinH,joinH', + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Push(pushL,pushR) +import Data.Tree.AVL.Internals.HPush(pushHL_,pushHR_) +import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP) + +#if __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Join two trees of known height, returning an AVL tree. +-- 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' + :: AVL e -> UINT -> AVL e -> UINT -> AVL e +joinH' l hl r hr + = if hl LEQ hr then let d = SUBINT(hr,hl) in joinHL d l r + else let d = SUBINT(hl,hr) in joinHR d l r + +-- hr >= hl, join l to left subtree of r. +-- Int argument is absolute difference in tree height, hr-hl (>=0) +{-# INLINE joinHL #-} +joinHL :: UINT -> AVL e -> AVL e -> AVL e +joinHL _ E r = r -- l was empty +joinHL d (N ll le lr) r = case popRN ll le lr of + UBT2(l_,e) -> case l_ of + E -> error "joinHL: Bug0" -- impossible if BF=-1 + Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1 + _ -> spliceL l_ e d r -- hl2=hl +joinHL d (Z ll le lr) r = case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> e `pushL` r -- l had only one element + _ -> spliceL l_ e d r -- hl2=hl +joinHL d (P ll le lr) r = case popRP ll le lr of + UBT2(l_,e) -> case l_ of + E -> error "joinHL: Bug1" -- impossible if BF=+1 + Z _ _ _ -> spliceL l_ e INCINT1(d) r -- hl2=hl-1 + _ -> spliceL l_ e d r -- hl2=hl + + +-- hl >= hr, join r to right subtree of l. +-- Int argument is absolute difference in tree height, hl-hr (>=0) +{-# INLINE joinHR #-} +joinHR :: UINT -> AVL e -> AVL e -> AVL e +joinHR _ l E = l -- r was empty +joinHR d l (N rl re rr) = case popLN rl re rr of + UBT2(e,r_) -> case r_ of + E -> error "joinHR: Bug0" -- impossible if BF=-1 + Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1 + _ -> spliceR r_ e d l -- hr2=hr +joinHR d l (Z rl re rr) = case popLZ rl re rr of + UBT2(e,r_) -> case r_ of + E -> l `pushR` e -- r had only one element + _ -> spliceR r_ e d l -- hr2=hr +joinHR d l (P rl re rr) = case popLP rl re rr of + UBT2(e,r_) -> case r_ of + E -> error "joinHL: Bug1" -- impossible if BF=+1 + Z _ _ _ -> spliceR r_ e INCINT1(d) l -- hr2=hr-1 + _ -> spliceR r_ e d l -- hr2=hr +----------------------------------------------------------------------- +--------------------------- joinH' Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | Join two AVL trees of known height, returning an AVL tree 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 :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +joinH l hl r hr = + case COMPAREUINT hl hr of + -- hr > hl + LT -> case l of + E -> UBT2(r,hr) + N ll le lr -> case popRN ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> spliceHL l_ hl e r hr -- dH= 0 + Z ll le lr -> case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> pushHL_ l r hr -- l had only 1 element + _ -> spliceHL l_ hl e r hr -- dH=0 + P ll le lr -> case popRP ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> spliceHL l_ hl e r hr -- dH= 0 + -- hr = hl + EQ -> case l of + E -> UBT2(l,hl) -- r must be empty too, don't use emptyAVL! + N ll le lr -> case popRN ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + Z ll le lr -> case popRZ ll le lr of + UBT2(l_,e) -> case l_ of + E -> pushHL_ l r hr -- l had only 1 element + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + P ll le lr -> case popRP ll le lr of + UBT2(l_,e) -> case l_ of + Z _ _ _ -> spliceHL l_ DECINT1(hl) e r hr -- dH=-1 + _ -> UBT2(Z l_ e r, INCINT1(hr)) -- dH= 0 + -- hl > hr + GT -> case r of + E -> UBT2(l,hl) + N rl re rr -> case popLN rl re rr of + UBT2(e,r_) -> case r_ of + Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1 + _ -> spliceHR l hl e r_ hr -- dH= 0 + Z rl re rr -> case popLZ rl re rr of + UBT2(e,r_) -> case r_ of + E -> pushHR_ l hl r -- r had only 1 element + _ -> spliceHR l hl e r_ hr -- dH=0 + P rl re rr -> case popLP rl re rr of + UBT2(e,r_) -> case r_ of + Z _ _ _ -> spliceHR l hl e r_ DECINT1(hr) -- dH=-1 + _ -> spliceHR l hl e r_ hr -- dH= 0 + + +-- | Splice two AVL trees of known height using the supplied bridging element. +-- That is, the bridging element appears \"in the middle\" of the resulting AVL tree. +-- The elements of the first tree argument are to the left of the bridging element and +-- the elements of the second tree are to the right of the bridging element. +-- +-- This function does not require that the AVL 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 :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +-- 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 l hl b r hr = + case COMPAREUINT hl hr of + LT -> spliceHL l hl b r hr + EQ -> UBT2(Z l b r, INCINT1(hl)) + GT -> spliceHR l hl b r hr + +-- Splice two trees of known relative height where hr>hl, using the supplied bridging element, +-- returning another tree of known relative height. +spliceHL :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +spliceHL l hl b r hr = let d = SUBINT(hr,hl) + in if d EQL L(1) then UBT2(N l b r, INCINT1(hr)) + else spliceHL_ hr d l b r + +-- Splice two trees of known relative height where hl>hr, using the supplied bridging element, +-- returning another tree of known relative height. +spliceHR :: AVL e -> UINT -> e -> AVL e -> UINT -> UBT2(AVL e,UINT) +spliceHR l hl b r hr = let d = SUBINT(hl,hr) + in if d EQL L(1) then UBT2(P l b r, INCINT1(hl)) + else spliceHR_ hl d l b r + +-- 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 spliceHL_ #-} +spliceHL_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT) +--spliceHL_ _ _ _ _ E = error "spliceHL_: Bug0" -- impossible if hr>hl +spliceHL_ hr d l b (N rl re rr) = let r_ = spliceLN l b DECINT2(d) rl re rr + in r_ `seq` UBT2(r_,hr) +spliceHL_ hr d l b (Z rl re rr) = let r_ = spliceLZ l b DECINT1(d) rl re rr + in case r_ of +-- E -> error "spliceHL_: Bug1" + Z _ _ _ -> UBT2(r_, hr ) + _ -> UBT2(r_,INCINT1(hr)) +spliceHL_ hr d l b (P rl re rr) = let r_ = spliceLP l b DECINT1(d) rl re rr + in r_ `seq` UBT2(r_,hr) + +-- Splice two trees of known relative height where hl>hr+1, using the supplied bridging element, +-- returning another tree of known relative height. d >= 2 !! +{-# INLINE spliceHR_ #-} +spliceHR_ :: UINT -> UINT -> AVL e -> e -> AVL e -> UBT2(AVL e,UINT) +--spliceHR_ _ _ E _ _ = error "spliceHR_: Bug0" -- impossible if hl>hr +spliceHR_ hl d (N ll le lr) b r = let l_ = spliceRN r b DECINT1(d) ll le lr + in l_ `seq` UBT2(l_,hl) +spliceHR_ hl d (Z ll le lr) b r = let l_ = spliceRZ r b DECINT1(d) ll le lr + in case l_ of +-- E -> error "spliceHR_: Bug1" + Z _ _ _ -> UBT2(l_, hl ) + _ -> UBT2(l_,INCINT1(hl)) +spliceHR_ hl d (P ll le lr) b r = let l_ = spliceRP r b DECINT2(d) ll le lr + in l_ `seq` UBT2(l_,hl) +----------------------------------------------------------------------- +-------------------------- spliceH Ends Here -------------------------- +----------------------------------------------------------------------- + +-- hr >= hl, splice s to left subtree of r, using b as the bridge +-- The Int argument is the absolute difference in tree height, hr-hl (>=0) +spliceL :: AVL e -> e -> UINT -> AVL e -> AVL e +spliceL s b L(0) r = Z s b r +spliceL s b L(1) r = N s b r +spliceL s b d (N rl re rr) = spliceLN s b DECINT2(d) rl re rr -- height diff of rl is two less +spliceL s b d (Z rl re rr) = spliceLZ s b DECINT1(d) rl re rr -- height diff of rl is one less +spliceL s b d (P rl re rr) = spliceLP s b DECINT1(d) rl re rr -- height diff of rl is one less +spliceL _ _ _ E = error "spliceL: Bug0" -- r can't be empty + +-- Splice into left subtree of (N l e r), height cannot change as a result of this +spliceLN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLN s b L(0) l e r = Z (Z s b l) e r -- dH=0 +spliceLN s b L(1) l e r = Z (N s b l) e r -- dH=0 +spliceLN s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` N l_ e r +spliceLN s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr + in case l_ of + Z _ _ _ -> N l_ e r -- dH=0 + P _ _ _ -> Z l_ e r -- dH=0 + _ -> error "spliceLN: Bug0" -- impossible +spliceLN s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` N l_ e r +spliceLN _ _ _ E _ _ = error "spliceLN: Bug1" -- impossible + +-- Splice into left subtree of (Z l e r), Z->P if dH=1, Z->Z if dH=0 +spliceLZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLZ s b L(1) l e r = P (N s b l) e r -- Z->P, dH=1 +spliceLZ s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0 +spliceLZ s b d (Z ll le lr) e r = let l_ = spliceLZ s b DECINT1(d) ll le lr + in case l_ of + Z _ _ _ -> Z l_ e r -- Z->Z, dH=0 + P _ _ _ -> P l_ e r -- Z->P, dH=1 + _ -> error "spliceLZ: Bug0" -- impossible +spliceLZ s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` Z l_ e r -- Z->Z, dH=0 +spliceLZ _ _ _ E _ _ = error "spliceLZ: Bug1" -- impossible + +-- Splice into left subtree of (P l e r), height cannot change as a result of this +spliceLP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceLP s b L(1) (N ll le lr) e r = Z (P s b ll) le (Z lr e r) -- dH=0 +spliceLP s b L(1) (Z ll le lr) e r = Z (Z s b ll) le (Z lr e r) -- dH=0 +spliceLP s b L(1) (P ll le lr) e r = Z (Z s b ll) le (N lr e r) -- dH=0 +spliceLP s b d (N ll le lr) e r = let l_ = spliceLN s b DECINT2(d) ll le lr in l_ `seq` P l_ e r -- dH=0 +spliceLP s b d (Z ll le lr) e r = spliceLPZ s b DECINT1(d) ll le lr e r -- dH=0 +spliceLP s b d (P ll le lr) e r = let l_ = spliceLP s b DECINT1(d) ll le lr in l_ `seq` P l_ e r -- dH=0 +spliceLP _ _ _ E _ _ = error "spliceLP: Bug0" + +-- Splice into left subtree of (P (Z ll le lr) e r) +{-# INLINE spliceLPZ #-} +spliceLPZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e +spliceLPZ s b L(1) ll le lr e r = Z (N s b ll) le (Z lr e r) -- dH=0 +spliceLPZ s b d (N lll lle llr) le lr e r = let ll_ = spliceLN s b DECINT2(d) lll lle llr -- dH=0 + in ll_ `seq` P (Z ll_ le lr) e r +spliceLPZ s b d (Z lll lle llr) le lr e r = let ll_ = spliceLZ s b DECINT1(d) lll lle llr -- dH=0 + in case ll_ of + Z _ _ _ -> P (Z ll_ le lr) e r -- dH=0 + P _ _ _ -> Z ll_ le (Z lr e r) -- dH=0 + _ -> error "spliceLPZ: Bug0" -- impossible +spliceLPZ s b d (P lll lle llr) le lr e r = let ll_ = spliceLP s b DECINT1(d) lll lle llr -- dH=0 + in ll_ `seq` P (Z ll_ le lr) e r +spliceLPZ _ _ _ E _ _ _ _ = error "spliceLPZ: Bug1" +----------------------------------------------------------------------- +-------------------------- spliceL Ends Here -------------------------- +----------------------------------------------------------------------- + +-- hl >= hr, splice s to right subtree of l, using b as the bridge +-- The Int argument is the absolute difference in tree height, hl-hr (>=0) +spliceR :: AVL e -> e -> UINT -> AVL e -> AVL e +spliceR s b L(0) l = Z l b s +spliceR s b L(1) l = P l b s +spliceR s b d (N ll le lr) = spliceRN s b DECINT1(d) ll le lr -- height diff of lr is one less +spliceR s b d (Z ll le lr) = spliceRZ s b DECINT1(d) ll le lr -- height diff of lr is one less +spliceR s b d (P ll le lr) = spliceRP s b DECINT2(d) ll le lr -- height diff of lr is two less +spliceR _ _ _ E = error "spliceR: Bug0" -- l can't be empty + +-- Splice into right subtree of (P l e r), height cannot change as a result of this +spliceRP :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRP s b L(0) l e r = Z l e (Z r b s) -- dH=0 +spliceRP s b L(1) l e r = Z l e (P r b s) -- dH=0 +spliceRP s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` P l e r_ +spliceRP s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr + in case r_ of + Z _ _ _ -> P l e r_ -- dH=0 + N _ _ _ -> Z l e r_ -- dH=0 + _ -> error "spliceRP: Bug0" -- impossible +spliceRP s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` P l e r_ +spliceRP _ _ _ _ _ E = error "spliceRP: Bug1" -- impossible + +-- Splice into right subtree of (Z l e r), Z->N if dH=1, Z->Z if dH=0 +spliceRZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRZ s b L(1) l e r = N l e (P r b s) -- Z->N, dH=1 +spliceRZ s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0 +spliceRZ s b d l e (Z rl re rr) = let r_ = spliceRZ s b DECINT1(d) rl re rr + in case r_ of + Z _ _ _ -> Z l e r_ -- Z->Z, dH=0 + N _ _ _ -> N l e r_ -- Z->N, dH=1 + _ -> error "spliceRZ: Bug0" -- impossible +spliceRZ s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` Z l e r_ -- Z->Z, dH=0 +spliceRZ _ _ _ _ _ E = error "spliceRZ: Bug1" -- impossible + +-- Splice into right subtree of (N l e r), height cannot change as a result of this +spliceRN :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> AVL e +spliceRN s b L(1) l e (N rl re rr) = Z (P l e rl) re (Z rr b s) -- dH=0 +spliceRN s b L(1) l e (Z rl re rr) = Z (Z l e rl) re (Z rr b s) -- dH=0 +spliceRN s b L(1) l e (P rl re rr) = Z (Z l e rl) re (N rr b s) -- dH=0 +spliceRN s b d l e (N rl re rr) = let r_ = spliceRN s b DECINT1(d) rl re rr in r_ `seq` N l e r_ -- dH=0 +spliceRN s b d l e (Z rl re rr) = spliceRNZ s b DECINT1(d) l e rl re rr -- dH=0 +spliceRN s b d l e (P rl re rr) = let r_ = spliceRP s b DECINT2(d) rl re rr in r_ `seq` N l e r_ -- dH=0 +spliceRN _ _ _ _ _ E = error "spliceRN: Bug0" + +-- Splice into right subtree of (N l e (Z rl re rr)) +{-# INLINE spliceRNZ #-} +spliceRNZ :: AVL e -> e -> UINT -> AVL e -> e -> AVL e -> e -> AVL e -> AVL e +spliceRNZ s b L(1) l e rl re rr = Z (Z l e rl) re (P rr b s) -- dH=0 +spliceRNZ s b d l e rl re (N rrl rre rrr) = let rr_ = spliceRN s b DECINT1(d) rrl rre rrr + in rr_ `seq` N l e (Z rl re rr_) -- dH=0 +spliceRNZ s b d l e rl re (Z rrl rre rrr) = let rr_ = spliceRZ s b DECINT1(d) rrl rre rrr -- dH=0 + in case rr_ of + Z _ _ _ -> N l e (Z rl re rr_) -- dH=0 + N _ _ _ -> Z (Z l e rl) re rr_ -- dH=0 + _ -> error "spliceRNZ: Bug0" -- impossible +spliceRNZ s b d l e rl re (P rrl rre rrr) = let rr_ = spliceRP s b DECINT2(d) rrl rre rrr -- dH=0 + in rr_ `seq` N l e (Z rl re rr_) +spliceRNZ _ _ _ _ _ _ _ E = error "spliceRNZ: Bug1" +----------------------------------------------------------------------- +-------------------------- spliceR Ends Here -------------------------- +----------------------------------------------------------------------- diff --git a/Data/Tree/AVL/Internals/HPush.hs b/Data/Tree/AVL/Internals/HPush.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HPush.hs @@ -0,0 +1,189 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HPush +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for pushing elements into trees of known height. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HPush + (pushHL,pushHR,pushHL_,pushHR_, + ) where + +import Data.Tree.AVL.Types(AVL(..)) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | A version of 'pushL' for an AVL tree of known height. Returns an AVL tree 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. +{-# INLINE pushHL #-} +pushHL :: e -> AVL e -> UINT -> UBT2(AVL e,UINT) +pushHL e t h = pushHL_ (Z E e E) t h + +-- | A version of 'pushR' for an AVL tree of known height. Returns an AVL tree 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. +{-# INLINE pushHR #-} +pushHR :: AVL e -> UINT -> e -> UBT2(AVL e,UINT) +pushHR t h e = pushHR_ t h (Z E e E) + +-- | Push a singleton tree (first arg) in the leftmost position of an AVL tree of known height, +-- returning an AVL tree 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. +-- +-- Complexity: O(log n) +pushHL_ :: AVL e -> AVL e -> UINT -> UBT2(AVL e,UINT) +pushHL_ t0 t h = case t of + E -> UBT2(t0, INCINT1(h)) -- Relative Heights + N l e r -> let t_ = putNL l e r in t_ `seq` UBT2(t_,h) + P l e r -> let t_ = putPL l e r in t_ `seq` UBT2(t_,h) + Z l e r -> let t_ = putZL l e r + in case t_ of + Z _ _ _ -> UBT2(t_, h ) + P _ _ _ -> UBT2(t_, INCINT1(h)) + -- _ -> error "pushHL_: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + putNL E e r = Z t0 e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0 + _ -> error "pushHL_: Bug1" -- impossible + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + putZL E e r = P t0 e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> error "pushHL_: Bug2" -- impossible + _ -> P l' e 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 --------- + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + putPL E _ _ = error "pushHL_: Bug3" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putPLL -- + ----------------------------------------------------------------------- + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z t0 le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> error "pushHL_: Bug4" -- impossible + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !! +----------------------------------------------------------------------- +-------------------------- pushHL_ Ends Here -------------------------- +----------------------------------------------------------------------- + + +-- | Push a singleton tree (third arg) in the rightmost position of an AVL tree of known height, +-- returning an AVL tree 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. +-- +-- Complexity: O(log n) +pushHR_ :: AVL e -> UINT -> AVL e -> UBT2(AVL e,UINT) +pushHR_ t h t0 = case t of + E -> UBT2(t0, INCINT1(h)) -- Relative Heights + N l e r -> let t_ = putNR l e r in t_ `seq` UBT2(t_,h) + P l e r -> let t_ = putPR l e r in t_ `seq` UBT2(t_,h) + Z l e r -> let t_ = putZR l e r + in case t_ of + Z _ _ _ -> UBT2(t_, h ) + N _ _ _ -> UBT2(t_, INCINT1(h)) + -- _ -> error "pushHR_: Bug0" -- impossible + where + ----------------------------- LEVEL 2 --------------------------------- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + putZR l e E = N l e t0 -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1 + -- _ -> error "pushHR_: Bug1" -- impossible + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + putPR l e E = Z l e t0 -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + N _ _ _ -> Z l e 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 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + putNR _ _ E = error "pushHR_: Bug3" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re t0 -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + _ -> error "pushHR_: Bug4" -- impossible +----------------------------------------------------------------------- +-------------------------- pushHR_ Ends Here -------------------------- +----------------------------------------------------------------------- + diff --git a/Data/Tree/AVL/Internals/HSet.hs b/Data/Tree/AVL/Internals/HSet.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HSet.hs @@ -0,0 +1,655 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HSet +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Set primitives on AVL trees with (height information supplied where needed). +-- All the functions in this module use essentially the same symetric \"Divide and Conquer\" algorithm. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HSet + (-- * Union primitives. + unionH,unionMaybeH, + + -- * Intersection primitives. + intersectionH,intersectionMaybeH, + + -- * Difference primitives. + differenceH,differenceMaybeH,symDifferenceH, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) + +import Data.COrdering + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Uses the supplied combining comparison to evaluate the union of two sets represented as +-- sorted AVL trees of known height. Whenever the combining comparison is applied, the first +-- comparison argument is an element of the first tree and the second comparison argument is +-- an element of the second tree. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +unionH :: (e -> e -> COrdering e) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +unionH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,e1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,e0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case spliceH m hm e1_ r hr of + UBT2(t,ht) -> spliceH l hl e0_ t ht + -- e0 = e1 + Eq e -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> spliceH l hl e r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,e0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,e1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case spliceH l hl e1_ m hm of + UBT2(t,ht) -> spliceH t ht e0_ r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,e,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), e0, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,e0_,l1_,hl1_) + Eq e0_ -> UBT5(l,hl,e0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,e0_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e0_,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,e,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), e1, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,e1_,l1,hl1) + Eq e1_ -> UBT5(l,hl,e1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,e1_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,e1_,l1_,hl1_) +----------------------------------------------------------------------- +-------------------------- unionH Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | Similar to _unionH_, but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +unionMaybeH :: (e -> e -> COrdering (Maybe e)) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +unionMaybeH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,mbe1_,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,mbe0_,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case (case mbe1_ of + Just e1_ -> spliceH m hm e1_ r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbe0_ of + Just e0_ -> spliceH l hl e0_ t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq mbe -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> case mbe of + Just e -> spliceH l hl e r hr + Nothing -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,mbe0_,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,mbe1_,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case (case mbe1_ of + Just e1_ -> spliceH l hl e1_ m hm + Nothing -> joinH l hl m hm + ) of + UBT2(t,ht) -> case mbe0_ of + Just e0_ -> spliceH t ht e0_ r hr + Nothing -> joinH t ht r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), Just e0, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe0_,l1_,hl1_) + Eq mbe0_ -> UBT5(l,hl,mbe0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbe0_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe0_,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Maybe e,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), Just e1, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbe1_,l1,hl1) + Eq mbe1_ -> UBT5(l,hl,mbe1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbe1_,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbe1_,l1_,hl1_) +----------------------------------------------------------------------- +----------------------- unionMaybeH Ends Here ------------------------- +----------------------------------------------------------------------- + + +-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as +-- sorted AVL trees. This function requires no height information at all for +-- the two tree inputs. The absolute height of the resulting tree is returned also. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +intersectionH :: (a -> b -> COrdering c) -> AVL a -> AVL b -> UBT2(AVL c,UINT) +intersectionH comp = i where + -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT) + i E _ = UBT2(E,L(0)) + i _ E = UBT2(E,L(0)) + i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i_ l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case i rr0 r1 of + UBT2(r,hr) -> case i rl0 lr1 of + UBT2(m,hm) -> case i l0 ll1 of + UBT2(l,hl) -> case (case mbc1 of + Just c1 -> spliceH m hm c1 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc0 of + Just c0 -> spliceH l hl c0 t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq c -> case i l0 l1 of + UBT2(l,hl) -> case i r0 r1 of + UBT2(r,hr) -> spliceH l hl c r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case i r0 rr1 of + UBT2(r,hr) -> case i lr0 rl1 of + UBT2(m,hm) -> case i ll0 l1 of + UBT2(l,hl) -> case (case mbc0 of + Just c0 -> spliceH m hm c0 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc1 of + Just c1 -> spliceH l hl c1 t ht + Nothing -> joinH l hl t ht + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq c0 -> UBT5(l,hl,Just c0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq c1 -> UBT5(l,hl,Just c1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +---------------------- intersectionH Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | Similar to _intersectionH_, but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +intersectionMaybeH :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> UBT2(AVL c,UINT) +intersectionMaybeH comp = i where + -- i :: AVL a -> AVL b -> UBT2(AVL c,UINT) + i E _ = UBT2(E,L(0)) + i _ E = UBT2(E,L(0)) + i (N l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (N l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (Z l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (N l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (Z l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i (P l0 e0 r0) (P l1 e1 r1) = i_ l0 e0 r0 l1 e1 r1 + i_ l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case i rr0 r1 of + UBT2(r,hr) -> case i rl0 lr1 of + UBT2(m,hm) -> case i l0 ll1 of + UBT2(l,hl) -> case (case mbc1 of + Just c1 -> spliceH m hm c1 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc0 of + Just c0 -> spliceH l hl c0 t ht + Nothing -> joinH l hl t ht + -- e0 = e1 + Eq mbc -> case i l0 l1 of + UBT2(l,hl) -> case i r0 r1 of + UBT2(r,hr) -> case mbc of + Just c -> spliceH l hl c r hr + Nothing -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case i r0 rr1 of + UBT2(r,hr) -> case i lr0 rl1 of + UBT2(m,hm) -> case i ll0 l1 of + UBT2(l,hl) -> case (case mbc0 of + Just c0 -> spliceH m hm c0 r hr + Nothing -> joinH m hm r hr + ) of + UBT2(t,ht) -> case mbc1 of + Just c1 -> spliceH l hl c1 t ht + Nothing -> joinH l hl t ht + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq mbc0_ -> UBT5(l,hl,mbc0_,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq mbc1_ -> UBT5(l,hl,mbc1_,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +-------------------- intersectionMaybeH Ends Here --------------------- +----------------------------------------------------------------------- + +-- | Uses the supplied comparison to evaluate the difference between two sets represented as +-- sorted AVL trees. +-- +-- N.B. This function works with relative heights for the first tree and needs no height +-- information for the second tree, so it_s OK to initialise the height of the first to zero, +-- rather than calculating the absolute height. However, if you do this the height of the resulting +-- tree will be incorrect also (it will have the same fixed offset as the first tree). +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +differenceH :: (a -> b -> Ordering) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) +differenceH comp = d where + -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) + d E h0 _ = UBT2(E ,h0) -- Relative heights!! + d t0 h0 E = UBT2(t0,h0) + d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d_ l0 hl0 e0 r0 hr0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkR r0 hr0 e1 of + UBT4(rl0,hrl0, rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_ ,be0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case d rr0 hrr0 r1 of -- right + UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle + UBT2(m,hm) -> case d l0 hl0 ll1 of -- left + UBT2(l,hl) -> case joinH m hm r hr of -- join middle right + UBT2(y,hy) -> if be0 + then spliceH l hl e0 y hy + else joinH l hl y hy + -- e0 = e1 + EQ -> case d r0 hr0 r1 of -- right + UBT2(r,hr) -> case d l0 hl0 l1 of -- left + UBT2(l,hl) -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 of + UBT5(rl1,_ ,be0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT4(ll0,hll0, lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case d r0 hr0 rr1 of -- right + UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle + UBT2(m,hm) -> case d ll0 hll0 l1 of -- left + UBT2(l,hl) -> case joinH l hl m hm of -- join left middle + UBT2(x,hx) -> if be0 + then spliceH x hx e0 r hr + else joinH x hx r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1), and for other algorithmic reasons in this case. + -- N.B. forkL returns True if t1 does not contain e0 (I.E. If e0 is an element of the result). + -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Bool, AVL b, UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,True,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + LT -> case forkL_ l hl of + UBT5(x0,hx0,be0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,be0,x1_,hx1_) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkL_ r hr of + UBT5(x0,hx0,be0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,be0,x1,hx1) + -- N.B. forkR t0, according to e1. Neither of the resulting forks will contain an element + -- which is "equal" to e1. + -- forkR :: AVL a -> UINT -> b -> UBT4(AVL a, UINT, AVL a, UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E h = UBT4(E,h,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + LT -> case forkR_ r hr of + UBT4(x0,hx0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT4(x0_,hx0_,x1,hx1) + EQ -> UBT4(l,hl,r,hr) -- e1 is dropped. + GT -> case forkR_ l hl of + UBT4(x0,hx0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT4(x0,hx0,x1_,hx1_) +----------------------------------------------------------------------- +----------------------- differenceH Ends Here ------------------------- +----------------------------------------------------------------------- + +-- | Similar to _differenceH_, but the resulting tree also includes those elements a\_ for which the +-- combining comparison returns @Eq (Just a\_)@. +-- +-- N.B. This function works with relative heights for the first tree and needs no height +-- information for the second tree, so it_s OK to initialise the height of the first to zero, +-- rather than calculating the absolute height. However, if you do this the height of the resulting +-- tree will be incorrect also (it will have the same fixed offset as the first tree). +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +differenceMaybeH :: (a -> b -> COrdering (Maybe a)) -> AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) +differenceMaybeH comp = d where + -- d :: AVL a -> UINT -> AVL b -> UBT2(AVL a,UINT) + d E h0 _ = UBT2(E ,h0) -- Relative heights!! + d t0 h0 E = UBT2(t0,h0) + d (N l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (N l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (Z l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (N l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (Z l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d (P l0 e0 r0) h0 (P l1 e1 r1) = d_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 e1 r1 + d_ l0 hl0 e0 r0 hr0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 hr0 e1 of + UBT5( rl0,hrl0,mbe1,rr0,hrr0) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_ ,mbe0,lr1,_ ) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case d rr0 hrr0 r1 of -- right + UBT2(r,hr) -> case d rl0 hrl0 lr1 of -- middle + UBT2(m,hm) -> case d l0 hl0 ll1 of -- left + UBT2(l,hl) -> case (case mbe1 of + Just e1_ -> spliceH m hm e1_ r hr -- splice middle right with e1_ + Nothing -> joinH m hm r hr) of -- join middle right + UBT2(y,hy) -> case mbe0 of + Just e0_ -> spliceH l hl e0_ y hy + Nothing -> joinH l hl y hy + -- e0 = e1 + Eq mbe0 -> case d r0 hr0 r1 of -- right + UBT2(r,hr) -> case d l0 hl0 l1 of -- left + UBT2(l,hl) -> case mbe0 of + Just e0_ -> spliceH l hl e0_ r hr -- retain updated e0 + Nothing -> joinH l hl r hr -- discard original e0 + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5( rl1,_ ,mbe0,rr1,_ ) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,mbe1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case d r0 hr0 rr1 of -- right + UBT2(r,hr) -> case d lr0 hlr0 rl1 of -- middle + UBT2(m,hm) -> case d ll0 hll0 l1 of -- left + UBT2(l,hl) -> case (case mbe1 of + Just e1_ -> spliceH l hl e1_ m hm -- splice left middle with e1_ + Nothing -> joinH l hl m hm) of -- join left middle + UBT2(x,hx) -> case mbe0 of + Just e0_ -> spliceH x hx e0_ r hr + Nothing -> joinH x hx r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1), and for other algorithmic reasons in this case. + -- N.B. forkL returns (Just e0) if t1 does not contain e0 (I.E. If original e0 is an element of the result). + -- forkL :: a -> AVL b -> UBT5(AVL b, UINT, Maybe a, AVL b, UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Just e0,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe0,x1_,hx1_) + Eq mbe0 -> UBT5(l,hl,mbe0,r,hr) + Gt -> case forkL_ r hr of + UBT5(x0,hx0,mbe0,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe0,x1,hx1) + -- N.B. forkR t0, according to e1. Returns Nothing if t0 does not contain e1. + -- forkR :: AVL a -> UINT -> b -> UBT5(AVL a, UINT, Maybe a, AVL a, UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH l hl e x0 hx0 of + UBT2(x0_,hx0_) -> UBT5(x0_,hx0_,mbe1,x1,hx1) + Eq mbe1 -> UBT5(l,hl,mbe1,r,hr) + Gt -> case forkR_ l hl of + UBT5(x0,hx0,mbe1,x1,hx1) -> case spliceH x1 hx1 e r hr of + UBT2(x1_,hx1_) -> UBT5(x0,hx0,mbe1,x1_,hx1_) +----------------------------------------------------------------------- +--------------------- differenceMaybeH Ends Here ---------------------- +----------------------------------------------------------------------- + +-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/. +-- +-- Complexity: Not sure, but I_d appreciate it if someone could figure it out. +symDifferenceH :: (e -> e -> Ordering) -> AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) +symDifferenceH c = u where + -- u :: AVL e -> UINT -> AVL e -> UINT -> UBT2(AVL e,UINT) + u E _ t1 h1 = UBT2(t1,h1) + u t0 h0 E _ = UBT2(t0,h0) + u (N l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (N l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT2(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (Z l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (Z l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT1(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u (P l0 e0 r0) h0 (N l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT2(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (Z l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT1(h1) + u (P l0 e0 r0) h0 (P l1 e1 r1) h1 = u_ l0 DECINT1(h0) e0 r0 DECINT2(h0) l1 DECINT1(h1) e1 r1 DECINT2(h1) + u_ l0 hl0 e0 r0 hr0 l1 hl1 e1 r1 hr1 = + case c e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkR r0 hr0 e1 of + UBT5(rl0,hrl0,be1,rr0,hrr0) -> case forkL e0 l1 hl1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,hll1,be0,lr1,hlr1) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + case u l0 hl0 ll1 hll1 of + UBT2(l,hl) -> case u rl0 hrl0 lr1 hlr1 of + UBT2(m,hm) -> case u rr0 hrr0 r1 hr1 of + UBT2(r,hr) -> case (if be1 then spliceH m hm e1 r hr + else joinH m hm r hr + ) of + UBT2(t,ht) -> if be0 then spliceH l hl e0 t ht + else joinH l hl t ht + -- e0 = e1 + EQ -> case u l0 hl0 l1 hl1 of + UBT2(l,hl) -> case u r0 hr0 r1 hr1 of + UBT2(r,hr) -> joinH l hl r hr + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 hr1 of + UBT5(rl1,hrl1,be0,rr1,hrr1) -> case forkR l0 hl0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,hll0,be1,lr0,hlr0) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + case u ll0 hll0 l1 hl1 of + UBT2(l,hl) -> case u lr0 hlr0 rl1 hrl1 of + UBT2(m,hm) -> case u r0 hr0 rr1 hrr1 of + UBT2(r,hr) -> case (if be1 then spliceH l hl e1 m hm + else joinH l hl m hm + ) of + UBT2(t,ht) -> if be0 then spliceH t ht e0 r hr + else joinH t ht r hr + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: e -> AVL e -> UINT -> UBT5(AVL e,UINT,Bool,AVL e,UINT) + forkL e0 t1 ht1 = forkL_ t1 ht1 where + forkL_ E _ = UBT5(E, L(0), True, E, L(0)) + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case c e0 e of + LT -> case forkL_ l hl of + UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,be0,l1_,hl1_) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkL_ r hr of + UBT5(l0,hl0,be0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be0,l1,hl1) + -- forkR :: AVL e -> UINT -> e -> UBT5(AVL e,UINT,Bool,AVL e,UINT) + forkR t0 ht0 e1 = forkR_ t0 ht0 where + forkR_ E _ = UBT5(E, L(0), True, E, L(0)) + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case c e e1 of + LT -> case forkR_ r hr of + UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,be1,l1,hl1) + EQ -> UBT5(l,hl,False,r,hr) + GT -> case forkR_ l hl of + UBT5(l0,hl0,be1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,be1,l1_,hl1_) +----------------------------------------------------------------------- +----------------------- symDifferenceH Ends Here ---------------------- +----------------------------------------------------------------------- diff --git a/Data/Tree/AVL/Internals/HeightUtils.hs b/Data/Tree/AVL/Internals/HeightUtils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Internals/HeightUtils.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Internals.HeightUtils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL tree height related utilities. +-- +-- The functions defined here are not exported by the main Data.Tree.AVL module +-- because they violate the policy for AVL tree equality used elsewhere in this library. +-- You need to import this module explicitly if you want to use any of these functions. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Internals.HeightUtils + (height,addHeight,compareHeight, -- heightInt, + fastAddSize, + ) where + +import Data.Tree.AVL.Types(AVL(..)) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- {-# INLINE heightInt #-} -- Don't want this +-- heightInt :: AVL e -> Int +-- heightInt t = ASINT(addHeight L(0) t) + +-- | Determine the height of an AVL tree. +-- +-- Complexity: O(log n) +{-# INLINE height #-} +height :: AVL e -> UINT +height t = addHeight L(0) t + +-- | Adds the height of a tree to the first argument. +-- +-- Complexity: O(log n) +addHeight :: UINT -> AVL e -> UINT +addHeight h E = h +addHeight h (N l _ _) = addHeight INCINT2(h) l +addHeight h (Z l _ _) = addHeight INCINT1(h) l +addHeight h (P _ _ r) = addHeight INCINT2(h) r + +-- | A fast algorithm for comparing the heights of two trees. This algorithm avoids the need +-- to compute the heights of both trees and should offer better performance if the trees differ +-- significantly in height. But if you need the heights anyway it will be quicker to just evaluate +-- them both and compare the results. +-- +-- Complexity: O(log n), where n is the size of the smaller of the two trees. +compareHeight :: AVL a -> AVL b -> Ordering +compareHeight = ch L(0) where -- d = hA-hB + ch :: UINT -> AVL a -> AVL b -> Ordering + ch d E E = COMPAREUINT d L(0) + ch d E (N l1 _ _ ) = chA DECINT2(d) l1 + ch d E (Z l1 _ _ ) = chA DECINT1(d) l1 + ch d E (P _ _ r1) = chA DECINT2(d) r1 + ch d (N l0 _ _ ) E = chB INCINT2(d) l0 + ch d (N l0 _ _ ) (N l1 _ _ ) = ch d l0 l1 + ch d (N l0 _ _ ) (Z l1 _ _ ) = ch INCINT1(d) l0 l1 + ch d (N l0 _ _ ) (P _ _ r1) = ch d l0 r1 + ch d (Z l0 _ _ ) E = chB INCINT1(d) l0 + ch d (Z l0 _ _ ) (N l1 _ _ ) = ch DECINT1(d) l0 l1 + ch d (Z l0 _ _ ) (Z l1 _ _ ) = ch d l0 l1 + ch d (Z l0 _ _ ) (P _ _ r1) = ch DECINT1(d) l0 r1 + ch d (P _ _ r0) E = chB INCINT2(d) r0 + ch d (P _ _ r0) (N l1 _ _ ) = ch d r0 l1 + ch d (P _ _ r0) (Z l1 _ _ ) = ch INCINT1(d) r0 l1 + ch d (P _ _ r0) (P _ _ r1) = ch d r0 r1 + -- Tree A ended first, continue with Tree B until hA-hB<0, or Tree B ends + chA d tB = case COMPAREUINT d L(0) of + LT -> LT + EQ -> case tB of + E -> EQ + _ -> LT + GT -> case tB of + E -> GT + N l _ _ -> chA DECINT2(d) l + Z l _ _ -> chA DECINT1(d) l + P _ _ r -> chA DECINT2(d) r + -- Tree B ended first, continue with Tree A until hA-hB>0, or Tree A ends + chB d tA = case COMPAREUINT d L(0) of + GT -> GT + EQ -> case tA of + E -> EQ + _ -> GT + LT -> case tA of + E -> LT + N l _ _ -> chB INCINT2(d) l + Z l _ _ -> chB INCINT1(d) l + P _ _ r -> chB INCINT2(d) r + + +{----------------------------------------- +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)) +------------------------------------------} + +-- | Fast algorithm to calculate size. This avoids visiting about 50% of tree nodes +-- by using fact that trees with small heights can only have particular shapes. +-- So it's still O(n), but with substantial saving in constant factors. +-- +-- Complexity: O(n) +fastAddSize :: UINT -> AVL e -> UINT +fastAddSize n E = n +fastAddSize n (N l _ r) = case addHeight L(2) l of + L(2) -> INCINT2(n) + h -> fasN n h l r +fastAddSize n (Z l _ r) = case addHeight L(1) l of + L(1) -> INCINT1(n) + L(2) -> INCINT3(n) + h -> fasZ n h l r +fastAddSize n (P l _ r) = case addHeight L(2) r of + L(2) -> INCINT2(n) + h -> fasP n h l r + +-- Local utilities used by fastAddSize, Only work if h >=3 !! +fasN,fasZ,fasP :: UINT -> UINT -> AVL e -> AVL e -> UINT +fasN n L(3) _ r = fas INCINT2(n) L(2) r +fasN n h l r = fas (fas INCINT1(n) DECINT2(h) l) DECINT1(h) r -- h>=4 +fasZ n h l r = fas (fas INCINT1(n) DECINT1(h) l) DECINT1(h) r +fasP n L(3) l _ = fas INCINT2(n) L(2) l +fasP n h l r = fas (fas INCINT1(n) DECINT2(h) r) DECINT1(h) l -- h>=4 + +-- Local Utility used by fasN,fasZ,fasP, Only works if h >= 2 !! +fas :: UINT -> UINT -> AVL e -> UINT +fas _ L(2) E = error "fas: Bug0" +fas n L(2) (N _ _ _) = INCINT2(n) +fas n L(2) (Z _ _ _) = INCINT3(n) +fas n L(2) (P _ _ _) = INCINT2(n) +-- 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" + diff --git a/Data/Tree/AVL/Join.hs b/Data/Tree/AVL/Join.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Join.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Join +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for joining AVL trees. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Join + (-- * Joining trees. + join,concatAVL,flatConcat, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Size(addSize) +import Data.Tree.AVL.List(asTreeLenL,toListL) +import Data.Tree.AVL.Internals.DelUtils(popHLN,popHLZ,popHLP) +import Data.Tree.AVL.Internals.HeightUtils(height,addHeight) +import Data.Tree.AVL.Internals.HJoin(joinH',spliceH) + +import Data.List(foldl') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Join two AVL trees. This is the AVL equivalent of (++). +-- +-- > asListL (l `join` r) = asListL l ++ asListL r +-- +-- Complexity: O(log n), where n is the size of the larger of the two trees. +join :: AVL e -> AVL e -> AVL e +join l r = joinH' l (height l) r (height r) + +-- Specialised list of AVL trees of known height, with leftmost element popped. +-- (used by concatAVL). +data HAVLS e = HE | H e (AVL e) UINT (HAVLS e) + +-- | Concatenate a /finite/ list of AVL trees. During construction of the resulting tree the +-- input list is consumed lazily, but it will be consumed entirely before the result is returned. +-- +-- > asListL (concatAVL avls) = concatMap asListL avls +-- +-- Complexity: Umm..Dunno. Uses a divide and conquer approach to splice adjacent pairs of +-- trees in the list recursively, until only one tree remains. The complexity of each splice +-- is proportional to the difference in tree heights. +concatAVL :: [AVL e] -> AVL e +concatAVL [] = E +concatAVL ( E :ts) = concatAVL ts +concatAVL (t@(N l _ _):ts) = concatHAVLS t (addHeight L(2) l) (mkHAVLS ts) +concatAVL (t@(Z l _ _):ts) = concatHAVLS t (addHeight L(1) l) (mkHAVLS ts) +concatAVL (t@(P _ _ r):ts) = concatHAVLS t (addHeight L(2) r) (mkHAVLS ts) + +-- Recursively call mergePairs until only one tree remains. +-- The head of the current list has to be treated specially becuase it has no associated +-- bridging element. +concatHAVLS :: AVL e -> UINT -> HAVLS e -> AVL e +concatHAVLS l _ HE = l +concatHAVLS l hl (H e r hr hs) = case mergePairs l hl e r hr hs of + UBT3(t,ht,hs_) -> concatHAVLS t ht hs_ + + +-- Merge adjacent pairs in the current list. +-- The head of the current list has to be treated specially becuase it has no associated +-- bridging element. +-- This function is strict in both elements of the result pair. +{-# INLINE mergePairs #-} +mergePairs :: AVL e -> UINT -> e -> AVL e -> UINT -> HAVLS e -> UBT3(AVL e,UINT,HAVLS e) +mergePairs l hl e r hr hs = case spliceH l hl e r hr of + UBT2(t,ht) -> case hs of + HE -> UBT3(t,ht,HE) + H e_ t_ ht_ hs_ -> let hs__ = mergePairs_ e_ t_ ht_ hs_ + in hs__ `seq` UBT3(t,ht,hs__) + +-- Deals with the rest of mergePairs after the head of the current list has been dealt with. +-- This function is strict in the resulting list head and lazy in the tail. +mergePairs_ :: e -> AVL e -> UINT -> HAVLS e -> HAVLS e +mergePairs_ e l hl HE = H e l hl HE +mergePairs_ e l hl (H e_ r hr hs) = case spliceH l hl e_ r hr of + UBT2(t,ht) -> case hs of + HE -> H e t ht HE + H e__ r_ hr_ hs_ -> H e t ht (mergePairs_ e__ r_ hr_ hs_) + +-- Uses popHL to get the leftmost element from each tree and calculate the (popped) tree height. +-- The popped element is used as a bridging element for splicing purposes. +-- Empty and singleton trees get special treatment. +-- This function is strict in the resulting list head and lazy in the tail. +mkHAVLS :: [AVL e] -> HAVLS e +mkHAVLS [] = HE +mkHAVLS ( E :ts) = mkHAVLS ts -- Discard empty trees +mkHAVLS ((N l e r):ts) = case popHLN l e r of -- Never a singlton with N + UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts) +mkHAVLS ((Z l e r):ts) = case popHLZ l e r of + UBT3(e_,t,ht) -> if ht EQL L(0) + then mkHAVLS_ e_ ts -- Deal with singleton + else H e_ t ht (mkHAVLS ts) -- Otherwise treat as normal +mkHAVLS ((P l e r):ts) = case popHLP l e r of -- Never a singlton with P + UBT3(e_,t,ht) -> H e_ t ht (mkHAVLS ts) +-- Deals with singletons (avoids unnecessary popHL in next in list) +mkHAVLS_ :: e -> [AVL e] -> HAVLS e +mkHAVLS_ e [] = H e E L(0) HE -- End of list reached anyway +mkHAVLS_ e ( E :ts) = mkHAVLS_ e ts -- Discard empty trees +mkHAVLS_ e (t@(N l _ _):ts) = H e t (addHeight L(2) l) (mkHAVLS ts) +mkHAVLS_ e (t@(Z l _ _):ts) = H e t (addHeight L(1) l) (mkHAVLS ts) +mkHAVLS_ e (t@(P _ _ r):ts) = H e t (addHeight L(2) r) (mkHAVLS ts) +----------------------------------------------------------------------- +---------------------- concatAVL Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Similar to 'concatAVL', except the resulting tree is flat. +-- This function evaluates the entire list of trees before constructing the result. +-- +-- Complexity: O(n), where n is the total number of elements in the resulting tree. +flatConcat :: [AVL e] -> AVL e +flatConcat avls = asTreeLenL (foldl' addSize 0 avls) (foldr toListL [] avls) diff --git a/Data/Tree/AVL/List.hs b/Data/Tree/AVL/List.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/List.hs @@ -0,0 +1,652 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.List +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- List related utilities for AVL trees. +----------------------------------------------------------------------------- +module Data.Tree.AVL.List + (-- * Converting AVL trees to Lists (fixed element order). + -- | These functions are lazy and allow normal lazy list processing + -- style to be used (without necessarily converting the entire tree + -- to a list in one gulp). + asListL,toListL,asListR,toListR, + + -- * Converting Lists to AVL trees (fixed element order). + asTreeLenL,asTreeL, + asTreeLenR,asTreeR, + + -- * Converting unsorted Lists to sorted AVL trees. + genAsTree, + + -- * Pushing unsorted Lists in sorted AVL trees. + genPushList, + + -- * Some analogues of common List functions. + reverseAVL,mapAVL,mapAVL', + traverseAVL, + + replicateAVL,filterViaList,mapMaybeViaList, + partitionAVL, + + -- * Folds + -- | Note that unlike folds over lists ('foldr' and 'foldl'), there is no + -- significant difference between left and right folds in AVL trees, other + -- than which side of the tree each starts with. Both involve tail and non-tail recursion. + -- Therefore this library provides strict and lazy versions of both. + foldrAVL,foldrAVL',foldr1AVL,foldr1AVL',foldr2AVL,foldr2AVL', + foldlAVL,foldlAVL',foldl1AVL,foldl1AVL',foldl2AVL,foldl2AVL', + + -- * Tree flattening utilities. + -- | None of these functions preserve the tree shape (of course). + flatten, + flatReverse,flatMap,flatMap', + + -- * Sorting. + -- | Nothing to do with AVL trees really. But using AVL trees do give an O(n.(log n)) sort + -- algorithm for free, so here it is. These functions all consume the entire + -- input list to construct a sorted AVL tree and then read the elements out as a list (lazily). + genSortAscending,genSortDescending, + + ) where + +import Prelude -- so haddock finds the symbols there +import Control.Applicative hiding (empty) + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..),empty) +import Data.Tree.AVL.Size(size) +import Data.Tree.AVL.Push(genPush) + +import Data.Bits(shiftR,(.&.)) +import Data.List(foldl') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | List AVL tree contents in left to right order. +-- The resulting list in ascending order if the tree is sorted. +-- +-- Complexity: O(n) +asListL :: AVL e -> [e] +asListL avl = toListL avl [] + +-- | Join the AVL tree contents to an existing list in left to right order. +-- This is a ++ free function which behaves as if defined thusly.. +-- +-- > avl `toListL` as = (asListL avl) ++ as +-- +-- Complexity: O(n) +toListL :: AVL e -> [e] -> [e] +toListL E es = es +toListL (N l e r) es = toListL' l e r es +toListL (Z l e r) es = toListL' l e r es +toListL (P l e r) es = toListL' l e r es +toListL' :: AVL e -> e -> AVL e -> [e] -> [e] +toListL' l e r es = toListL l (e:(toListL r es)) + +-- | List AVL tree contents in right to left order. +-- The resulting list in descending order if the tree is sorted. +-- +-- Complexity: O(n) +asListR :: AVL e -> [e] +asListR avl = toListR avl [] + +-- | Join the AVL tree contents to an existing list in right to left order. +-- This is a ++ free function which behaves as if defined thusly.. +-- +-- > avl `toListR` as = (asListR avl) ++ as +-- +-- Complexity: O(n) +toListR :: AVL e -> [e] -> [e] +toListR E es = es +toListR (N l e r) es = toListR' l e r es +toListR (Z l e r) es = toListR' l e r es +toListR (P l e r) es = toListR' l e r es +toListR' :: AVL e -> e -> AVL e -> [e] -> [e] +toListR' l e r es = toListR r (e:(toListR l es)) + +-- | The AVL equivalent of 'foldr' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's second argument will result in O(n) +-- stack use. See 'foldrAVL'' for a strict version. +-- +-- It behaves as if defined.. +-- +-- > foldrAVL f a avl = foldr f a (asListL avl) +-- +-- For example, the 'asListL' function could be defined.. +-- +-- > asListL = foldrAVL (:) [] +-- +-- Complexity: O(n) +foldrAVL :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = foldU (f e (foldU a r)) l + +-- | The strict version of 'foldrAVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldrAVL' :: (e -> a -> a) -> a -> AVL e -> a +foldrAVL' f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = let a' = foldU a r + a'' = f e a' + in a' `seq` a'' `seq` foldU a'' l + +-- | The AVL equivalent of 'foldr1' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's second argument will result in O(n) +-- stack use. See 'foldr1AVL'' for a strict version. +-- +-- > foldr1AVL f avl = foldr1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldr1AVL :: (e -> e -> e) -> AVL e -> e +foldr1AVL f = foldU where + foldU E = error "foldr1AVL: Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = foldrAVL f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldrAVL f e l + foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr1AVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldr1AVL' :: (e -> e -> e) -> AVL e -> e +foldr1AVL' f = foldU where + foldU E = error "foldr1AVL': Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = let a = foldU r + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + -- Use this when r might be E + foldW l e E = foldrAVL' f e l + foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = let a = foldW rl re rr + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + +-- | This fold is a hybrid between 'foldrAVL' and 'foldr1AVL'. As with 'foldr1AVL', it requires +-- a non-empty tree, but instead of treating the rightmost element as an initial value, it applies +-- a function to it (second function argument) and uses the result instead. This allows +-- a more flexible type for the main folding function (same type as that used by 'foldrAVL'). +-- As with 'foldrAVL' and 'foldr1AVL', this function is lazy, so it's best not to use it with functions +-- that are strict in their second argument. See 'foldr2AVL'' for a strict version. +-- +-- Complexity: O(n) +foldr2AVL :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL f g = foldU where + foldU E = error "foldr2AVL: Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = foldrAVL f (f e (foldU r)) l + -- Use this when r might be E + foldW l e E = foldrAVL f (g e) l + foldW l e (N rl re rr) = foldrAVL f (f e (foldV rl re rr)) l -- rr can't be E + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = foldrAVL f (f e (foldW rl re rr)) l + +-- | The strict version of 'foldr2AVL', which is useful for functions which are strict in their second +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldr2AVL' :: (e -> a -> a) -> (e -> a) -> AVL e -> a +foldr2AVL' f g = foldU where + foldU E = error "foldr2AVL': Empty Tree" + foldU (N l e r) = foldV l e r -- r can't be E + foldU (Z l e r) = foldW l e r -- r might be E + foldU (P l e r) = foldW l e r -- r might be E + -- Use this when r can't be E + foldV l e r = let a = foldU r + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + -- Use this when r might be E + foldW l e E = let a = g e in a `seq` foldrAVL' f a l + foldW l e (N rl re rr) = let a = foldV rl re rr -- rr can't be E + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + foldW l e (Z rl re rr) = foldX l e rl re rr -- rr might be E + foldW l e (P rl re rr) = foldX l e rl re rr -- rr might be E + -- Common code for foldW (Z and P cases) + foldX l e rl re rr = let a = foldW rl re rr + a' = f e a + in a `seq` a' `seq` foldrAVL' f a' l + + +-- | The AVL equivalent of 'foldl' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's first argument will result in O(n) +-- stack use. See 'foldlAVL'' for a strict version. +-- +-- > foldlAVL f a avl = foldl f a (asListL avl) +-- +-- For example, the 'asListR' function could be defined.. +-- +-- > asListR = foldlAVL (flip (:)) [] +-- +-- Complexity: O(n) +foldlAVL :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = foldU (f (foldU a l) e) r + +-- | The strict version of 'foldlAVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldlAVL' :: (a -> e -> a) -> a -> AVL e -> a +foldlAVL' f = foldU where + foldU a E = a + foldU a (N l e r) = foldV a l e r + foldU a (Z l e r) = foldV a l e r + foldU a (P l e r) = foldV a l e r + foldV a l e r = let a' = foldU a l + a'' = f a' e + in a' `seq` a'' `seq` foldU a'' r + +-- | The AVL equivalent of 'foldl1' on lists. This is a the lazy version (as lazy as the folding function +-- anyway). Using this version with a function that is strict in it's first argument will result in O(n) +-- stack use. See 'foldl1AVL'' for a strict version. +-- +-- > foldl1AVL f avl = foldl1 f (asListL avl) +-- +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(n) +foldl1AVL :: (e -> e -> e) -> AVL e -> e +foldl1AVL f = foldU where + foldU E = error "foldl1AVL: Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = foldlAVL f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldlAVL f e r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl1AVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldl1AVL' :: (e -> e -> e) -> AVL e -> e +foldl1AVL' f = foldU where + foldU E = error "foldl1AVL': Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = let a = foldU l + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Use this when l might be E + foldW E e r = foldlAVL' f e r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = let a = foldW ll le lr + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + +-- | This fold is a hybrid between 'foldlAVL' and 'foldl1AVL'. As with 'foldl1AVL', it requires +-- a non-empty tree, but instead of treating the leftmost element as an initial value, it applies +-- a function to it (second function argument) and uses the result instead. This allows +-- a more flexible type for the main folding function (same type as that used by 'foldlAVL'). +-- As with 'foldlAVL' and 'foldl1AVL', this function is lazy, so it's best not to use it with functions +-- that are strict in their first argument. See 'foldl2AVL'' for a strict version. +-- +-- Complexity: O(n) +foldl2AVL :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL f g = foldU where + foldU E = error "foldl2AVL: Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = foldlAVL f (f (foldU l) e) r + -- Use this when l might be E + foldW E e r = foldlAVL f (g e) r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = foldlAVL f (f (foldV ll le lr) e) r -- ll can't be E + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = foldlAVL f (f (foldW ll le lr) e) r + +-- | The strict version of 'foldl2AVL', which is useful for functions which are strict in their first +-- argument. The advantage of this version is that it reduces the stack use from the O(n) that the lazy +-- version gives (when used with strict functions) to O(log n). +-- +-- Complexity: O(n) +foldl2AVL' :: (a -> e -> a) -> (e -> a) -> AVL e -> a +foldl2AVL' f g = foldU where + foldU E = error "foldl2AVL': Empty Tree" + foldU (N l e r) = foldW l e r -- l might be E + foldU (Z l e r) = foldW l e r -- l might be E + foldU (P l e r) = foldV l e r -- l can't be E + -- Use this when l can't be E + foldV l e r = let a = foldU l + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Use this when l might be E + foldW E e r = let a = g e in a `seq` foldlAVL' f a r + foldW (N ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (Z ll le lr) e r = foldX ll le lr e r -- ll might be E + foldW (P ll le lr) e r = let a = foldV ll le lr -- ll can't be E + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + -- Common code for foldW (Z and P cases) + foldX ll le lr e r = let a = foldW ll le lr + a' = f a e + in a `seq` a' `seq` foldlAVL' f a' r + + +-- | Convert a list of known length into an AVL tree, such that the head of the list becomes +-- the leftmost tree element. The resulting tree is flat (and also sorted if the supplied list +-- is sorted in ascending order). +-- +-- If the actual length of the list is not the same as the supplied length then +-- an error will be raised. +-- +-- Complexity: O(n) +asTreeLenL :: Int -> [e] -> AVL e +asTreeLenL n es = case subst (replicateAVL n ()) es of + UBT2(tree,es_) -> case es_ of + [] -> tree + _ -> error "asTreeLenL: List too long." + where + -- Substitute template values for real values taken from the list + subst E as = UBT2(E,as) + subst (N l _ r) as = subst' N l r as + subst (Z l _ r) as = subst' Z l r as + subst (P l _ r) as = subst' P l r as + {-# INLINE subst' #-} + subst' f l r as = case subst l as of + UBT2(l_,xs) -> case xs of + a:as' -> case subst r as' of + UBT2(r_,as__) -> let t_ = f l_ a r_ + in t_ `seq` UBT2(t_,as__) +-- [] -> error "asTreeLenL: List too short." + + +-- | As 'asTreeLenL', except the length of the list is calculated internally, not supplied +-- as an argument. +-- +-- Complexity: O(n) +asTreeL :: [e] -> AVL e +asTreeL es = asTreeLenL (length es) es + +-- | Convert a list of known length into an AVL tree, such that the head of the list becomes +-- the rightmost tree element. The resulting tree is flat (and also sorted if the supplied list +-- is sorted in descending order). +-- +-- If the actual length of the list is not the same as the supplied length then +-- an error will be raised. +-- +-- Complexity: O(n) +asTreeLenR :: Int -> [e] -> AVL e +asTreeLenR n es = case subst (replicateAVL n ()) es of + UBT2(tree,es_) -> case es_ of + [] -> tree + _ -> error "asTreeLenR: List too long." + where + -- Substitute template values for real values taken from the list + subst E as = UBT2(E,as) + subst (N l _ r) as = subst' N l r as + subst (Z l _ r) as = subst' Z l r as + subst (P l _ r) as = subst' P l r as + {-# INLINE subst' #-} + subst' f l r as = case subst r as of + UBT2(r_,xs) -> case xs of + a:as' -> case subst l as' of + UBT2(l_,as__) -> let t_ = f l_ a r_ + in t_ `seq` UBT2(t_,as__) + [] -> error "asTreeLenR: List too short." + +-- | As 'asTreeLenR', except the length of the list is calculated internally, not supplied +-- as an argument. +-- +-- Complexity: O(n) +asTreeR :: [e] -> AVL e +asTreeR es = asTreeLenR (length es) es + +-- | Reverse an AVL tree (swaps and reverses left and right sub-trees). +-- The resulting tree is the mirror image of the original. +-- +-- Complexity: O(n) +reverseAVL :: AVL e -> AVL e +reverseAVL E = E +reverseAVL (N l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` P r' e l' +reverseAVL (Z l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` Z r' e l' +reverseAVL (P l e r) = let l' = reverseAVL l + r' = reverseAVL r + in l' `seq` r' `seq` N r' e l' + +-- | Apply a function to every element in an AVL tree. This function preserves the tree shape. +-- There is also a strict version of this function ('mapAVL''). +-- +-- N.B. If the tree is sorted the result of this operation will only be sorted if +-- the applied function preserves ordering (for some suitable ordering definition). +-- +-- Complexity: O(n) +mapAVL :: (a -> b) -> AVL a -> AVL b +mapAVL f = map' where + map' E = E + map' (N l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` N l' (f a) r' + map' (Z l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` Z l' (f a) r' + map' (P l a r) = let l' = map' l + r' = map' r + in l' `seq` r' `seq` P l' (f a) r' + +-- | Similar to 'mapAVL', but the supplied function is applied strictly. +-- +-- Complexity: O(n) +mapAVL' :: (a -> b) -> AVL a -> AVL b +mapAVL' f = map' where + map' E = E + map' (N l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` N l' b r' + map' (Z l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` Z l' b r' + map' (P l a r) = let l' = map' l + r' = map' r + b = f a + in b `seq` l' `seq` r' `seq` P l' b r' + +traverseAVL :: Applicative f => (a -> f b) -> AVL a -> f (AVL b) +traverseAVL _f E = pure E +traverseAVL f (N l v r) = N <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (Z l v r) = Z <$> traverseAVL f l <*> f v <*> traverseAVL f r +traverseAVL f (P l v r) = P <$> traverseAVL f l <*> f v <*> traverseAVL f r + +-- | Construct a flat AVL tree of size n (n>=0), where all elements are identical. +-- +-- Complexity: O(log n) +replicateAVL :: Int -> e -> AVL e +replicateAVL m e = rep m where -- Functional spaghetti follows :-) + 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 n = let sub = rep (n `shiftR` 1) in Z sub e sub + -- n is known to be even (>=0) + 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` Z l e r + else let l = repOdd nl -- right sub-tree is even, so left is odd (>=2) + r = repEvn nr + in l `seq` r `seq` Z l e r + -- n is an exact power of 2 (or 0), I.E. 0,1,2,4,8,16.. + repP2 0 = E + repP2 1 = Z E e E + 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` P l e r -- BF=+1 + -- n is one less than an exact power of 2, I.E. 0,1,3,7,15.. + repP2M1 0 = E + repP2M1 n = let sub = repP2M1 (n `shiftR` 1) in sub `seq` Z sub e sub + +-- | Flatten an AVL tree, preserving the ordering of the tree elements. +-- +-- Complexity: O(n) +flatten :: AVL e -> AVL e +flatten t = asTreeLenL (size t) (asListL t) + +-- | Similar to 'flatten', but the tree elements are reversed. This function has higher constant +-- factor overhead than 'reverseAVL'. +-- +-- Complexity: O(n) +flatReverse :: AVL e -> AVL e +flatReverse t = asTreeLenL (size t) (asListR t) + +-- | Similar to 'mapAVL', but the resulting tree is flat. +-- This function has higher constant factor overhead than 'mapAVL'. +-- +-- Complexity: O(n) +flatMap :: (a -> b) -> AVL a -> AVL b +flatMap f t = asTreeLenL (size t) (map f (asListL t)) + +-- | Same as 'flatMap', but the supplied function is applied strictly. +-- +-- Complexity: O(n) +flatMap' :: (a -> b) -> AVL a -> AVL b +flatMap' f t = asTreeLenL (size t) (map' f (asListL t)) where + map' _ [] = [] + map' g (a:as) = let b = g a in b `seq` (b : map' f as) + +-- | Remove all AVL tree elements which do not satisfy the supplied predicate. +-- Element ordering is preserved. The resulting tree is flat. +-- +-- Complexity: O(n) +filterViaList :: (e -> Bool) -> AVL e -> AVL e +filterViaList p t = filter' [] 0 (asListR t) where + filter' se n [] = asTreeLenL n se + filter' se n (e:es) = if p e then let n'=n+1 in n' `seq` filter' (e:se) n' es + else filter' se n es + +-- | Partition an AVL tree using the supplied predicate. The first AVL tree in the +-- resulting pair contains all elements for which the predicate is True, the second +-- contains all those for which the predicate is False. Element ordering is preserved. +-- Both of the resulting trees are flat. +-- +-- Complexity: O(n) +partitionAVL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +partitionAVL p t = part 0 [] 0 [] (asListR t) where + part nT lstT nF lstF [] = let avlT = asTreeLenL nT lstT + avlF = asTreeLenL nF lstF + in (avlT,avlF) -- Non strict in avlT, avlF !! + part nT lstT nF lstF (e:es) = if p e then let nT'=nT+1 in nT' `seq` part nT' (e:lstT) nF lstF es + else let nF'=nF+1 in nF' `seq` part nT lstT nF' (e:lstF) es + +-- | Remove all AVL tree elements for which the supplied function returns 'Nothing'. +-- Element ordering is preserved. The resulting tree is flat. +-- +-- Complexity: O(n) +mapMaybeViaList :: (a -> Maybe b) -> AVL a -> AVL b +mapMaybeViaList f t = map' [] 0 (asListR t) where + map' sb n [] = asTreeLenL n sb + map' sb n (a:as) = case f a of + Just b -> let n'=n+1 in n' `seq` map' (b:sb) n' as + Nothing -> map' sb n as + +-- | Invokes 'genPushList' on the empty AVL tree. +-- +-- Complexity: O(n.(log n)) +{-# INLINE genAsTree #-} +genAsTree :: (e -> e -> COrdering e) -> [e] -> AVL e +genAsTree c = genPushList c empty + +-- | Push the elements of an unsorted List in a sorted AVL tree using the supplied combining comparison. +-- +-- Complexity: O(n.(log (m+n))) where n is the list length, m is the tree size. +genPushList :: (e -> e -> COrdering e) -> AVL e -> [e] -> AVL e +genPushList c avl = foldl' addElem avl + where addElem t e = genPush (c e) e t + +-- | Uses the supplied combining comparison to sort list elements into ascending order. +-- Multiple occurences of the same element are eliminated (they are combined in some way). +-- +-- Complexity: O(n.(log n)) +{-# INLINE genSortAscending #-} +genSortAscending :: (e -> e -> COrdering e) -> [e] -> [e] +genSortAscending c = asListL . genAsTree c + +-- | Uses the supplied combining comparison to sort list elements into descending order. +-- Multiple occurences of the same element are eliminated (they are combined in some way). +-- +-- Complexity: O(n.(log n)) +{-# INLINE genSortDescending #-} +genSortDescending :: (e -> e -> COrdering e) -> [e] -> [e] +genSortDescending c = asListR . genAsTree c + + diff --git a/Data/Tree/AVL/Push.hs b/Data/Tree/AVL/Push.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Push.hs @@ -0,0 +1,718 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Push +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines functions for searching AVL trees and pushing +-- a new element in the tree (or modifying the value of an existing element). +-- The functions defined here may alter the content of a tree (value of an existing +-- tree element) and also the structure of a tree (by adding a new element). +----------------------------------------------------------------------------- +module Data.Tree.AVL.Push + (-- * Pushing on extreme left or right. + pushL,pushR, + + -- * Pushing on /sorted/ trees. + genPush,genPush',genPushMaybe,genPushMaybe', + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath,insertPath) + +{------------------------------------------------------------------------------------------------------------------------------ + -------------------------------------- Notes about Insertion and Rebalancing ------------------------------------------------- + ------------------------------------------------------------------------------------------------------------------------------ + If we forget about tree rebalancing, and consider what changes in BF tell us about changes in H + under ordinary circumstances, we can make the following observations: + + (1) Insertion can never reduce the height of a (sub)tree. + (2) Insertion can only change the height of a (sub)tree by +1 at most. Therefore the BF of the + root can change by +/- 1 most. + (2) If insertion changes the BF from 0 -> +/- 1, then this must be because either the left or + right subtrees has grown in height by 1. Since they were equal before (BF=0), the overall + height of the root must also have grown by 1. + (3) If insertion changes the BF from +/-1 -> 0, then this must be because one either the left + or right subtree has grown by 1 so that it is now equal in height to the opposing subtree. + Since height of the root is determined by the maximum height of the subtrees, it is left + unchanged. + (4) If insertion leaves the BF unchanged, then this must be because the height of neither + subtree has changed. Therefore the height of the root is left unchanged. + (5) It follows from (2) and (3), that changes in height, and hence BF can (and will) propogate + up the tree (along the insertion path) as far as the first node with non-zero BF, and no further. + (6) If insertion changes the BF from +/-1 -> +/-2 then we have a problem. This is dealt with by + one of four possible rebalancing 'rotations' (there are two possiblities for each of the left + and right subtrees). However, it's appropriate to mention an important property of the rotations + now. The net effect of unbalancing and rebalancing is to give the root BF=0 and leave the height + unchanged. So the combined effect of the unbalance-rebalance operation appears like a special + case of (3). Another important property of rebalancing is that it /preserves/ the tree sorting. + (7) It follows from (6) and (5) any single insertion will cause most one unbalance-rebalance operation. + + So in summary we have a set of rules to enable us to infer changes in height of a subtree (if any) from + changes in the BF of the subtree, and hence the changes (if any) in the BF of the root. The rules are: + BF 0 -> +/-1, height increased by 1 + BF +/-1 -> 0, height unchanged. + BF unchanged , height unchanged. + BF +/-1 -> -/+1, NEVER OCCURS + + It should also be observed that these observations and rules apply to INSERTION only (not deletion). + +Rebalancing: CASE RR +-------------------- + Consider inserting into the right subtree of the right subtree (RR subtree). From the obsevations above we can + say this is only going to unbalance the root if: + The height of the RR subtree is increased by 1 (we determine this from looking at changes in it's BF) + ..and.. The right subtree has BF=0 prior to insertion (observation 5) + ..and.. THe root has BF=-1 prior to insertion (observation 2) + + In pictures.. + + ----- ----- ----- + | B | | B | | D | + |H=h+2| |H=h+3| |H=h+2| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- -----/ \----- + | A | | D | E grows | A | | D | Rebalance | B | | E | + | H=h | |H=h+1| by 1 | H=h | |H=h+2| --------> |H=h+1| |H=h+1| + | | |BF= 0| ------> | | |BF=-1| |BF= 0| | | + ----- /-----\ h -> h+1 ----- /-----\ /-----\ ----- + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- -----/ \----- + | C | | E | | C | | E | | A | | C | + | H=h | | H=h | | H=h | |H=h+1| | H=h | | H=h | + | | | | | | | | | | | | + ----- ----- ----- ----- ----- ----- + + Unfortunately, if you try this for insertion into the right left subtree (C) it doesn't work. To deal with + this case we need a more complicated re-balancing rotation involving 3 nodes. There are 2 distinct cases, which + both use the same rotation, but details re. BF and H are different. + +Rebalancing: CASE RL(1) +----------------------- + + ----- ----- ----- + | B | | B | | D | + |H=h+3| |H=h+4| |H=h+3| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- / \ + | A | | F | E grows | A | | F | Rebalance -----/ \----- + |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F | + | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2| + ----- /-----\ h -> h+1 ----- /-----\ |BF=+1| |BF= 0| + / \ / \ -----/-----\----- -----/-----\----- + / \ / \ | A | | C | | E | | G | + -----/ \----- -----/ \----- |H=h+1| | H=h | |H=h+1| |H=h+1| + | D | | G | | D | | G | | | | | | | | | + |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ----- + |BF= 0| | | |BF=-1| | | + /-----\ ----- /-----\ ----- + / \ / \ + / \ / \ + -----/ \----- -----/ \----- + | C | | E | | C | | E | + | H=h | | H=h | | H=h | |H=h+1| + | | | | | | | | + ----- ----- ----- ----- + +Rebalancing: CASE RL(2) +----------------------- + + ----- ----- ----- + | B | | B | | D | + |H=h+3| |H=h+4| |H=h+3| <- Note + |BF=-1| |BF=-2| <-- Unbalanced! |BF= 0| <- Note + /-----\ /-----\ /-----\ + / \ / \ / \ + / \ / \ / \ + -----/ \----- -----/ \----- / \ + | A | | F | C grows | A | | F | Rebalance -----/ \----- + |H=h+1| |H=h+2| by 1 |H=h+1| |H=h+3| --------> | B | | F | + | | |BF= 0| ------> | | |BF=+1| |H=h+2| |H=h+2| + ----- /-----\ h -> h+1 ----- /-----\ |BF= 0| |BF=-1| + / \ / \ -----/-----\----- -----/-----\----- + / \ / \ | A | | C | | E | | G | + -----/ \----- -----/ \----- |H=h+1| |H=h+1| | H=h | |H=h+1| + | D | | G | | D | | G | | | | | | | | | + |H=h+1| |H=h+1| |H=h+2| |H=h+1| ----- ----- ----- ----- + |BF= 0| | | |BF=+1| | | + /-----\ ----- /-----\ ----- + / \ / \ + / \ / \ + -----/ \----- -----/ \----- + | C | | E | | C | | E | + | H=h | | H=h | |H=h+1| | H=h | + | | | | | | | | + ----- ----- ----- ----- +----------------------------------------------------------------------------------------------------------------------------- +-----------------------------------------------------------------------------------------------------------------------------} + +-- | General push. This function searches the AVL tree using the supplied selector. If a matching element +-- is found it's replaced by the value (@e@) returned in the @('Eq' e)@ constructor returned by the selector. +-- If no match is found then the default element value is added at in the appropriate position in the tree. +-- +-- Note that for this to work properly requires that the selector behave as if it were comparing the +-- (potentially) new default element with existing tree elements, even if it isn't. +-- +-- Note also that this function is /non-strict/ in it\'s second argument (the default value which +-- is inserted if the search fails or is discarded if the search succeeds). If you want +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPush'' +-- +-- Complexity: O(log n) +genPush :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush c e0 = put where -- there now follows a huge collection of functions requiring + -- pattern matching from hell in which c and e0 are free variables +-- This may look longwinded, it's been done this way to.. +-- * Avoid doing case analysis on the same node more than once. +-- * Minimise heap burn rate (by avoiding explicit rebalancing operations). + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put E = Z E e0 E + put (N l e r) = putN l e r + put (Z l e r) = putZ l e r + put (P l e r) = putP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + + -- Put in (N l e r), BF=-1 , (never returns P) + putN l e r = case c e of + Lt -> putNL l e r -- N l e' r -- =e, so update existing + Gt -> putNR l e r -- >e, so put in R subtree + + -- Put in (Z l e r), BF= 0 + putZ l e r = case c e of + Lt -> putZL l e r -- Z l e' r -- =e, so update existing + Gt -> putZR l e r -- >e, so put in R subtree + + -- Put in (P l e r), BF=+1 , (never returns N) + putP l e r = case c e of + Lt -> putPL l e r -- P l e' r -- =e, so update existing + Gt -> putPR l e r -- >e, so put in R subtree + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + {-# INLINE putNL #-} + putNL E e r = Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush: Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL E e r = P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush: Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR l e E = N l e (Z E e0 E ) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush: Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR l e E = Z l e (Z E e0 E ) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush: Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e 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 l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ E = error "genPush: Bug4" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = case c re of -- determine if RR or RL + Lt -> putNRL l e rl re rr -- RL (never returns P) + Eq re' -> N l e (Z rl re' rr) -- new re + Gt -> putNRR l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL E _ _ = error "genPush: Bug5" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = case c le of -- determine if LL or LR + Lt -> putPLL ll le lr e r -- LL (never returns N) + Eq le' -> P (Z ll le' lr) e r -- new le + Gt -> putPLR ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "genPush: Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "genPush: Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL l e E re rr = Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "genPush: Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR ll le E e r = Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "genPush: Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +------------------------- genPush Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Almost identical to 'genPush', but this version forces evaluation of the default new element +-- (second argument) if no matching element is found. Note that it does /not/ do this if +-- a matching element is found, because in this case the default new element is discarded +-- anyway. Note also that it does not force evaluation of any replacement value provided by the +-- selector (if it returns Eq). (You have to do that yourself if that\'s what you want.) +-- +-- Complexity: O(log n) +genPush' :: (e -> COrdering e) -> e -> AVL e -> AVL e +genPush' c e0 = put where + ----------------------------- LEVEL 0 --------------------------------- + -- put -- + ----------------------------------------------------------------------- + put E = e0 `seq` Z E e0 E + put (N l e r) = putN l e r + put (Z l e r) = putZ l e r + put (P l e r) = putP l e r + + ----------------------------- LEVEL 1 --------------------------------- + -- putN, putZ, putP -- + ----------------------------------------------------------------------- + + -- Put in (N l e r), BF=-1 , (never returns P) + putN l e r = case c e of + Lt -> putNL l e r -- N l e' r -- =e, so update existing + Gt -> putNR l e r -- >e, so put in R subtree + + -- Put in (Z l e r), BF= 0 + putZ l e r = case c e of + Lt -> putZL l e r -- Z l e' r -- =e, so update existing + Gt -> putZR l e r -- >e, so put in R subtree + + -- Put in (P l e r), BF=+1 , (never returns N) + putP l e r = case c e of + Lt -> putPL l e r -- P l e' r -- =e, so update existing + Gt -> putPR l e r -- >e, so put in R subtree + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + {-# INLINE putNL #-} + putNL E e r = e0 `seq` Z (Z E e0 E ) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush': Bug0" -- impossible + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + _ -> Z l' e r -- L subtree BF:0->+/-1, H:h->h+1, parent BF:-1-> 0 + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + {-# INLINE putZL #-} + putZL E e r = e0 `seq` P (Z E e0 E ) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZ ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + E -> error "genPush': Bug1" -- impossible + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> P l' e r -- L subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->+1 + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + {-# INLINE putZR #-} + putZR l e E = e0 `seq` N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush': Bug2" -- impossible + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + _ -> N l e r' -- R subtree BF: 0->+/-1, H:h->h+1, parent BF: 0->-1 + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + {-# INLINE putPR #-} + putPR l e E = e0 `seq` Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZ rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + E -> error "genPush': Bug3" -- impossible + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + _ -> Z l e 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 l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + {-# INLINE putNR #-} + putNR _ _ E = error "genPush': Bug4" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putN rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putP rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = case c re of -- determine if RR or RL + Lt -> putNRL l e rl re rr -- RL (never returns P) + Eq re' -> N l e (Z rl re' rr) -- new re + Gt -> putNRR l e rl re rr -- RR (never returns P) + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + {-# INLINE putPL #-} + putPL E _ _ = error "genPush': Bug5" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putN ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putP ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = case c le of -- determine if LL or LR + Lt -> putPLL ll le lr e r -- LL (never returns N) + Eq le' -> P (Z ll le' lr) e r -- new le + Gt -> putPLR ll le lr e r -- LR (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR, putPLL -- + -- putNRL, putPLR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = e0 `seq` Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putN rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putP rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZ rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + E -> error "genPush': Bug6" -- impossible + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = e0 `seq` Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putN lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putP lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZ lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + E -> error "genPush': Bug7" -- impossible + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+/-1, H:h->h+1, parent BF:-1->-2, CASE LL !! + + -- (putNRL l e rl re rr): Put in RL subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRL #-} + putNRL l e E re rr = e0 `seq` Z (Z l e E) e0 (Z E re rr) -- l and rr must also be E, special CASE LR !! + putNRL l e (N rll rle rlr) re rr = let rl' = putN rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (P rll rle rlr) re rr = let rl' = putP rll rle rlr -- RL subtree BF<>0, H:h->h, so no change + in rl' `seq` N l e (Z rl' re rr) + putNRL l e (Z rll rle rlr) re rr = let rl' = putZ rll rle rlr -- RL subtree BF= 0, so need to look for changes + in case rl' of + E -> error "genPush': Bug8" -- impossible + Z _ _ _ -> N l e (Z rl' re rr) -- RL subtree BF: 0-> 0, H:h->h, so no change + N rll' rle' rlr' -> Z (P l e rll') rle' (Z rlr' re rr) -- RL subtree BF: 0->-1, SO.. CASE RL(1) !! + P rll' rle' rlr' -> Z (Z l e rll') rle' (N rlr' re rr) -- RL subtree BF: 0->+1, SO.. CASE RL(2) !! + + -- (putPLR ll le lr e r): Put in LR subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLR #-} + putPLR ll le E e r = e0 `seq` Z (Z ll le E) e0 (Z E e r) -- r and ll must also be E, special CASE LR !! + putPLR ll le (N lrl lre lrr) e r = let lr' = putN lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (P lrl lre lrr) e r = let lr' = putP lrl lre lrr -- LR subtree BF<>0, H:h->h, so no change + in lr' `seq` P (Z ll le lr') e r + putPLR ll le (Z lrl lre lrr) e r = let lr' = putZ lrl lre lrr -- LR subtree BF= 0, so need to look for changes + in case lr' of + E -> error "genPush': Bug9" -- impossible + Z _ _ _ -> P (Z ll le lr') e r -- LR subtree BF: 0-> 0, H:h->h, so no change + N lrl' lre' lrr' -> Z (P ll le lrl') lre' (Z lrr' e r) -- LR subtree BF: 0->-1, SO.. CASE LR(2) !! + P lrl' lre' lrr' -> Z (Z ll le lrl') lre' (N lrr' e r) -- LR subtree BF: 0->+1, SO.. CASE LR(1) !! +----------------------------------------------------------------------- +------------------------- genPush' Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | Similar to 'genPush', but returns the original tree if the combining comparison returns +-- @('Eq' 'Nothing')@. So this function can be used reduce heap burn rate by avoiding duplication +-- of nodes on the insertion path. But it may also be marginally slower otherwise. +-- +-- Note that this function is /non-strict/ in it\'s second argument (the default value which +-- is inserted in the search fails or is discarded if the search succeeds). If you want +-- to force evaluation, but only if it\'s actually incorprated in the tree, then use 'genPushMaybe'' +-- +-- Complexity: O(log n) +genPushMaybe :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe c e t = case genOpenPathWith c t of + FullBP _ Nothing -> t + FullBP p (Just e') -> writePath p e' t + EmptyBP p -> insertPath p e t + +-- | Almost identical to 'genPushMaybe', but this version forces evaluation of the default new element +-- (second argument) if no matching element is found. Note that it does /not/ do this if +-- a matching element is found, because in this case the default new element is discarded +-- anyway. +-- +-- Complexity: O(log n) +genPushMaybe' :: (e -> COrdering (Maybe e)) -> e -> AVL e -> AVL e +genPushMaybe' c e t = case genOpenPathWith c t of + FullBP _ Nothing -> t + FullBP p (Just e') -> writePath p e' t + EmptyBP p -> e `seq` insertPath p e t + +-- | Push a new element in the leftmost position of an AVL tree. No comparison or searching is involved. +-- +-- Complexity: O(log n) +pushL :: e -> AVL e -> AVL e +pushL e0 = pushL' where -- There now follows a cut down version of the more general put. + -- Insertion is always on the left subtree. + -- Re-Balancing cases RR,RL/LR(1/2) never occur. Only LL! + -- There are also more impossible cases (putZL never returns N) + ----------------------------- LEVEL 0 --------------------------------- + -- pushL' -- + ----------------------------------------------------------------------- + pushL' E = Z E e0 E + pushL' (N l e r) = putNL l e r + pushL' (Z l e r) = putZL l e r + pushL' (P l e r) = putPL l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- putNL, putZL, putPL -- + ----------------------------------------------------------------------- + + -- (putNL l e r): Put in L subtree of (N l e r), BF=-1 (Never requires rebalancing) , (never returns P) + putNL E e r = Z (Z E e0 E) e r -- L subtree empty, H:0->1, parent BF:-1-> 0 + putNL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:-1->-1 + in l' `seq` N l' e r + putNL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> N l' e r -- L subtree BF:0-> 0, H:h->h , parent BF:-1->-1 + P _ _ _ -> Z l' e r -- L subtree BF:0->+1, H:h->h+1, parent BF:-1-> 0 + _ -> error "pushL: Bug0" -- impossible + + -- (putZL l e r): Put in L subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns N) + putZL E e r = P (Z E e0 E) e r -- L subtree H:0->1, parent BF: 0->+1 + putZL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF: 0-> 0 + in l' `seq` Z l' e r + putZL (Z ll le lr) e r = let l' = putZL ll le lr -- L subtree BF= 0, so need to look for changes + in case l' of + Z _ _ _ -> Z l' e r -- L subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> error "pushL: Bug1" -- impossible + _ -> P l' e 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 --------- + + -- (putPL l e r): Put in L subtree of (P l e r), BF=+1 , (never returns N) + putPL E _ _ = error "pushL: Bug2" -- impossible if BF=+1 + putPL (N ll le lr) e r = let l' = putNL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (P ll le lr) e r = let l' = putPL ll le lr -- L subtree BF<>0, H:h->h, parent BF:+1->+1 + in l' `seq` P l' e r + putPL (Z ll le lr) e r = putPLL ll le lr e r -- LL (never returns N) + + ----------------------------- LEVEL 3 --------------------------------- + -- putPLL -- + ----------------------------------------------------------------------- + + -- (putPLL ll le lr e r): Put in LL subtree of (P (Z ll le lr) e r) , (never returns N) + {-# INLINE putPLL #-} + putPLL E le lr e r = Z (Z E e0 E) le (Z lr e r) -- r and lr must also be E, special CASE LL!! + putPLL (N lll lle llr) le lr e r = let ll' = putNL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (P lll lle llr) le lr e r = let ll' = putPL lll lle llr -- LL subtree BF<>0, H:h->h, so no change + in ll' `seq` P (Z ll' le lr) e r + putPLL (Z lll lle llr) le lr e r = let ll' = putZL lll lle llr -- LL subtree BF= 0, so need to look for changes + in case ll' of + Z _ _ _ -> P (Z ll' le lr) e r -- LL subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> error "pushL: Bug3" -- impossible + _ -> Z ll' le (Z lr e r) -- LL subtree BF: 0->+1, H:h->h+1, parent BF:-1->-2, CASE LL !! +----------------------------------------------------------------------- +--------------------------- pushL Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- | Push a new element in the rightmost position of an AVL tree. No comparison or searching is involved. +-- +-- Complexity: O(log n) +pushR :: AVL e -> e -> AVL e +pushR t e0 = pushR' t where -- There now follows a cut down version of the more general put. + -- Insertion is always on the right subtree. + -- Re-Balancing cases LL,RL/LR(1/2) never occur. Only RR! + -- There are also more impossible cases (putZR never returns P) + + ----------------------------- LEVEL 0 --------------------------------- + -- pushR' -- + ----------------------------------------------------------------------- + pushR' E = Z E e0 E + pushR' (N l e r) = putNR l e r + pushR' (Z l e r) = putZR l e r + pushR' (P l e r) = putPR l e r + + ----------------------------- LEVEL 2 --------------------------------- + -- putNR, putZR, putPR -- + ----------------------------------------------------------------------- + + -- (putZR l e r): Put in R subtree of (Z l e r), BF= 0 (Never requires rebalancing) , (never returns P) + putZR l e E = N l e (Z E e0 E) -- R subtree H:0->1, parent BF: 0->-1 + putZR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF: 0-> 0 + in r' `seq` Z l e r' + putZR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> Z l e r' -- R subtree BF: 0-> 0, H:h->h , parent BF: 0-> 0 + N _ _ _ -> N l e r' -- R subtree BF: 0->-1, H:h->h+1, parent BF: 0->-1 + _ -> error "pushR: Bug0" -- impossible + + -- (putPR l e r): Put in R subtree of (P l e r), BF=+1 (Never requires rebalancing) , (never returns N) + putPR l e E = Z l e (Z E e0 E) -- R subtree empty, H:0->1, parent BF:+1-> 0 + putPR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:+1->+1 + in r' `seq` P l e r' + putPR l e (Z rl re rr) = let r' = putZR rl re rr -- R subtree BF= 0, so need to look for changes + in case r' of + Z _ _ _ -> P l e r' -- R subtree BF:0-> 0, H:h->h , parent BF:+1->+1 + N _ _ _ -> Z l e r' -- R subtree BF:0->-1, H:h->h+1, parent BF:+1-> 0 + _ -> error "pushR: Bug1" -- impossible + + -------- This case (NR) may need rebalancing if it goes to LEVEL 3 --------- + + -- (putNR l e r): Put in R subtree of (N l e r), BF=-1 , (never returns P) + putNR _ _ E = error "pushR: Bug2" -- impossible if BF=-1 + putNR l e (N rl re rr) = let r' = putNR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (P rl re rr) = let r' = putPR rl re rr -- R subtree BF<>0, H:h->h, parent BF:-1->-1 + in r' `seq` N l e r' + putNR l e (Z rl re rr) = putNRR l e rl re rr -- RR (never returns P) + + ----------------------------- LEVEL 3 --------------------------------- + -- putNRR -- + ----------------------------------------------------------------------- + + -- (putNRR l e rl re rr): Put in RR subtree of (N l e (Z rl re rr)) , (never returns P) + {-# INLINE putNRR #-} + putNRR l e rl re E = Z (Z l e rl) re (Z E e0 E) -- l and rl must also be E, special CASE RR!! + putNRR l e rl re (N rrl rre rrr) = let rr' = putNR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (P rrl rre rrr) = let rr' = putPR rrl rre rrr -- RR subtree BF<>0, H:h->h, so no change + in rr' `seq` N l e (Z rl re rr') + putNRR l e rl re (Z rrl rre rrr) = let rr' = putZR rrl rre rrr -- RR subtree BF= 0, so need to look for changes + in case rr' of + Z _ _ _ -> N l e (Z rl re rr') -- RR subtree BF: 0-> 0, H:h->h, so no change + N _ _ _ -> Z (Z l e rl) re rr' -- RR subtree BF: 0->-1, H:h->h+1, parent BF:-1->-2, CASE RR !! + _ -> error "pushR: Bug3" -- impossible +----------------------------------------------------------------------- +--------------------------- pushR Ends Here --------------------------- +----------------------------------------------------------------------- + + diff --git a/Data/Tree/AVL/Read.hs b/Data/Tree/AVL/Read.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Read.hs @@ -0,0 +1,171 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Read +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines useful functions for searching AVL trees and reading +-- information from a particular element. The functions defined here do not +-- alter either the content or the structure of a tree. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Read + (-- * Reading from extreme left or right. + assertReadL,tryReadL, + assertReadR,tryReadR, + + -- * Reading from /sorted/ trees. + genAssertRead,genTryRead,genTryReadMaybe,genDefaultRead, + + -- * Simple searches of /sorted/ trees. + genContains, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) + +-- | Read the leftmost element from a /non-empty/ tree. Raises an error if the tree is empty. +-- If the tree is sorted this will return the least element. +-- +-- Complexity: O(log n) +assertReadL :: AVL e -> e +assertReadL E = error "assertReadL: Empty tree." +assertReadL (N l e _) = readLE l e +assertReadL (Z l e _) = readLE l e +assertReadL (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty. + +-- | Similar to 'assertReadL' but returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryReadL :: AVL e -> Maybe e +tryReadL E = Nothing +tryReadL (N l e _) = Just $! readLE l e +tryReadL (Z l e _) = Just $! readLE l e +tryReadL (P l _ _) = Just $! readLNE l -- BF=+1, so left sub-tree cannot be empty. + +-- Local utilities for the above +readLNE :: AVL e -> e +readLNE E = error "readLNE: Bug." +readLNE (N l e _) = readLE l e +readLNE (Z l e _) = readLE l e +readLNE (P l _ _) = readLNE l -- BF=+1, so left sub-tree cannot be empty. +readLE :: AVL e -> e -> e +readLE E e = e +readLE (N l e _) _ = readLE l e +readLE (Z l e _) _ = readLE l e +readLE (P l _ _) _ = readLNE l -- BF=+1, so left sub-tree cannot be empty. + + +-- | Read the rightmost element from a /non-empty/ tree. Raises an error if the tree is empty. +-- If the tree is sorted this will return the greatest element. +-- +-- Complexity: O(log n) +assertReadR :: AVL e -> e +assertReadR E = error "assertReadR: Empty tree." +assertReadR (P _ e r) = readRE r e +assertReadR (Z _ e r) = readRE r e +assertReadR (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty. + +-- | Similar to 'assertReadR' but returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryReadR :: AVL e -> Maybe e +tryReadR E = Nothing +tryReadR (P _ e r) = Just $! readRE r e +tryReadR (Z _ e r) = Just $! readRE r e +tryReadR (N _ _ r) = Just $! readRNE r -- BF=-1, so right sub-tree cannot be empty. + +-- Local utilities for the above +readRNE :: AVL e -> e +readRNE E = error "readRNE: Bug." +readRNE (P _ e r) = readRE r e +readRNE (Z _ e r) = readRE r e +readRNE (N _ _ r) = readRNE r -- BF=-1, so right sub-tree cannot be empty. +readRE :: AVL e -> e -> e +readRE E e = e +readRE (P _ e r) _ = readRE r e +readRE (Z _ e r) _ = readRE r e +readRE (N _ _ r) _ = readRNE r -- BF=-1, so right sub-tree cannot be empty. + + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function raises a error if the search fails. +-- +-- Complexity: O(log n) +genAssertRead :: AVL e -> (e -> COrdering a) -> a +genAssertRead t c = genRead' t where + genRead' E = error "genAssertRead failed." + genRead' (N l e r) = genRead'' l e r + genRead' (Z l e r) = genRead'' l e r + genRead' (P l e r) = genRead'' l e r + genRead'' l e r = case c e of + Lt -> genRead' l + Eq a -> a + Gt -> genRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function is similar to 'genAssertRead', but returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +genTryRead :: AVL e -> (e -> COrdering a) -> Maybe a +genTryRead t c = genTryRead' t where + genTryRead' E = Nothing + genTryRead' (N l e r) = genTryRead'' l e r + genTryRead' (Z l e r) = genTryRead'' l e r + genTryRead' (P l e r) = genTryRead'' l e r + genTryRead'' l e r = case c e of + Lt -> genTryRead' l + Eq a -> Just a + Gt -> genTryRead' r + +-- | This version returns the result of the selector (without adding a 'Just' wrapper) if the search +-- succeeds, or 'Nothing' if it fails. +-- +-- Complexity: O(log n) +genTryReadMaybe :: AVL e -> (e -> COrdering (Maybe a)) -> Maybe a +genTryReadMaybe t c = genTryRead' t where + genTryRead' E = Nothing + genTryRead' (N l e r) = genTryRead'' l e r + genTryRead' (Z l e r) = genTryRead'' l e r + genTryRead' (P l e r) = genTryRead'' l e r + genTryRead'' l e r = case c e of + Lt -> genTryRead' l + Eq mba -> mba + Gt -> genTryRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- This function is similar to 'genAssertRead', but returns a the default value (first argument) if +-- the search fails. +-- +-- Complexity: O(log n) +genDefaultRead :: a -> AVL e -> (e -> COrdering a) -> a +genDefaultRead d t c = genRead' t where + genRead' E = d + genRead' (N l e r) = genRead'' l e r + genRead' (Z l e r) = genRead'' l e r + genRead' (P l e r) = genRead'' l e r + genRead'' l e r = case c e of + Lt -> genRead' l + Eq a -> a + Gt -> genRead' r + +-- | General purpose function to perform a search of a sorted tree, using the supplied selector. +-- Returns True if matching element is found. +-- +-- Complexity: O(log n) +genContains :: AVL e -> (e -> Ordering) -> Bool +genContains t c = genContains' t where + genContains' E = False + genContains' (N l e r) = genContains'' l e r + genContains' (Z l e r) = genContains'' l e r + genContains' (P l e r) = genContains'' l e r + genContains'' l e r = case c e of + LT -> genContains' l + EQ -> True + GT -> genContains' r diff --git a/Data/Tree/AVL/Set.hs b/Data/Tree/AVL/Set.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Set.hs @@ -0,0 +1,423 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Set +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for manipulating AVL trees which represent ordered sets (I.E. /sorted/ trees). +-- Note that although many of these functions work with a variety of different element +-- types they all require that elements are sorted according to the same criterion (such +-- as a field value in a record). +----------------------------------------------------------------------------- +module Data.Tree.AVL.Set + (-- * General purpose set operations. + + -- ** Union. + genUnion,genUnionMaybe,genUnions, + + -- ** Difference. + genDifference,genDifferenceMaybe,genSymDifference, + + -- ** Intersection. + genIntersection,genIntersectionMaybe, + + -- *** Intersection with the result as a list. + -- | Sometimes you don\'t want intersection to give a tree, particularly if the + -- resulting elements are not orderered or sorted according to whatever criterion was + -- used to sort the elements of the input sets. + -- + -- BTW, the reason these variants are provided for intersection only (and not the other + -- set functions) is that the (tree returning) intersections always construct an entirely + -- new tree, whereas with the others the resulting tree will typically share sub-trees + -- with one or both of the originals. (Of course the results of the others can easily be + -- converted to a list too if required.) + genIntersectionToListL,genIntersectionAsListL, + genIntersectionMaybeToListL,genIntersectionMaybeAsListL, + + + -- ** Subset. + genIsSubsetOf, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.HeightUtils(addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH) +import Data.Tree.AVL.Internals.HSet(unionH,unionMaybeH, + intersectionH,intersectionMaybeH, + differenceH,differenceMaybeH,symDifferenceH) + +import Data.COrdering + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Uses the supplied combining comparison to evaluate the union of two sets represented as +-- sorted AVL trees. Whenever the combining comparison is applied, the first comparison argument is +-- an element of the first tree and the second comparison argument is an element of the second tree. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +-- (Faster than Hedge union from Data.Set at any rate). +genUnion :: (e -> e -> COrdering e) -> AVL e -> AVL e -> AVL e +genUnion c = 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 L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case unionH c t0 h0 t1 h1 of UBT2(t,_) -> t + +-- | Similar to 'genUnion', but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genUnionMaybe :: (e -> e -> COrdering (Maybe e)) -> AVL e -> AVL e -> AVL e +genUnionMaybe c = 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 L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case unionMaybeH c t0 h0 t1 h1 of UBT2(t,_) -> t + +-- | Uses the supplied combining comparison to evaluate the union of all sets in a list +-- of sets represented as sorted AVL trees. Behaves as if defined.. +-- +-- @genUnions ccmp avls = foldl' ('genUnion' ccmp) empty avls@ +genUnions :: (e -> e -> COrdering e) -> [AVL e] -> AVL e +genUnions c = gus E L(0) where + gus a _ [] = a + gus a ha ( E :avls) = gus a ha avls + gus a ha (t@(N l _ _):avls) = case unionH c a ha t (addHeight L(2) l) of UBT2(a_,ha_) -> gus a_ ha_ avls + gus a ha (t@(Z l _ _):avls) = case unionH c a ha t (addHeight L(1) l) of UBT2(a_,ha_) -> gus a_ ha_ avls + gus a ha (t@(P _ _ r):avls) = case unionH c a ha t (addHeight L(2) r) of UBT2(a_,ha_) -> gus a_ ha_ avls + +-- | Uses the supplied combining comparison to evaluate the intersection of two sets represented as +-- sorted AVL trees. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersection :: (a -> b -> COrdering c) -> AVL a -> AVL b -> AVL c +genIntersection c t0 t1 = case intersectionH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'genIntersection', but the resulting tree does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybe :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> AVL c +genIntersectionMaybe c t0 t1 = case intersectionMaybeH c t0 t1 of UBT2(t,_) -> t + +-- | Similar to 'genIntersection', but prepends the result to the supplied list in +-- left to right order. This is a (++) free function which behaves as if defined: +-- +-- @genIntersectionToListL c setA setB cs = asListL (genIntersection c setA setB) ++ cs@ +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionToListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionToListL comp = i where + -- i :: AVL a -> AVL b -> [c] -> [c] + i E _ cs = cs + i _ E cs = cs + i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i' l0 e0 r0 l1 e1 r1 cs = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + let cs' = i rr0 r1 cs + cs'' = cs' `seq` case mbc1 of + Nothing -> i rl0 lr1 cs' + Just c1 -> i rl0 lr1 (c1:cs') + in cs'' `seq` case mbc0 of + Nothing -> i l0 ll1 cs'' + Just c0 -> i l0 ll1 (c0:cs'') + -- e0 = e1 + Eq c -> let cs' = i r0 r1 cs in cs' `seq` i l0 l1 (c:cs') + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + let cs' = i r0 rr1 cs + cs'' = cs' `seq` case mbc0 of + Nothing -> i lr0 rl1 cs' + Just c0 -> i lr0 rl1 (c0:cs') + in cs'' `seq` case mbc1 of + Nothing -> i ll0 l1 cs'' + Just c1 -> i ll0 l1 (c1:cs'') + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq c0 -> UBT5(l,hl,Just c0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq c1 -> UBT5(l,hl,Just c1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +------------------ genIntersectionToListL Ends Here ------------------- +----------------------------------------------------------------------- + +-- | Applies 'genIntersectionToListL' to the empty list. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionAsListL :: (a -> b -> COrdering c) -> AVL a -> AVL b -> [c] +genIntersectionAsListL c setA setB = genIntersectionToListL c setA setB [] + +-- | Similar to 'genIntersectionToListL', but the result does not include elements in cases where +-- the supplied combining comparison returns @(Eq Nothing)@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybeToListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] -> [c] +genIntersectionMaybeToListL comp = i where + -- i :: AVL a -> AVL b -> [c] -> [c] + i E _ cs = cs + i _ E cs = cs + i (N l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (N l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (Z l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (N l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (Z l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i (P l0 e0 r0) (P l1 e1 r1) cs = i' l0 e0 r0 l1 e1 r1 cs + i' l0 e0 r0 l1 e1 r1 cs = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + Lt -> case forkR r0 e1 of + UBT5(rl0,_,mbc1,rr0,_) -> case forkL e0 l1 of -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + UBT5(ll1,_,mbc0,lr1,_) -> -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + -- (l0 + ll1) < e0 < (rl0 + lr1) < e1 < (rr0 + r1) + let cs' = i rr0 r1 cs + cs'' = cs' `seq` case mbc1 of + Nothing -> i rl0 lr1 cs' + Just c1 -> i rl0 lr1 (c1:cs') + in cs'' `seq` case mbc0 of + Nothing -> i l0 ll1 cs'' + Just c0 -> i l0 ll1 (c0:cs'') + -- e0 = e1 + Eq mbc -> let cs' = i r0 r1 cs in cs' `seq` case mbc of + Nothing -> i l0 l1 cs' + Just c -> i l0 l1 (c:cs') + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + Gt -> case forkL e0 r1 of + UBT5(rl1,_,mbc0,rr1,_) -> case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT5(ll0,_,mbc1,lr0,_) -> -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- (ll0 + l1) < e1 < (lr0 + rl1) < e0 < (r0 + rr1) + let cs' = i r0 rr1 cs + cs'' = cs' `seq` case mbc0 of + Nothing -> i lr0 rl1 cs' + Just c0 -> i lr0 rl1 (c0:cs') + in cs'' `seq` case mbc1 of + Nothing -> i ll0 l1 cs'' + Just c1 -> i ll0 l1 (c1:cs'') + -- We need 2 different versions of fork (L & R) to ensure that comparison arguments are used in + -- the right order (c e0 e1) + -- forkL :: a -> AVL b -> UBT5(AVL b,UINT,Maybe c,AVL b,UINT) + forkL e0 t1 = forkL_ t1 L(0) where + forkL_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + Lt -> case forkL_ l hl of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc0,l1_,hl1_) + Eq mbc0 -> UBT5(l,hl,mbc0,r,hr) + Gt -> case forkL_ r hr of + UBT5(l0,hl0,mbc0,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc0,l1,hl1) + -- forkR :: AVL a -> b -> UBT5(AVL a,UINT,Maybe c,AVL a,UINT) + forkR t0 e1 = forkR_ t0 L(0) where + forkR_ E h = UBT5(E,h,Nothing,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + Lt -> case forkR_ r hr of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l hl e l0 hl0 of + UBT2(l0_,hl0_) -> UBT5(l0_,hl0_,mbc1,l1,hl1) + Eq mbc1 -> UBT5(l,hl,mbc1,r,hr) + Gt -> case forkR_ l hl of + UBT5(l0,hl0,mbc1,l1,hl1) -> case spliceH l1 hl1 e r hr of + UBT2(l1_,hl1_) -> UBT5(l0,hl0,mbc1,l1_,hl1_) +----------------------------------------------------------------------- +---------------- genIntersectionMaybeToListL Ends Here ---------------- +----------------------------------------------------------------------- + +-- | Applies 'genIntersectionMaybeToListL' to the empty list. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIntersectionMaybeAsListL :: (a -> b -> COrdering (Maybe c)) -> AVL a -> AVL b -> [c] +genIntersectionMaybeAsListL c setA setB = genIntersectionMaybeToListL c setA setB [] + +-- | Uses the supplied comparison to evaluate the difference between two sets represented as +-- sorted AVL trees. The expression.. +-- +-- > genDifference cmp setA setB +-- +-- .. is a set containing all those elements of @setA@ which do not appear in @setB@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genDifference :: (a -> b -> Ordering) -> AVL a -> AVL b -> AVL a +-- N.B. differenceH works with relative heights on first tree, and needs no height for the second. +genDifference c t0 t1 = case differenceH c t0 L(0) t1 of UBT2(t,_) -> t + +-- | Similar to 'genDifference', but the resulting tree also includes those elements a\' for which the +-- combining comparison returns @(Eq (Just a\'))@. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genDifferenceMaybe :: (a -> b -> COrdering (Maybe a)) -> AVL a -> AVL b -> AVL a +-- N.B. differenceMaybeH works with relative heights on first tree, and needs no height for the second. +genDifferenceMaybe c t0 t1 = case differenceMaybeH c t0 L(0) t1 of UBT2(t,_) -> t + +-- Local data type for result of forkL in genIsSubsetOf. +data SubsetForkLRes a = Nout | ForkL (AVL a) !UINT (AVL a) !UINT + +-- | Uses the supplied comparison to test whether the first set is a subset of the second, +-- both sets being represented as sorted AVL trees. This function returns True if any of +-- the following conditions hold.. +-- +-- * The first set is empty (the empty set is a subset of any set). +-- +-- * The two sets are equal. +-- +-- * The first set is a proper subset of the second set. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genIsSubsetOf :: (a -> b -> Ordering) -> AVL a -> AVL b -> Bool +genIsSubsetOf comp = s where + -- s :: AVL a -> AVL b -> Bool + s E _ = True + s _ E = False + s (N l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (N l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (Z l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (N l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (Z l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s (P l0 e0 r0) (P l1 e1 r1) = s' l0 e0 r0 l1 e1 r1 + s' l0 e0 r0 l1 e1 r1 = + case comp e0 e1 of + -- e0 < e1, so (l0 < e0 < e1) & (e0 < e1 < r1) + LT -> case forkL e0 l1 of + Nout -> False + ForkL ll1 _ lr1 _ -> (s l0 ll1) && case forkR r0 e1 of -- (ll1 < e0 < e1) & (e0 < lr1 < e1) + UBT4(rl0,_,rr0,_) -> (s rl0 lr1) && (s rr0 r1) -- (e0 < rl0 < e1) & (e0 < e1 < rr0) + -- e0 = e1 + EQ -> (s l0 l1) && (s r0 r1) + -- e1 < e0, so (l1 < e1 < e0) & (e1 < e0 < r0) + GT -> case forkL e0 r1 of + Nout -> False + ForkL rl1 _ rr1 _ -> (s r0 rr1) && case forkR l0 e1 of -- (e1 < rl1 < e0) & (e1 < e0 < rr1) + UBT4(ll0,_,lr0,_) -> (s lr0 rl1) && (s ll0 l1) -- (ll0 < e1 < e0) & (e1 < lr0 < e0) + -- forkL returns Nout if t1 does not contain e0 (which implies set 0 cannot be a subset of set 1) + -- forkL :: a -> AVL b -> SubsetForkLRes b + forkL e0 t = forkL_ t L(0) where + forkL_ E _ = Nout + forkL_ (N l e r) h = forkL__ l DECINT2(h) e r DECINT1(h) + forkL_ (Z l e r) h = forkL__ l DECINT1(h) e r DECINT1(h) + forkL_ (P l e r) h = forkL__ l DECINT1(h) e r DECINT2(h) + forkL__ l hl e r hr = case comp e0 e of + LT -> case forkL_ l hl of + Nout -> Nout + ForkL t0 ht0 t1 ht1 -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> ForkL t0 ht0 t1_ ht1_ + EQ -> ForkL l hl r hr + GT -> case forkL_ r hr of + Nout -> Nout + ForkL t0 ht0 t1 ht1 -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> ForkL t0_ ht0_ t1 ht1 + -- forkR discards an element from set 0 if it is equal to the element from set 1 + -- forkR :: AVL a -> b -> UBT4(AVL a,UINT,AVL a,UINT) + forkR t e1 = forkR_ t L(0) where + forkR_ E h = UBT4(E,h,E,h) -- Relative heights!! + forkR_ (N l e r) h = forkR__ l DECINT2(h) e r DECINT1(h) + forkR_ (Z l e r) h = forkR__ l DECINT1(h) e r DECINT1(h) + forkR_ (P l e r) h = forkR__ l DECINT1(h) e r DECINT2(h) + forkR__ l hl e r hr = case comp e e1 of + LT -> case forkR_ r hr of + UBT4(t0,ht0,t1,ht1) -> case spliceH l hl e t0 ht0 of + UBT2(t0_,ht0_) -> UBT4(t0_,ht0_,t1,ht1) + EQ -> UBT4(l,hl,r,hr) -- e is discarded from set 0 + GT -> case forkR_ l hl of + UBT4(t0,ht0,t1,ht1) -> case spliceH t1 ht1 e r hr of + UBT2(t1_,ht1_) -> UBT4(t0,ht0,t1_,ht1_) +----------------------------------------------------------------------- +------------------------ genIsSubsetOf Ends Here ---------------------- +----------------------------------------------------------------------- + +-- | The symmetric difference is the set of elements which occur in one set or the other but /not both/. +-- +-- Complexity: Not sure, but I'd appreciate it if someone could figure it out. +genSymDifference :: (e -> e -> Ordering) -> AVL e -> AVL e -> AVL e +genSymDifference c = 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 L(2) l0) t1 (addHeight L(2) l1) + gu t0@(N l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(1) l1) + gu t0@(N l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) l0) t1 (addHeight L(2) r1) + gu t0@(Z l0 _ _ ) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) l1) + gu t0@(Z l0 _ _ ) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(1) l1) + gu t0@(Z l0 _ _ ) t1@(P _ _ r1) = gu_ t0 (addHeight L(1) l0) t1 (addHeight L(2) r1) + gu t0@(P _ _ r0) t1@(N l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) l1) + gu t0@(P _ _ r0) t1@(Z l1 _ _ ) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(1) l1) + gu t0@(P _ _ r0) t1@(P _ _ r1) = gu_ t0 (addHeight L(2) r0) t1 (addHeight L(2) r1) + gu_ t0 h0 t1 h1 = case symDifferenceH c t0 h0 t1 h1 of UBT2(t,_) -> t + diff --git a/Data/Tree/AVL/Size.hs b/Data/Tree/AVL/Size.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Size.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Size +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL Tree size related utilities. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Size + (-- * AVL tree size utilities. + size,addSize, + ) where + +import Data.Tree.AVL.Types(AVL) +import Data.Tree.AVL.Internals.HeightUtils(fastAddSize) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Counts the total number of elements in an AVL tree. +-- +-- Complexity: O(n) +{-# INLINE size #-} +size :: AVL e -> Int +size = addSize 0 + +-- | Adds the size of a tree to the first argument. +-- +-- Complexity: O(n) +{-# INLINE addSize #-} +addSize :: Int -> AVL e -> Int +addSize ASINT(n) t = ASINT(fastAddSize n t) diff --git a/Data/Tree/AVL/Split.hs b/Data/Tree/AVL/Split.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Split.hs @@ -0,0 +1,838 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Split +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- Functions for splitting AVL trees. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Split + (-- * Taking fixed size lumps of tree. + -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is + -- already known for other reasons then for (n > s\/2) using the appropriate complementary + -- function with argument (s-n) will be faster. + -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to + -- exploit this optimisation (because this is O(s) anyway). + splitAtL,splitAtR,takeL,takeR,dropL,dropR, + + -- * Rotations. + -- | Bear in mind that the tree size (s) is not stored in the AVL data structure, but if it is + -- already known for other reasons then for (n > s\/2) using the appropriate complementary + -- function with argument (s-n) will be faster. + -- But it's probably not worth invoking 'Data.Tree.AVL.Types.size' for no reason other than to exploit this optimisation + -- (because this is O(s) anyway). + rotateL,rotateR,popRotateL,popRotateR,rotateByL,rotateByR, + + -- * Taking lumps of tree according to a supplied predicate. + spanL,spanR,takeWhileL,dropWhileL,takeWhileR,dropWhileR, + + -- * Taking lumps of /sorted/ trees. + -- | Prepare to get confused. All these functions adhere to the same Ordering convention as + -- is used for searches. That is, if the supplied selector returns LT that means the search + -- key is less than the current tree element. Or put another way, the current tree element + -- is greater than the search key. + -- + -- So (for example) the result of the 'genTakeLT' function is a tree containing all those elements + -- which are less than the notional search key. That is, all those elements for which the + -- supplied selector returns GT (not LT as you might expect). I know that seems backwards, but + -- it's consistent if you think about it. + genForkL,genForkR,genFork, + genTakeLE,genDropGT, + genTakeLT,genDropGE, + genTakeGT,genDropLE, + genTakeGE,genDropLT, + + ) where + +import Prelude -- so haddock finds the symbols there + + +import Data.COrdering(COrdering(..)) +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Push(pushL,pushR) +import Data.Tree.AVL.Internals.DelUtils(popRN,popRZ,popRP,popLN,popLZ,popLP) +import Data.Tree.AVL.Internals.HAVL(HAVL(HAVL),spliceHAVL,pushLHAVL,pushRHAVL) +import Data.Tree.AVL.Internals.HJoin(joinH') + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- Local Datatype for results of split operations. +data SplitResult e = All (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!! + | More {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!) + +-- | Split an AVL tree from the Left. The 'Int' argument n (n >= 0) specifies the split point. +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right (l,r)) where l contains +-- the leftmost n elements and r contains the remaining rightmost elements (r will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +splitAtL :: Int -> AVL e -> Either Int (AVL e, AVL e) +splitAtL n _ | n < 0 = error "splitAtL: Negative argument." +splitAtL 0 E = Left 0 -- Treat this case specially +splitAtL 0 t = Right (E,t) +splitAtL ASINT(n) t = case splitL n t L(0) of -- Tree Heights are relative!! + More n_ -> Left ASINT(SUBINT(n,n_)) + All (HAVL l _) (HAVL r _) -> Right (l,r) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty +splitL :: UINT -> AVL e -> UINT -> SplitResult e +splitL n E _ = More n +splitL n (N l e r) h = splitL_ n l DECINT2(h) e r DECINT1(h) +splitL n (Z l e r) h = splitL_ n l DECINT1(h) e r DECINT1(h) +splitL n (P l e r) h = splitL_ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where rhavl is empty +splitL_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e +splitL_ n l hl e r hr = + case splitL n l hl of + More L(0) -> let rhavl = pushLHAVL e (HAVL r hr); lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` All lhavl rhavl + More L(1) -> case r of + E -> More L(0) + _ -> let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` All lhavl rhavl + More n_ -> let sr = splitL DECINT1(n_) r hr + in case sr of + More _ -> sr + All havl0 havl1 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` All havl0' havl1 + All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` All havl0 havl1' +----------------------------------------------------------------------- +------------------------- splitAtL Ends Here -------------------------- +----------------------------------------------------------------------- + +-- | Split an AVL tree from the Right. The 'Int' argument n (n >= 0) specifies the split point. +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right (l,r)) where r contains +-- the rightmost n elements and l contains the remaining leftmost elements (l will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +splitAtR :: Int -> AVL e -> Either Int (AVL e, AVL e) +splitAtR n _ | n < 0 = error "splitAtR: Negative argument." +splitAtR 0 E = Left 0 -- Treat this case specially +splitAtR 0 t = Right (t,E) +splitAtR ASINT(n) t = case splitR n t L(0) of -- Tree Heights are relative!! + More n_ -> Left ASINT(SUBINT(n,n_)) + All (HAVL l _) (HAVL r _) -> Right (l,r) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty +splitR :: UINT -> AVL e -> UINT -> SplitResult e +splitR n E _ = More n +splitR n (N l e r) h = splitR_ n l DECINT2(h) e r DECINT1(h) +splitR n (Z l e r) h = splitR_ n l DECINT1(h) e r DECINT1(h) +splitR n (P l e r) h = splitR_ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (ALL lhavl rhavl) where lhavl is empty +splitR_ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> SplitResult e +splitR_ n l hl e r hr = + case splitR n r hr of + More L(0) -> let lhavl = pushRHAVL (HAVL l hl) e; rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` All lhavl rhavl + More L(1) -> case l of + E -> More L(0) + _ -> let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` All lhavl rhavl + More n_ -> let sr = splitR DECINT1(n_) l hl + in case sr of + More _ -> sr + All havl0 havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` All havl0 havl1' + All havl0 havl1 -> let havlO' = spliceHAVL (HAVL l hl) e havl0 + in havlO' `seq` All havlO' havl1 +----------------------------------------------------------------------- +------------------------- splitAtR Ends Here -------------------------- +----------------------------------------------------------------------- + +-- Local Datatype for results of take/drop operations. +data TakeResult e = AllTR (HAVL e) -- The resulting Tree + | MoreTR {-# UNPACK #-} !UINT -- No of tree elements still required (>=0!!) + +-- | This is a simplified version of 'splitAtL' which does not return the remaining tree. +-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the left). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right l) where l contains +-- the leftmost n elements. +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +takeL :: Int -> AVL e -> Either Int (AVL e) +takeL n _ | n < 0 = error "takeL: Negative argument." +takeL 0 E = Left 0 -- Treat this case specially +takeL 0 _ = Right E +takeL ASINT(n) t = case takeL_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL t' _) -> Right t' + +-- n > 0 !! +takeL_ :: UINT -> AVL e -> UINT -> TakeResult e +takeL_ n E _ = MoreTR n +takeL_ n (N l e r) h = takeL__ n l DECINT2(h) e r DECINT1(h) +takeL_ n (Z l e r) h = takeL__ n l DECINT1(h) e r DECINT1(h) +takeL_ n (P l e r) h = takeL__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +takeL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +takeL__ n l hl e r hr = + let takel = takeL_ n l hl + in case takel of + MoreTR L(0) -> let lhavl = HAVL l hl + in lhavl `seq` AllTR lhavl + MoreTR L(1) -> case r of + E -> MoreTR L(0) + _ -> let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` AllTR lhavl + MoreTR n_ -> let taker = takeL_ DECINT1(n_) r hr + in case taker of + AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` AllTR havl0' + _ -> taker + _ -> takel +----------------------------------------------------------------------- +-------------------------- takeL Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtR' which does not return the remaining tree. +-- The 'Int' argument n (n >= 0) specifies the number of elements to take (from the right). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right r) where r contains +-- the rightmost n elements. +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +takeR :: Int -> AVL e -> Either Int (AVL e) +takeR n _ | n < 0 = error "takeR: Negative argument." +takeR 0 E = Left 0 -- Treat this case specially +takeR 0 _ = Right E +takeR ASINT(n) t = case takeR_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL t' _) -> Right t' + +-- n > 0 !! +takeR_ :: UINT -> AVL e -> UINT -> TakeResult e +takeR_ n E _ = MoreTR n +takeR_ n (N l e r) h = takeR__ n l DECINT2(h) e r DECINT1(h) +takeR_ n (Z l e r) h = takeR__ n l DECINT1(h) e r DECINT1(h) +takeR_ n (P l e r) h = takeR__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +takeR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +takeR__ n l hl e r hr = + let taker = takeR_ n r hr + in case taker of + MoreTR L(0) -> let rhavl = HAVL r hr + in rhavl `seq` AllTR rhavl + MoreTR L(1) -> case l of + E -> MoreTR L(0) + _ -> let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` AllTR rhavl + MoreTR n_ -> let takel = takeR_ DECINT1(n_) l hl + in case takel of + AllTR havl0 -> let havl0' = spliceHAVL havl0 e (HAVL r hr) + in havl0' `seq` AllTR havl0' + _ -> takel + _ -> taker +----------------------------------------------------------------------- +-------------------------- takeR Ends Here ---------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtL' which returns the remaining tree only (rightmost elements). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right r) where r contains +-- the remaining elements (r will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +dropL :: Int -> AVL e -> Either Int (AVL e) +dropL n _ | n < 0 = error "dropL: Negative argument." +dropL 0 E = Left 0 -- Treat this case specially +dropL 0 t = Right t +dropL ASINT(n) t = case dropL_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL r _) -> Right r + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty +dropL_ :: UINT -> AVL e -> UINT -> TakeResult e +dropL_ n E _ = MoreTR n +dropL_ n (N l e r) h = dropL__ n l DECINT2(h) e r DECINT1(h) +dropL_ n (Z l e r) h = dropL__ n l DECINT1(h) e r DECINT1(h) +dropL_ n (P l e r) h = dropL__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR rhavl) where rhavl is empty +dropL__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +dropL__ n l hl e r hr = + case dropL_ n l hl of + MoreTR L(0) -> let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` AllTR rhavl + MoreTR L(1) -> case r of + E -> MoreTR L(0) + _ -> let rhavl = HAVL r hr in rhavl `seq` AllTR rhavl + MoreTR n_ -> dropL_ DECINT1(n_) r hr + AllTR havl1 -> let havl1' = spliceHAVL havl1 e (HAVL r hr) + in havl1' `seq` AllTR havl1' +----------------------------------------------------------------------- +--------------------------- dropL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'splitAtR' which returns the remaining tree only (leftmost elements). +-- This function raises an error if n is negative. +-- +-- If the tree size is greater than n the result is (Right l) where l contains +-- the remaining elements (l will be non-empty). +-- +-- If the tree size is less than or equal to n then the result is (Left s), where s is tree size. +-- +-- An empty tree will always yield a result of (Left 0). +-- +-- Complexity: O(n) +dropR :: Int -> AVL e -> Either Int (AVL e) +dropR n _ | n < 0 = error "dropL: Negative argument." +dropR 0 E = Left 0 -- Treat this case specially +dropR 0 t = Right t +dropR ASINT(n) t = case dropR_ n t L(0) of -- Tree Heights are relative!! + MoreTR n_ -> Left ASINT(SUBINT(n,n_)) + AllTR (HAVL l _) -> Right l + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty +dropR_ :: UINT -> AVL e -> UINT -> TakeResult e +dropR_ n E _ = MoreTR n +dropR_ n (N l e r) h = dropR__ n l DECINT2(h) e r DECINT1(h) +dropR_ n (Z l e r) h = dropR__ n l DECINT1(h) e r DECINT1(h) +dropR_ n (P l e r) h = dropR__ n l DECINT1(h) e r DECINT2(h) + +-- n > 0 !! +-- N.B Never returns a result of form (AllTR lhavl) where lhavl is empty +dropR__ :: UINT -> AVL e -> UINT -> e -> AVL e -> UINT -> TakeResult e +dropR__ n l hl e r hr = + case dropR_ n r hr of + MoreTR L(0) -> let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` AllTR lhavl + MoreTR L(1) -> case l of + E -> MoreTR L(0) + _ -> let lhavl = HAVL l hl in lhavl `seq` AllTR lhavl + MoreTR n_ -> dropR_ DECINT1(n_) l hl + AllTR havl0 -> let havl0' = spliceHAVL (HAVL l hl) e havl0 + in havl0' `seq` AllTR havl0' +----------------------------------------------------------------------- +--------------------------- dropR Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- Local Datatype for results of span operations. +data SpanResult e = Some (HAVL e) (HAVL e) -- Two tree/height pairs. Non Strict!! + | TheLot -- The Lot satisfied + +-- | Span an AVL tree from the left, using the supplied predicate. This function returns +-- a pair of trees (l,r), where l contains the leftmost consecutive elements which +-- satisfy the predicate. The leftmost element of r (if any) is the first to fail +-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved. +-- +-- Complexity: O(n), where n is the size of l. +spanL :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +spanL p t = case spanIt t L(0) of -- Tree heights are relative + TheLot -> (t, E) -- All satisfied + Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied + where + spanIt E _ = TheLot + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + -- N.B: Never Returns (Some _ (HAVL E _)) (== TheLot) + spanIt_ l hl e r hr = + case spanIt l hl of + Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` Some havl0 havl1_ + TheLot -> if p e + then let spanItr = spanIt r hr + in case spanItr of + Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` Some havl0_ havl1 + _ -> spanItr + else let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` Some lhavl rhavl +----------------------------------------------------------------------- +--------------------------- spanL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | Span an AVL tree from the right, using the supplied predicate. This function returns +-- a pair of trees (l,r), where r contains the rightmost consecutive elements which +-- satisfy the predicate. The rightmost element of l (if any) is the first to fail +-- the predicate. Either of the resulting trees may be empty. Element ordering is preserved. +-- +-- Complexity: O(n), where n is the size of r. +spanR :: (e -> Bool) -> AVL e -> (AVL e, AVL e) +spanR p t = case spanIt t L(0) of -- Tree heights are relative + TheLot -> (E, t) -- All satisfied + Some (HAVL l _) (HAVL r _) -> (l, r) -- Some satisfied + where + spanIt E _ = TheLot + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + -- N.B: Never Returns (Some (HAVL E _) _) (== TheLot) + spanIt_ l hl e r hr = + case spanIt r hr of + Some havl0 havl1 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` Some havl0_ havl1 + TheLot -> if p e + then let spanItl = spanIt l hl + in case spanItl of + Some havl0 havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` Some havl0 havl1_ + _ -> spanItl + else let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` Some lhavl rhavl +----------------------------------------------------------------------- +--------------------------- spanR Ends Here --------------------------- +----------------------------------------------------------------------- + +-- Local Datatype for results of takeWhile/DropWhile operations. +data TakeWhileResult e = SomeTW (HAVL e) + | TheLotTW + +-- | This is a simplified version of 'spanL' which does not return the remaining tree +-- The result is the leftmost consecutive sequence of elements which satisfy the +-- supplied predicate (which may be empty). +-- +-- Complexity: O(n), where n is the size of the result. +takeWhileL :: (e -> Bool) -> AVL e -> AVL e +takeWhileL p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> t -- All satisfied + SomeTW (HAVL l _) -> l -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + let twl = spanIt l hl + in case twl of + TheLotTW -> if p e + then let twr = spanIt r hr + in case twr of + SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` SomeTW havl0_ + _ -> twr + else let lhavl = HAVL l hl in lhavl `seq` SomeTW lhavl + _ -> twl +----------------------------------------------------------------------- +------------------------- takeWhileL Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanR' which does not return the remaining tree +-- The result is the rightmost consecutive sequence of elements which satisfy the +-- supplied predicate (which may be empty). +-- +-- Complexity: O(n), where n is the size of the result. +takeWhileR :: (e -> Bool) -> AVL e -> AVL e +takeWhileR p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> t -- All satisfied + SomeTW (HAVL r _) -> r -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + let twr = spanIt r hr + in case twr of + TheLotTW -> if p e + then let twl = spanIt l hl + in case twl of + SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` SomeTW havl1_ + _ -> twl + else let rhavl = HAVL r hr in rhavl `seq` SomeTW rhavl + _ -> twr +----------------------------------------------------------------------- +------------------------- takeWhileR Ends Here ------------------------ +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanL' which does not return the tree containing +-- the elements which satisfy the supplied predicate. +-- The result is a tree whose leftmost element is the first to fail the predicate, starting from +-- the left (which may be empty). +-- +-- Complexity: O(n), where n is the number of elements dropped. +dropWhileL :: (e -> Bool) -> AVL e -> AVL e +dropWhileL p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> E -- All satisfied + SomeTW (HAVL r _) -> r -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + case spanIt l hl of + SomeTW havl1 -> let havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` SomeTW havl1_ + TheLotTW -> if p e + then spanIt r hr + else let rhavl = pushLHAVL e (HAVL r hr) + in rhavl `seq` SomeTW rhavl +----------------------------------------------------------------------- +---------------------- dropWhileL Ends Here --------------------------- +----------------------------------------------------------------------- + +-- | This is a simplified version of 'spanR' which does not return the tree containing +-- the elements which satisfy the supplied predicate. +-- The result is a tree whose rightmost element is the first to fail the predicate, starting from +-- the right (which may be empty). +-- +-- Complexity: O(n), where n is the number of elements dropped. +dropWhileR :: (e -> Bool) -> AVL e -> AVL e +dropWhileR p t = case spanIt t L(0) of -- Tree heights are relative + TheLotTW -> E -- All satisfied + SomeTW (HAVL l _) -> l -- Some satisfied + where + spanIt E _ = TheLotTW + spanIt (N l e r) h = spanIt_ l DECINT2(h) e r DECINT1(h) + spanIt (Z l e r) h = spanIt_ l DECINT1(h) e r DECINT1(h) + spanIt (P l e r) h = spanIt_ l DECINT1(h) e r DECINT2(h) + spanIt_ l hl e r hr = + case spanIt r hr of + SomeTW havl0 -> let havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` SomeTW havl0_ + TheLotTW -> if p e + then spanIt l hl + else let lhavl = pushRHAVL (HAVL l hl) e + in lhavl `seq` SomeTW lhavl +----------------------------------------------------------------------- +---------------------- dropWhileR Ends Here --------------------------- +----------------------------------------------------------------------- + + +-- | Rotate an AVL tree one place left. This function pops the leftmost element and pushes into +-- the rightmost position. An empty tree yields an empty tree. +-- +-- Complexity: O(log n) +rotateL :: AVL e -> AVL e +rotateL E = E +rotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> pushR t e_ +rotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> pushR t e_ +rotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> pushR t e_ + +-- | Rotate an AVL tree one place right. This function pops the rightmost element and pushes into +-- the leftmost position. An empty tree yields an empty tree. +-- +-- Complexity: O(log n) +rotateR :: AVL e -> AVL e +rotateR E = E +rotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> pushL e_ t +rotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> pushL e_ t +rotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> pushL e_ t + +-- | Similar to 'rotateL', but returns the rotated element. This function raises an error if +-- applied to an empty tree. +-- +-- Complexity: O(log n) +popRotateL :: AVL e -> (e, AVL e) +popRotateL E = error "popRotateL: Empty tree." +popRotateL (N l e r) = case popLN l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL (Z l e r) = case popLZ l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL (P l e r) = case popLP l e r of UBT2(e_,t) -> popRotateL' e_ t +popRotateL' :: e -> AVL e -> (e, AVL e) +popRotateL' e t = let t' = pushR t e in t' `seq` (e,t') + +-- | Similar to 'rotateR', but returns the rotated element. This function raises an error if +-- applied to an empty tree. +-- +-- Complexity: O(log n) +popRotateR :: AVL e -> (AVL e, e) +popRotateR E = error "popRotateR: Empty tree." +popRotateR (N l e r) = case popRN l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR (Z l e r) = case popRZ l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR (P l e r) = case popRP l e r of UBT2(t,e_) -> popRotateR' t e_ +popRotateR' :: AVL e -> e -> (AVL e, e) +popRotateR' t e = let t' = pushL e t in t' `seq` (t',e) + + +-- | Rotate an AVL tree left by n places. If s is the size of the tree then ordinarily n +-- should be in the range [0..s-1]. However, this function will deliver a correct result +-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases. +-- The result of rotating an empty tree is an empty tree. +-- +-- Complexity: O(n) +rotateByL :: AVL e -> Int -> AVL e +rotateByL t ASINT(n) = case COMPAREUINT n L(0) of + LT -> rotateByR__ t NEGATE(n) + EQ -> t + GT -> rotateByL__ t n +-- n>=0!! +{-# INLINE rotateByL_ #-} +rotateByL_ :: AVL e -> UINT -> AVL e +rotateByL_ t L(0) = t +rotateByL_ t n = rotateByL__ t n +-- n>0!! +rotateByL__ :: AVL e -> UINT -> AVL e +rotateByL__ E _ = E +rotateByL__ t n = case splitL n t L(0) of -- Tree Heights are relative!! + More L(0) -> t + More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!! + n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1 + in if ADDINT(n_,n_) LEQ s + then rotateByL_ t n_ -- n_ may be 0 !! + else rotateByR__ t SUBINT(s,n_) -- (s-n_) can't be 0 + All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl + + +-- | Rotate an AVL tree right by n places. If s is the size of the tree then ordinarily n +-- should be in the range [0..s-1]. However, this function will deliver a correct result +-- for any n (n\<0 or n\>=s), the actual rotation being given by (n \`mod\` s) in such cases. +-- The result of rotating an empty tree is an empty tree. +-- +-- Complexity: O(n) +rotateByR :: AVL e -> Int -> AVL e +rotateByR t ASINT(n) = case COMPAREUINT n L(0) of + LT -> rotateByL__ t NEGATE(n) + EQ -> t + GT -> rotateByR__ t n +-- n>=0!! +{-# INLINE rotateByR_ #-} +rotateByR_ :: AVL e -> UINT -> AVL e +rotateByR_ t L(0) = t +rotateByR_ t n = rotateByR__ t n +-- n>0!! +rotateByR__ :: AVL e -> UINT -> AVL e +rotateByR__ E _ = E +rotateByR__ t n = case splitR n t L(0) of -- Tree Heights are relative!! + More L(0) -> t + More m -> let s = SUBINT(n,m) -- Actual size of tree, > 0!! + n_ = _MODULO_(n,s) -- Actual shift required, 0..s-1 + in if ADDINT(n_,n_) LEQ s + then rotateByR_ t n_ -- n_ may be 0 !! + else rotateByL__ t SUBINT(s,n_) -- (s-n_) can_t be 0 + All (HAVL l hl) (HAVL r hr) -> joinH' r hr l hl + + +-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the +-- elements less than or equal to according to the supplied selector and r contains all the elements greater than +-- according to the supplied selector. +-- +-- Complexity: O(log n) +genForkL :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkL c avl = let (HAVL l _,HAVL r _) = genForkL_ L(0) avl -- Tree heights are relative + in (l,r) + where + genForkL_ h E = (HAVL E h, HAVL E h) + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = genForkL_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, havl1_) + -- Current element = pivot, so goes in left half and stop here + EQ -> let lhavl = pushRHAVL (HAVL l hl) e + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` (lhavl,rhavl) + -- Current element < pivot, so goes in left half + GT -> let (havl0,havl1) = genForkL_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, havl1) + +-- | Divide a sorted AVL tree into left and right sorted trees (l,r), such that l contains all the +-- elements less than supplied selector and r contains all the elements greater than or equal to the +-- supplied selector. +-- +-- Complexity: O(log n) +genForkR :: (e -> Ordering) -> AVL e -> (AVL e, AVL e) +genForkR c avl = let (HAVL l _,HAVL r _) = genForkR_ L(0) avl -- Tree heights are relative + in (l,r) + where + genForkR_ h E = (HAVL E h, HAVL E h) + genForkR_ h (N l e r) = genForkR__ l DECINT2(h) e r DECINT1(h) + genForkR_ h (Z l e r) = genForkR__ l DECINT1(h) e r DECINT1(h) + genForkR_ h (P l e r) = genForkR__ l DECINT1(h) e r DECINT2(h) + genForkR__ l hl e r hr = case c e of + -- Current element > pivot, so goes in right half + LT -> let (havl0,havl1) = genForkR_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, havl1_) + -- Current element = pivot, so goes in right half and stop here + EQ -> let rhavl = pushLHAVL e (HAVL r hr) + lhavl = HAVL l hl + in lhavl `seq` rhavl `seq` (lhavl, rhavl) + -- Current element < pivot, so goes in left half + GT -> let (havl0,havl1) = genForkR_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, havl1) + + +-- | Similar to 'genForkL' and 'genForkR', but returns any equal element found (instead of +-- incorporating it into the left or right tree results respectively). +-- +-- Complexity: O(log n) +genFork :: (e -> COrdering a) -> AVL e -> (AVL e, Maybe a, AVL e) +genFork c avl = let (HAVL l _, mba, HAVL r _) = genFork_ L(0) avl -- Tree heights are relative + in (l,mba,r) + where + genFork_ h E = (HAVL E h, Nothing, HAVL E h) + genFork_ h (N l e r) = genFork__ l DECINT2(h) e r DECINT1(h) + genFork_ h (Z l e r) = genFork__ l DECINT1(h) e r DECINT1(h) + genFork_ h (P l e r) = genFork__ l DECINT1(h) e r DECINT2(h) + genFork__ l hl e r hr = case c e of + -- Current element > pivot + Lt -> let (havl0,mba,havl1) = genFork_ hl l + havl1_ = spliceHAVL havl1 e (HAVL r hr) + in havl1_ `seq` (havl0, mba, havl1_) + -- Current element = pivot + Eq a -> let lhavl = HAVL l hl + rhavl = HAVL r hr + in lhavl `seq` rhavl `seq` (lhavl, Just a, rhavl) + -- Current element < pivot + Gt -> let (havl0,mba,havl1) = genFork_ hr r + havl0_ = spliceHAVL (HAVL l hl) e havl0 + in havl0_ `seq` (havl0_, mba, havl1) + +-- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- only those elements which are less than or equal to according to the supplied selector. +-- This function also has the synonym 'genDropGT'. +-- +-- Complexity: O(log n) +genTakeLE :: (e -> Ordering) -> AVL e -> AVL e +genTakeLE c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative + in l + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> genForkL_ hl l + EQ -> pushRHAVL (HAVL l hl) e + GT -> let havl0 = genForkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'genTakeLE'. +-- +-- Complexity: O(log n) +{-# INLINE genDropGT #-} +genDropGT :: (e -> Ordering) -> AVL e -> AVL e +genDropGT = genTakeLE + +-- | This is a simplified version of 'genForkL' which returns a sorted tree containing +-- only those elements which are greater according to the supplied selector. +-- This function also has the synonym 'genDropLE'. +-- +-- Complexity: O(log n) +genTakeGT :: (e -> Ordering) -> AVL e -> AVL e +genTakeGT c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative + in r + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> let havl1 = genForkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> HAVL r hr + GT -> genForkL_ hr r + +-- | A synonym for 'genTakeGT'. +-- +-- Complexity: O(log n) +{-# INLINE genDropLE #-} +genDropLE :: (e -> Ordering) -> AVL e -> AVL e +genDropLE = genTakeGT + +-- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- only those elements which are less than according to the supplied selector. +-- This function also has the synonym 'genDropGE'. +-- +-- Complexity: O(log n) +genTakeLT :: (e -> Ordering) -> AVL e -> AVL e +genTakeLT c avl = let HAVL l _ = genForkL_ L(0) avl -- Tree heights are relative + in l + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> genForkL_ hl l + EQ -> HAVL l hl + GT -> let havl0 = genForkL_ hr r + in spliceHAVL (HAVL l hl) e havl0 + + +-- | A synonym for 'genTakeLT'. +-- +-- Complexity: O(log n) +{-# INLINE genDropGE #-} +genDropGE :: (e -> Ordering) -> AVL e -> AVL e +genDropGE = genTakeLT + +-- | This is a simplified version of 'genForkR' which returns a sorted tree containing +-- only those elements which are greater or equal to according to the supplied selector. +-- This function also has the synonym 'genDropLT'. +-- +-- Complexity: O(log n) +genTakeGE :: (e -> Ordering) -> AVL e -> AVL e +genTakeGE c avl = let HAVL r _ = genForkL_ L(0) avl -- Tree heights are relative + in r + where + genForkL_ h E = HAVL E h + genForkL_ h (N l e r) = genForkL__ l DECINT2(h) e r DECINT1(h) + genForkL_ h (Z l e r) = genForkL__ l DECINT1(h) e r DECINT1(h) + genForkL_ h (P l e r) = genForkL__ l DECINT1(h) e r DECINT2(h) + genForkL__ l hl e r hr = case c e of + LT -> let havl1 = genForkL_ hl l + in spliceHAVL havl1 e (HAVL r hr) + EQ -> pushLHAVL e (HAVL r hr) + GT -> genForkL_ hr r + +-- | A synonym for 'genTakeGE'. +-- +-- Complexity: O(log n) +{-# INLINE genDropLT #-} +genDropLT :: (e -> Ordering) -> AVL e -> AVL e +genDropLT = genTakeGE + diff --git a/Data/Tree/AVL/Test/Counter.hs b/Data/Tree/AVL/Test/Counter.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Test/Counter.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Test.Counter +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines the 'XInt' type which is a specialised instance of 'Ord' which allows +-- the number of comparisons performed to be counted. This may be used evaluate various +-- algorithms. The functions defined here are not exported by the main "Data.Tree.AVL" +-- module. You need to import this module explicitly if you want to use any of them. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Test.Counter + (XInt(..), + getCount,resetCount, + ) where + +import System.IO.Unsafe(unsafePerformIO) +import Data.IORef(IORef,newIORef,readIORef,writeIORef) + +{-# NOINLINE count #-} +count :: IORef Int +count = unsafePerformIO $ newIORef 0 + +-- Increment the counter. +incCount :: IO () +incCount = do c <- readIORef count + let c' = c+1 in c' `seq` writeIORef count c' + +-- | Read the current comparison counter. +getCount :: IO Int +getCount = readIORef count + +-- | Reset the comparison counter to zero. +resetCount :: IO () +resetCount = writeIORef count 0 + +-- | Basic data type. +newtype XInt = XInt Int deriving (Eq,Show,Read) + +-- | A side effecting instance of Ord. +instance Ord XInt where + compare (XInt x) (XInt y) = unsafePerformIO $ do incCount + return $! compare x y + + diff --git a/Data/Tree/AVL/Test/Utils.hs b/Data/Tree/AVL/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Test/Utils.hs @@ -0,0 +1,223 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Test.Utils +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- 'AVL' tree related test and verification utilities. The functions defined +-- here are not exported by the main "Data.Tree.AVL" module. You need to +-- import this module explicitly if you want to use any of them. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Test.Utils + (-- * Correctness checking. + isBalanced,checkHeight,isSorted,isSortedOK, + -- * Test data generation. + TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL, + -- * Exhaustive tests. + exhaustiveTest, + -- * Tree parameter utilities. + minElements,maxElements, + -- * Testing BinPath module. + pathTree, + ) where + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.List(mapAVL',asTreeLenL,asListL) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- | Infinite test tree. Used for test purposes for BinPath module. +-- Value at each node is the path to that node. +pathTree :: AVL Int +pathTree = Z l 0 r where + l = mapIt (\n -> 2*n+1) pathTree + r = mapIt (\n -> 2*n+2) pathTree + -- Need special lazy map for this recursive tree defn + mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r') + mapIt _ _ = undefined + +-- | Verify that a tree is height balanced and that the BF of each node is correct. +-- +-- Complexity: O(n) +isBalanced :: AVL e -> Bool +isBalanced t = not (cH t EQL L(-1)) + +-- | Verify that a tree is balanced and the BF of each node is correct. +-- Returns (Just height) if so, otherwise Nothing. +-- +-- Complexity: O(n) +checkHeight :: AVL e -> Maybe Int +checkHeight t = let ht = cH t in if ht EQL L(-1) then Nothing else Just ASINT(ht) + +-- Local utility, returns height if balanced, -1 if not +cH :: AVL e -> UINT +cH E = L(0) +cH (N l _ r) = cH_ L(1) l r -- (hr-hl) = 1 +cH (Z l _ r) = cH_ L(0) l r -- (hr-hl) = 0 +cH (P l _ r) = cH_ L(1) r l -- (hl-hr) = 1 +cH_ :: UINT -> AVL e -> AVL e -> UINT +cH_ delta l r = let hl = cH l + in if hl EQL L(-1) then hl + else let hr = cH r + in if hr EQL L(-1) then hr + else if SUBINT(hr,hl) EQL delta then INCINT1(hr) + else L(-1) + +-- | Verify that a tree is sorted. +-- +-- Complexity: O(n) +isSorted :: (e -> e -> Ordering) -> AVL e -> Bool +isSorted c = isSorted' where + isSorted' E = True + isSorted' (N l e r) = isSorted'' l e r + isSorted' (Z l e r) = isSorted'' l e r + isSorted' (P l e r) = isSorted'' l e r + isSorted'' l e r = (isSortedU l e) && (isSortedL e r) + -- Verify tree is sorted and rightmost element is less than an upper limit (ul) + isSortedU E _ = True + isSortedU (N l e r) ul = isSortedU' l e r ul + isSortedU (Z l e r) ul = isSortedU' l e r ul + isSortedU (P l e r) ul = isSortedU' l e r ul + isSortedU' l e r ul = case c e ul of + LT -> (isSortedU l e) && (isSortedLU e r ul) + _ -> False + -- Verify tree is sorted and leftmost element is greater than a lower limit (ll) + isSortedL _ E = True + isSortedL ll (N l e r) = isSortedL' ll l e r + isSortedL ll (Z l e r) = isSortedL' ll l e r + isSortedL ll (P l e r) = isSortedL' ll l e r + isSortedL' ll l e r = case c e ll of + GT -> (isSortedLU ll l e) && (isSortedL e 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 _ E _ = True + isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul + isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul + isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul + isSortedLU' ll l e r ul = case c e ll of + GT -> case c e ul of + LT -> (isSortedLU ll l e) && (isSortedLU e r ul) + _ -> False + _ -> False +-- isSorted ends -- +------------------- + +-- | Verify that a tree is sorted, height balanced and the BF of each node is correct. +-- +-- Complexity: O(n) +isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool +isSortedOK c t = (isBalanced t) && (isSorted c t) + +-- | AVL Tree test data. Each element of a the list is a pair consisting of a height, +-- and list of all possible sorted trees of the same height, paired with their sizes. +-- The elements of each tree of size s are 0..s-1. +type TestTrees = [(Int, [(AVL Int, Int)])] + +-- | All possible sorted AVL trees. +allAVL :: TestTrees +allAVL = p0 : p1 : moreTrees p1 p0 where + p0 = (0, [(E , 0)]) -- All possible trees of height 0 + p1 = (1, [(Z E 0 E, 1)]) -- All possible trees of height 1 + -- Generate more trees of height N, from existing trees of height N-1 and N-2 + moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])] + moreTrees pN1@(hN1, tpsN1) -- Height N-1 + (_ , tpsN2) = -- Height N-2 + let hN0 = hN1 + 1 -- Height N + tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1] -- BF=+1 + [newTree N l r | l <- tpsN2 , r <- tpsN1]) -- BF=-1 + [newTree Z l r | l <- tpsN1 , r <- tpsN1] -- BF= 0 + pN0 = (hN0,tsN0) + in hN0 `seq` pN0 : moreTrees pN0 pN1 + -- Generate a new (tree,size) pair using the supplied constructor + newTree con (l,sizel) (r,sizer) = + let rootEl = sizel -- Value of new root element + addRight = sizel+1 -- Offset to add to elements of right sub-tree + newSize = addRight + sizer -- Size of the new tree + r' = mapAVL' (addRight+) r + t = r' `seq` con l rootEl r' + in newSize `seq` t `seq` (t, newSize) + -- interleave two lists (until one or other is []) + interleave [] ys = ys + interleave xs [] = xs + interleave (x:xs) (y:ys) = (x:y:interleave xs ys) + + +-- | Same as 'allAVL', but excluding the empty tree (of height 0). +allNonEmptyAVL :: TestTrees +allNonEmptyAVL = tail allAVL + +-- | Returns the number of possible AVL trees of a given height. +-- +-- Behaves as if defined.. +-- +-- > numTrees h = (\(_,xs) -> length xs) (allAVL !! h) +-- +-- and satisfies this recurrence relation.. +-- +-- @ +-- numTrees 0 = 1 +-- numTrees 1 = 1 +-- numTrees h = (2*(numTrees (h-2)) + (numTrees (h-1))) * (numTrees (h-1)) +-- @ +numTrees :: Int -> Integer +numTrees 0 = 1 +numTrees 1 = 1 +numTrees n = numTrees' 1 1 n where + numTrees' n1 n2 2 = (2*n2 + n1)*n1 + numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m-1) + +-- | Apply the test function to each AVL tree in the TestTrees argument, and report +-- progress as test proceeds. The first two arguments of the test function are +-- tree height and size respectively. +exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO () +exhaustiveTest f xs = mapM_ test xs where + test (h,tps) = do putStr "Tree Height : " >> print h + putStr "Number Of Trees: " >> print (numTrees h) + mapM_ test' tps + putStrLn "Done." + where test' (t,s) = if f h s t then return () -- putStr "." + else error $ show $ asListL t -- Temporary Hack + +-- | Generates a flat AVL tree of n elements [0..n-1]. +flatAVL :: Int -> AVL Int +flatAVL n = asTreeLenL n [0..n-1] + +-- | Detetermine the minimum number of elements in an AVL tree of given height. +-- This function satisfies this recurrence relation.. +-- +-- @ +-- minElements 0 = 0 +-- minElements 1 = 1 +-- minElements h = 1 + minElements (h-1) + minElements (h-2) +-- -- = Some weird expression involving the golden ratio +-- @ +minElements :: Int -> Integer +minElements 0 = 0 +minElements 1 = 1 +minElements h = minElements' 0 1 h where + minElements' n1 n2 2 = 1 + n1 + n2 + minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m-1) + +-- | Detetermine the maximum number of elements in an AVL tree of given height. +-- This function satisfies this recurrence relation.. +-- +-- @ +-- maxElements 0 = 0 +-- maxElements h = 1 + 2 * maxElements (h-1) -- = 2^h-1 +-- @ +maxElements :: Int -> Integer +maxElements 0 = 0 +maxElements h = maxElements' 0 h where + maxElements' n1 1 = 1 + 2*n1 + maxElements' n1 m = maxElements' (1 + 2*n1) (m-1) diff --git a/Data/Tree/AVL/Types.hs b/Data/Tree/AVL/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Types.hs @@ -0,0 +1,165 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Types +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- AVL Tree data type definition and a few simple utility functions. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Types + ( -- * Types. + AVL(..), + + -- * Simple AVL related utilities. + empty,isEmpty,isNonEmpty,singleton,pair,tryGetSingleton, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.Typeable +#if __GLASGOW_HASKELL__ > 604 +import Data.Foldable +import Data.Monoid +#endif + +-- | AVL tree data type. +-- +-- The balance factor (BF) of an 'AVL' tree node is defined as the difference between the height of +-- the left and right sub-trees. An 'AVL' tree is ALWAYS height balanced, such that |BF| <= 1. +-- The functions in this library ("Data.Tree.AVL") are designed so that they never construct +-- an unbalanced tree (well that's assuming they're not broken). The 'AVL' tree type defined here +-- has the BF encoded the constructors. +-- +-- Some functions in this library return 'AVL' trees that are also \"flat\", which (in the context +-- of this library) means that the sizes of left and right sub-trees differ by at most one and +-- are also flat. Flat sorted trees should give slightly shorter searches than sorted trees which +-- are merely height balanced. Whether or not flattening is worth the effort depends on the number +-- of times the tree will be searched and the cost of element comparison. +-- +-- In cases where the tree elements are sorted, all the relevant 'AVL' functions follow the +-- convention that the leftmost tree element is least and the rightmost tree element is +-- the greatest. Bear this in mind when defining general comparison functions. It should +-- also be noted that all functions in this library for sorted trees require that the tree +-- does not contain multiple elements which are \"equal\" (according to whatever criterion +-- has been used to sort the elements). +-- +-- It is important to be consistent about argument ordering when defining general purpose +-- comparison functions (or selectors) for searching a sorted tree, such as .. +-- +-- @ +-- myComp :: (k -> e -> Ordering) +-- -- or.. +-- myCComp :: (k -> e -> COrdering a) +-- @ +-- +-- In these cases the first argument is the search key and the second argument is an element of +-- the 'AVL' tree. For example.. +-- +-- @ +-- key \`myCComp\` element -> Lt implies key < element, proceed down the left sub-tree +-- key \`myCComp\` element -> Gt implies key > element, proceed down the right sub-tree +-- @ +-- +-- This convention is same as that used by the overloaded 'compare' method from 'Ord' class. +-- +-- WARNING: The constructors of this data type are exported from this module but not from +-- the top level 'AVL' wrapper ("Data.Tree.AVL"). Don't try to construct your own 'AVL' +-- trees unless you're sure you know what your doing. If you end up creating and using +-- 'AVL' trees that aren't you'll break most of the functions in this library. +-- +-- Controlling Strictness. +-- +-- The 'AVL' data type is declared as non-strict in all it's fields, +-- but all the functions in this library behave as though it is strict in its +-- recursive fields (left and right sub-trees). Strictness in the element field is +-- controlled either by using the strict variants of functions (defined in this library +-- where appropriate), or using strict variants of the combinators defined in "Data.COrdering", +-- or using 'seq' etc. in your own code (in any combining comparisons you define, for example). +-- +-- A note about 'Eq' and 'Ord' class instances. +-- +-- For 'AVL' trees the defined instances of 'Ord' and 'Eq' are based on the lists that are produced using +-- the 'Data.Tree.AVL.List.asListL' function (it could just as well have been 'Data.Tree.AVL.List.asListR', +-- the choice is arbitrary but I can only chose one). This means that two trees which contain the same elements +-- in the same order are equal regardless of detailed tree structure. The same principle has been applied to +-- the instances of 'Read' and 'Show'. Unfortunately, this has the undesirable and non-intuitive effect +-- of making \"equal\" trees potentially distinguishable using some functions (such as height). +-- All such functions have been placed in the Data.Tree.AVL.Internals modules, which are not +-- included in the main "Data.Tree.AVL" wrapper. For all \"normal\" functions (f) exported by "Data.Tree.AVL" +-- it is safe to assume that if a and b are 'AVL' trees then (a == b) implies (f a == f b), provided the same +-- is true for the tree elements. +-- +data AVL e = E -- ^ Empty Tree + | N (AVL e) e (AVL e) -- ^ BF=-1 (right height > left height) + | Z (AVL e) e (AVL e) -- ^ BF= 0 + | P (AVL e) e (AVL e) -- ^ BF=+1 (left height > right height) + +-- A name for the AVL type constructor, fully qualified +avlTyConName :: String +avlTyConName = "Data.Tree.AVL.AVL" + +-- A Typeable1 instance +instance Typeable1 AVL where + typeOf1 _ = mkTyConApp (mkTyCon avlTyConName) [] + +#ifndef _GLASGOW_HASKELL_ +-- A Typeable instance (not needed by ghc, but Haddock fails to document this instance) +instance Typeable e => Typeable (AVL e) where + typeOf = typeOfDefault +#endif + +#if __GLASGOW_HASKELL__ > 604 +instance Foldable AVL where + foldMap _f E = mempty + foldMap f (N l v r) = foldMap f l `mappend` f v `mappend` foldMap f r + foldMap f (Z l v r) = foldMap f l `mappend` f v `mappend` foldMap f r + foldMap f (P l v r) = foldMap f l `mappend` f v `mappend` foldMap f r +#endif + +-- | The empty AVL tree. +{-# INLINE empty #-} +empty :: AVL e +empty = E + +-- | Returns 'True' if an AVL tree is empty. +-- +-- Complexity: O(1) +{-# INLINE isEmpty #-} +isEmpty :: AVL e -> Bool +isEmpty E = True +isEmpty _ = False + +-- | Returns 'True' if an AVL tree is non-empty. +-- +-- Complexity: O(1) +{-# INLINE isNonEmpty #-} +isNonEmpty :: AVL e -> Bool +isNonEmpty E = False +isNonEmpty _ = True + +-- | Creates an AVL tree with just one element. +-- +-- Complexity: O(1) +{-# INLINE singleton #-} +singleton :: e -> AVL e +singleton e = Z E e E + +-- | Create an AVL tree of two elements, occuring in same order as the arguments. +{-# INLINE pair #-} +pair :: e -> e -> AVL e +pair e0 e1 = P (Z E e0 E) e1 E + +-- | If the AVL tree is a singleton (has only one element @e@) then this function returns @('Just' e)@. +-- Otherwise it returns Nothing. +-- +-- Complexity: O(1) +{-# INLINE tryGetSingleton #-} +tryGetSingleton :: AVL e -> Maybe e +tryGetSingleton (Z E e _) = Just e -- Right subtree must be E too, but no need to waste time checking +tryGetSingleton _ = Nothing diff --git a/Data/Tree/AVL/Write.hs b/Data/Tree/AVL/Write.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Write.hs @@ -0,0 +1,198 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Write +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- This module defines useful functions for searching AVL trees and writing +-- information to a particular element. The functions defined here may +-- alter the content of a tree (values of tree elements) but not the structure +-- of a tree (no insertion or deletion). +----------------------------------------------------------------------------- +module Data.Tree.AVL.Write + (-- ** Writing to extreme left or right. + -- | I'm not sure these are likely to be much use in practice, but they're + -- simple enough to implement so are included for the sake of completeness. + writeL,tryWriteL,writeR,tryWriteR, + + -- * Writing to /sorted/ trees. + genWrite,genWriteFast,genTryWrite,genWriteMaybe,genTryWriteMaybe + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.COrdering +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPathWith,writePath) + +--------------------------------------------------------------------------- +-- writeL, tryWriteL -- +--------------------------------------------------------------------------- +-- | Replace the left most element of a tree with the supplied new element. +-- This function raises an error if applied to an empty tree. +-- +-- Complexity: O(log n) +writeL :: e -> AVL e -> AVL e +writeL _ E = error "writeL: Empty Tree" +writeL e' (N l e r) = writeLN e' l e r +writeL e' (Z l e r) = writeLZ e' l e r +writeL e' (P l e r) = writeLP e' l e r + +-- | Similar to 'writeL', but returns 'Nothing' if applied to an empty tree. +-- +-- Complexity: O(log n) +tryWriteL :: e -> AVL e -> Maybe (AVL e) +tryWriteL _ E = Nothing +tryWriteL e' (N l e r) = Just $! writeLN e' l e r +tryWriteL e' (Z l e r) = Just $! writeLZ e' l e r +tryWriteL e' (P l e r) = Just $! writeLP e' l e r + +-- This version of writeL is for trees which are known to be non-empty. +writeL' :: e -> AVL e -> AVL e +writeL' _ E = error "writeL': Bug0" +writeL' e' (N l e r) = writeLN e' l e r -- l may be empty +writeL' e' (Z l e r) = writeLZ e' l e r -- l may be empty +writeL' e' (P l e r) = writeLP e' l e r -- l can't be empty + +-- Write to left sub-tree of N l e r, or here if l is empty +writeLN :: e -> AVL e -> e -> AVL e -> AVL e +writeLN e' E _ r = N E e' r +writeLN e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` N l' e r +writeLN e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` N l' e r +writeLN e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` N l' e r + +-- Write to left sub-tree of Z l e r, or here if l is empty +writeLZ :: e -> AVL e -> e -> AVL e -> AVL e +writeLZ e' E _ r = Z E e' r -- r must be E too! +writeLZ e' (N ll le lr) e r = let l' = writeLN e' ll le lr in l' `seq` Z l' e r +writeLZ e' (Z ll le lr) e r = let l' = writeLZ e' ll le lr in l' `seq` Z l' e r +writeLZ e' (P ll le lr) e r = let l' = writeLP e' ll le lr in l' `seq` Z l' e r + +-- Write to left sub-tree of P l e r (l can't be empty) +{-# INLINE writeLP #-} +writeLP :: e -> AVL e -> e -> AVL e -> AVL e +writeLP e' l e r = let l' = writeL' e' l in l' `seq` P l' e r +--------------------------------------------------------------------------- +-- writeL, tryWriteL end here -- +--------------------------------------------------------------------------- + + +--------------------------------------------------------------------------- +-- writeR, tryWriteR -- +--------------------------------------------------------------------------- +-- | Replace the right most element of a tree with the supplied new element. +-- This function raises an error if applied to an empty tree. +-- +-- Complexity: O(log n) +writeR :: AVL e -> e -> AVL e +writeR E _ = error "writeR: Empty Tree" +writeR (N l e r) e' = writeRN l e r e' +writeR (Z l e r) e' = writeRZ l e r e' +writeR (P l e r) e' = writeRP l e r e' + +-- | Similar to 'writeR', but returns 'Nothing' if applied to an empty tree. +-- +-- Complexity: O(log n) +tryWriteR :: AVL e -> e -> Maybe (AVL e) +tryWriteR E _ = Nothing +tryWriteR (N l e r) e' = Just $! writeRN l e r e' +tryWriteR (Z l e r) e' = Just $! writeRZ l e r e' +tryWriteR (P l e r) e' = Just $! writeRP l e r e' + +-- This version of writeR is for trees which are known to be non-empty. +writeR' :: AVL e -> e -> AVL e +writeR' E _ = error "writeR': Bug0" +writeR' (N l e r) e' = writeRN l e r e' -- r can't be empty +writeR' (Z l e r) e' = writeRZ l e r e' -- r may be empty +writeR' (P l e r) e' = writeRP l e r e' -- r may be empty + +-- Write to right sub-tree of N l e r (r can't be empty) +{-# INLINE writeRN #-} +writeRN :: AVL e -> e -> AVL e -> e -> AVL e +writeRN l e r e' = let r' = writeR' r e' in r' `seq` N l e r' + +-- Write to right sub-tree of Z l e r, or here if r is empty +writeRZ :: AVL e -> e -> AVL e -> e -> AVL e +writeRZ l _ E e' = Z l e' E -- l must be E too! +writeRZ l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` Z l e r' +writeRZ l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` Z l e r' +writeRZ l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` Z l e r' + +-- Write to right sub-tree of P l e r, or here if r is empty +writeRP :: AVL e -> e -> AVL e -> e -> AVL e +writeRP l _ E e' = P l e' E +writeRP l e (N rl re rr) e' = let r' = writeRN rl re rr e' in r' `seq` P l e r' +writeRP l e (Z rl re rr) e' = let r' = writeRZ rl re rr e' in r' `seq` P l e r' +writeRP l e (P rl re rr) e' = let r' = writeRP rl re rr e' in r' `seq` P l e r' +--------------------------------------------------------------------------- +-- writeR, tryWriteR end here -- +--------------------------------------------------------------------------- + + +-- | A general purpose function to perform a search of a tree, using the supplied selector. +-- If the search succeeds the found element is replaced by the value (@e@) of the @('Eq' e)@ +-- constructor returned by the selector. If the search fails this function returns the original tree. +-- +-- Complexity: O(log n) +genWrite :: (e -> COrdering e) -> AVL e -> AVL e +genWrite c t = case genOpenPathWith c t of + FullBP pth e -> writePath pth e t + _ -> t + +-- | Functionally identical to 'genWrite', but returns an identical tree (one with all the nodes on +-- the path duplicated) if the search fails. This should probably only be used if you know the +-- search will succeed and will return an element which is different from that already present. +-- +-- Complexity: O(log n) +genWriteFast :: (e -> COrdering e) -> AVL e -> AVL e +genWriteFast c = write where + write E = E + write (N l e r) = case c e of + Lt -> let l' = write l in l' `seq` N l' e r + Eq v -> N l v r + Gt -> let r' = write r in r' `seq` N l e r' + write (Z l e r) = case c e of + Lt -> let l' = write l in l' `seq` Z l' e r + Eq v -> Z l v r + Gt -> let r' = write r in r' `seq` Z l e r' + write (P l e r) = case c e of + Lt -> let l' = write l in l' `seq` P l' e r + Eq v -> P l v r + Gt -> let r' = write r in r' `seq` P l e r' + +-- | A general purpose function to perform a search of a tree, using the supplied selector. +-- The found element is replaced by the value (@e@) of the @('Eq' e)@ constructor returned by +-- the selector. This function returns 'Nothing' if the search failed. +-- +-- Complexity: O(log n) +genTryWrite :: (e -> COrdering e) -> AVL e -> Maybe (AVL e) +genTryWrite c t = case genOpenPathWith c t of + FullBP pth e -> Just $! writePath pth e t + _ -> Nothing + +-- | Similar to 'genWrite', but also returns the original tree if the search succeeds but +-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn +-- rate if it\'s likely that no modification of the value is needed.) +-- +-- Complexity: O(log n) +genWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> AVL e +genWriteMaybe c t = case genOpenPathWith c t of + FullBP pth (Just e) -> writePath pth e t + _ -> t + +-- | Similar to 'genTryWrite', but also returns the original tree if the search succeeds but +-- the selector returns @('Eq' 'Nothing')@. (This version is intended to help reduce heap burn +-- rate if it\'s likely that no modification of the value is needed.) +-- +-- Complexity: O(log n) +genTryWriteMaybe :: (e -> COrdering (Maybe e)) -> AVL e -> Maybe (AVL e) +genTryWriteMaybe c t = case genOpenPathWith c t of + FullBP pth (Just e) -> Just $! writePath pth e t + FullBP _ Nothing -> Just t + _ -> Nothing + + diff --git a/Data/Tree/AVL/Zipper.hs b/Data/Tree/AVL/Zipper.hs new file mode 100644 --- /dev/null +++ b/Data/Tree/AVL/Zipper.hs @@ -0,0 +1,902 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.AVL.Zipper +-- Copyright : (c) Adrian Hey 2004,2005 +-- License : BSD3 +-- +-- Maintainer : http://homepages.nildram.co.uk/~ahey/em.png +-- Stability : stable +-- Portability : portable +-- +-- An implementation of \"The Zipper\" for AVL trees. This can be used like +-- a functional pointer to a serial data structure which can be navigated +-- and modified, without having to worry about all those tricky tree balancing +-- issues. See JFP Vol.7 part 5 or .. +-- +-- +-- +-- Notes about efficiency: +-- +-- The functions defined here provide a useful way to achieve those awkward +-- operations which may not be covered by the rest of this package. They're +-- reasonably efficient (mostly O(log n) or better), but zipper flexibility +-- is bought at the expense of keeping path information explicitly as a heap +-- data structure rather than implicitly on the stack. Since heap storage +-- probably costs more, zipper operations will are likely to incur higher +-- constant factors than equivalent non-zipper operations (if available). +-- +-- Some of the functions provided here may appear to be weird combinations of +-- functions from a more logical set of primitives. They are provided because +-- they are not really simple combinations of the corresponding primitives. +-- They are more efficient, so you should use them if possible (e.g combining +-- deleting with Zipper closing). +-- +-- Also, consider using the 'BAVL' as a cheaper alternative if you don't actually +-- need to navigate the tree. +----------------------------------------------------------------------------- +module Data.Tree.AVL.Zipper + (-- * Types. + ZAVL,PAVL, + + -- * Opening. + assertOpenL,assertOpenR, + tryOpenL,tryOpenR, + genAssertOpen,genTryOpen, + genTryOpenGE,genTryOpenLE, + genOpenEither, + + -- * Closing. + close,fillClose, + + -- * Manipulating the current element. + getCurrent,putCurrent,applyCurrent,applyCurrent', + + -- * Moving. + assertMoveL,assertMoveR,tryMoveL,tryMoveR, + + -- * Inserting elements. + insertL,insertR,insertMoveL,insertMoveR,fill, + + -- * Deleting elements. + delClose, + assertDelMoveL,assertDelMoveR,tryDelMoveR,tryDelMoveL, + delAllL,delAllR, + delAllCloseL,delAllCloseR, + delAllIncCloseL,delAllIncCloseR, + + -- * Inserting AVL trees. + insertTreeL,insertTreeR, + + -- * Current element status. + isLeftmost,isRightmost, + sizeL,sizeR, + + -- * Operations on whole zippers. + sizeZAVL, + + -- * A cheaper option is to use BAVL + -- | These are a cheaper but more restrictive alternative to using the full Zipper. + -- They use \"Binary Paths\" (Ints) to point to a particular element of an 'AVL' tree. + -- Use these when you don't need to navigate the tree, you just want to look at a + -- particular element (and perhaps modify or delete it). The advantage of these is + -- that they don't create the usual Zipper heap structure, so they will be faster + -- (and reduce heap burn rate too). + -- + -- If you subsequently decide you need a Zipper rather than a BAVL then some conversion + -- utilities are provided. + + -- ** Types. + BAVL, + + -- ** Opening and closing. + genOpenBAVL,closeBAVL, + + -- ** Inspecting status. + fullBAVL,emptyBAVL,tryReadBAVL,readFullBAVL, + + -- ** Modifying the tree. + pushBAVL,deleteBAVL, + + -- ** Converting to BAVL to Zipper. + -- | These are O(log n) operations but with low constant factors because no comparisons + -- are required (and the tree nodes on the path will most likely still be in cache as + -- a result of opening the BAVL in the first place). + fullBAVLtoZAVL,emptyBAVLtoPAVL,anyBAVLtoEither, + + ) where + +import Prelude -- so haddock finds the symbols there + +import Data.Tree.AVL.Types(AVL(..)) +import Data.Tree.AVL.Size(size,addSize) +import Data.Tree.AVL.Internals.DelUtils(deletePath,popRN,popRZ,popRP,popLN,popLZ,popLP) +import Data.Tree.AVL.Internals.HeightUtils(height,addHeight) +import Data.Tree.AVL.Internals.HJoin(spliceH,joinH) +import Data.Tree.AVL.Internals.HPush(pushHL,pushHR) +import Data.Tree.AVL.Internals.BinPath(BinPath(..),genOpenPath,writePath,insertPath,sel,goL,goR) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#include "ghcdefs.h" +#else +#include "h98defs.h" +#endif + +-- N.B. Zippers are always opened using relative heights for efficiency reasons. On the +-- whole this causes no problems, except when inserting entire AVL trees or substituting +-- the empty tree. (These cases have some minor height computation overhead). + +-- | Abstract data type for a successfully opened AVL tree. All ZAVL\'s are non-empty! +-- A ZAVL can be tought of as a functional pointer to an AVL tree element. +data ZAVL e = ZAVL (Path e) (AVL e) !UINT e (AVL e) !UINT + +-- | Abstract data type for an unsuccessfully opened AVL tree. +-- A PAVL can be tought of as a functional pointer to the gap +-- where the expected element should be (but isn't). You can fill this gap using +-- the 'fill' function, or fill and close at the same time using the 'fillClose' function. +data PAVL e = PAVL (Path e) !UINT + +data Path e = EP -- Empty Path + | LP (Path e) e (AVL e) !UINT -- Left subtree was taken + | RP (Path e) e (AVL e) !UINT -- Right subtree was taken + +-- Local Closing Utility +close_ :: Path e -> AVL e -> UINT -> AVL e +close_ EP t _ = t +close_ (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht +close_ (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht + +-- Local Utility to remove all left paths from a path +noLP :: Path e -> Path e +noLP EP = EP +noLP (LP p _ _ _ ) = noLP p +noLP (RP p e l hl) = let p_ = noLP p in p_ `seq` RP p_ e l hl + +-- Local Utility to remove all right paths from a path +noRP :: Path e -> Path e +noRP EP = EP +noRP (LP p e r hr) = let p_ = noRP p in p_ `seq` LP p_ e r hr +noRP (RP p _ _ _ ) = noRP p + +-- Local Closing Utility which ignores all left paths +closeNoLP :: Path e -> AVL e -> UINT -> AVL e +closeNoLP EP t _ = t +closeNoLP (LP p _ _ _ ) l hl = closeNoLP p l hl +closeNoLP (RP p e l hl) r hr = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoLP p t ht + +-- Local Closing Utility which ignores all right paths +closeNoRP :: Path e -> AVL e -> UINT -> AVL e +closeNoRP EP t _ = t +closeNoRP (LP p e r hr) l hl = case spliceH l hl e r hr of UBT2(t,ht) -> closeNoRP p t ht +closeNoRP (RP p _ _ _ ) r hr = closeNoRP p r hr + +-- Add size of all path elements. +addSizeP :: Int -> Path e -> Int +addSizeP n EP = n +addSizeP n (LP p _ r _) = addSizeP (addSize (n+1) r) p +addSizeP n (RP p _ l _) = addSizeP (addSize (n+1) l) p + +-- Add size of all RP path elements. +addSizeRP :: Int -> Path e -> Int +addSizeRP n EP = n +addSizeRP n (LP p _ _ _) = addSizeRP n p +addSizeRP n (RP p _ l _) = addSizeRP (addSize (n+1) l) p + +-- Add size of all LP path elements. +addSizeLP :: Int -> Path e -> Int +addSizeLP n EP = n +addSizeLP n (LP p _ r _) = addSizeLP (addSize (n+1) r) p +addSizeLP n (RP p _ _ _) = addSizeLP n p + +-- | Opens a sorted AVL tree at the element given by the supplied selector. This function +-- raises an error if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genAssertOpen :: (e -> Ordering) -> AVL e -> ZAVL e +genAssertOpen c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op _ _ E = error "genAssertOpen: No matching element." + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the element given by the supplied selector. +-- This function returns 'Nothing' if there is no such element. +-- +-- Note that this operation will still create a zipper path structure on the heap (which +-- is promptly discarded) if the search fails, and so is potentially inefficient if failure +-- is likely. In cases like this it may be better to use 'genOpenBAVL', test for \"fullness\" +-- using 'fullBAVL' and then convert to a 'ZAVL' using 'fullBAVLtoZAVL'. +-- +-- Complexity: O(log n) +genTryOpen :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpen c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> Maybe (ZAVL e) + op _ _ E = Nothing + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the least element which is greater than or equal, according to +-- the supplied selector. This function returns 'Nothing' if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genTryOpenGE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenGE c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op p h E = backupR p E h where + backupR EP _ _ = Nothing + backupR (LP p_ e r hr) l hl = Just $! ZAVL p_ l hl e r hr + backupR (RP p_ e l hl) r hr = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupR p_ t_ ht_ + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Attempts to open a sorted AVL tree at the greatest element which is less than or equal, according to +-- the supplied selector. This function returns _Nothing_ if the tree does not contain such an element. +-- +-- Complexity: O(log n) +genTryOpenLE :: (e -> Ordering) -> AVL e -> Maybe (ZAVL e) +genTryOpenLE c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> ZAVL e + op p h E = backupL p E h where + backupL EP _ _ = Nothing + backupL (LP p_ e r hr) l hl = case spliceH l hl e r hr of UBT2(t_,ht_) -> backupL p_ t_ ht_ + backupL (RP p_ e l hl) r hr = Just $! ZAVL p_ l hl e r hr + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Just $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Just $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Opens a non-empty AVL tree at the leftmost element. +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(log n) +assertOpenL :: AVL e -> ZAVL e +assertOpenL E = error "assertOpenL: Empty tree." +assertOpenL (N l e r) = openLN EP L(0) l e r -- Relative heights !! +assertOpenL (Z l e r) = openLZ EP L(0) l e r -- Relative heights !! +assertOpenL (P l e r) = openL_ (LP EP e r L(0)) L(1) l -- Relative heights !! + +-- | Attempts to open a non-empty AVL tree at the leftmost element. +-- This function returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryOpenL :: AVL e -> Maybe (ZAVL e) +tryOpenL E = Nothing +tryOpenL (N l e r) = Just $! openLN EP L(0) l e r -- Relative heights !! +tryOpenL (Z l e r) = Just $! openLZ EP L(0) l e r -- Relative heights !! +tryOpenL (P l e r) = Just $! openL_ (LP EP e r L(0)) L(1) l -- Relative heights !! + +-- Local utility for opening at the leftmost element, using current path and height. +openL_ :: (Path e) -> UINT -> AVL e -> ZAVL e +openL_ _ _ E = error "openL_: Bug0" +openL_ p h (N l e r) = openLN p h l e r +openL_ p h (Z l e r) = openLZ p h l e r +openL_ p h (P l e r) = let p_ = LP p e r DECINT2(h) in p_ `seq` openL_ p_ DECINT1(h) l + +-- Open leftmost of (N l e r), where l may be E +openLN :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openLN p h E e r = ZAVL p E DECINT2(h) e r DECINT1(h) +openLN p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT2(h) ll le lr +openLN p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT2(h) ll le lr +openLN p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h) + p__ = p_ `seq` LP p_ le lr DECINT4(h) + in p__ `seq` openL_ p__ DECINT3(h) ll +-- Open leftmost of (Z l e r), where l may be E +openLZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openLZ p h E e r = ZAVL p E DECINT1(h) e r DECINT1(h) +openLZ p h (N ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLN p_ DECINT1(h) ll le lr +openLZ p h (Z ll le lr) e r = let p_ = LP p e r DECINT1(h) in p_ `seq` openLZ p_ DECINT1(h) ll le lr +openLZ p h (P ll le lr) e r = let p_ = LP p e r DECINT1(h) + p__ = p_ `seq` LP p_ le lr DECINT3(h) + in p__ `seq` openL_ p__ DECINT2(h) ll + +-- | Opens a non-empty AVL tree at the rightmost element. +-- This function raises an error if the tree is empty. +-- +-- Complexity: O(log n) +assertOpenR :: AVL e -> ZAVL e +assertOpenR E = error "assertOpenR: Empty tree." +assertOpenR (N l e r) = openR_ (RP EP e l L(0)) L(1) r -- Relative heights !! +assertOpenR (Z l e r) = openRZ EP L(0) l e r -- Relative heights !! +assertOpenR (P l e r) = openRP EP L(0) l e r -- Relative heights !! + +-- | Attempts to open a non-empty AVL tree at the rightmost element. +-- This function returns 'Nothing' if the tree is empty. +-- +-- Complexity: O(log n) +tryOpenR :: AVL e -> Maybe (ZAVL e) +tryOpenR E = Nothing +tryOpenR (N l e r) = Just $! openR_ (RP EP e l L(0)) L(1) r -- Relative heights !! +tryOpenR (Z l e r) = Just $! openRZ EP L(0) l e r -- Relative heights !! +tryOpenR (P l e r) = Just $! openRP EP L(0) l e r -- Relative heights !! + +-- Local utility for opening at the rightmost element, using current path and height. +openR_ :: (Path e) -> UINT -> AVL e -> ZAVL e +openR_ _ _ E = error "openR_: Bug0" +openR_ p h (N l e r) = let p_ = RP p e l DECINT2(h) in p_ `seq` openR_ p_ DECINT1(h) r +openR_ p h (Z l e r) = openRZ p h l e r +openR_ p h (P l e r) = openRP p h l e r +-- Open rightmost of (P l e r), where r may be E +openRP :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openRP p h l e E = ZAVL p l DECINT1(h) e E DECINT2(h) +openRP p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h) + p__ = p_ `seq` RP p_ re rl DECINT4(h) + in p__ `seq` openR_ p__ DECINT3(h) rr +openRP p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT2(h) rl re rr +openRP p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT2(h) rl re rr +-- Open rightmost of (Z l e r), where r may be E +openRZ :: (Path e) -> UINT -> AVL e -> e -> AVL e -> ZAVL e +openRZ p h l e E = ZAVL p l DECINT1(h) e E DECINT1(h) +openRZ p h l e (N rl re rr) = let p_ = RP p e l DECINT1(h) + p__ = p_ `seq` RP p_ re rl DECINT3(h) + in p__ `seq` openR_ p__ DECINT2(h) rr +openRZ p h l e (Z rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRZ p_ DECINT1(h) rl re rr +openRZ p h l e (P rl re rr) = let p_ = RP p e l DECINT1(h) in p_ `seq` openRP p_ DECINT1(h) rl re rr + +-- | Returns @('Right' zavl)@ if the expected element was found, @('Left' pavl)@ if the +-- expected element was not found. It's OK to use this function on empty trees. +-- +-- Complexity: O(log n) +genOpenEither :: (e -> Ordering) -> AVL e -> Either (PAVL e) (ZAVL e) +genOpenEither c t = op EP L(0) t where -- Relative heights !! + -- op :: (Path e) -> UINT -> AVL e -> Either (PAVL e) (ZAVL e) + op p h E = Left $! PAVL p h + op p h (N l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT2(h) l + EQ -> Right $! ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` op p_ DECINT1(h) r + op p h (Z l e r) = case c e of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT1(h) r + op p h (P l e r) = case c e of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` op p_ DECINT1(h) l + EQ -> Right $! ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` op p_ DECINT2(h) r + +-- | Fill the gap pointed to by a 'PAVL' with the supplied element, which becomes +-- the current element of the resulting 'ZAVL'. The supplied filling element should +-- be \"equal\" to the value used in the search which created the 'PAVL'. +-- +-- Complexity: O(1) +fill :: e -> PAVL e -> ZAVL e +fill e (PAVL p h) = ZAVL p E h e E h + +-- | Essentially the same operation as 'fill', but the resulting 'ZAVL' is closed +-- immediately. +-- +-- Complexity: O(log n) +fillClose :: e -> PAVL e -> AVL e +fillClose e (PAVL p h) = close_ p (Z E e E) INCINT1(h) + +-- | Closes a Zipper. +-- +-- Complexity: O(log n) +close :: ZAVL e -> AVL e +close (ZAVL p l hl e r hr) = case spliceH l hl e r hr of UBT2(t,ht) -> close_ p t ht + +-- | Deletes the current element and then closes the Zipper. +-- +-- Complexity: O(log n) +delClose :: ZAVL e -> AVL e +delClose (ZAVL p l hl _ r hr) = case joinH l hl r hr of UBT2(t,ht) -> close_ p t ht + +-- | Gets the current element of a Zipper. +-- +-- Complexity: O(1) +getCurrent :: ZAVL e -> e +getCurrent (ZAVL _ _ _ e _ _) = e + +-- | Overwrites the current element of a Zipper. +-- +-- Complexity: O(1) +putCurrent :: e -> ZAVL e -> ZAVL e +putCurrent e (ZAVL p l hl _ r hr) = ZAVL p l hl e r hr + +-- | Applies a function to the current element of a Zipper (lazily). +-- See also 'applyCurrent'' for a strict version of this function. +-- +-- Complexity: O(1) +applyCurrent :: (e -> e) -> ZAVL e -> ZAVL e +applyCurrent f (ZAVL p l hl e r hr) = ZAVL p l hl (f e) r hr + +-- | Applies a function to the current element of a Zipper strictly. +-- See also 'applyCurrent' for a non-strict version of this function. +-- +-- Complexity: O(1) +applyCurrent' :: (e -> e) -> ZAVL e -> ZAVL e +applyCurrent' f (ZAVL p l hl e r hr) = let e_ = f e in e_ `seq` ZAVL p l hl e_ r hr + +-- | Moves one step left. +-- This function raises an error if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertMoveL :: ZAVL e -> ZAVL e +assertMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht + where cR EP _ _ = error "assertMoveL: Can't move left." + cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht + cR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertMoveL (ZAVL p (N ll le lr) hl e r hr) = let p_ = RP (LP p e r hr) le ll DECINT2(hl) + in p_ `seq` openR_ p_ DECINT1(hl) lr +assertMoveL (ZAVL p (Z ll le lr) hl e r hr) = openRZ (LP p e r hr) hl ll le lr +assertMoveL (ZAVL p (P ll le lr) hl e r hr) = openRP (LP p e r hr) hl ll le lr + +-- | Attempts to move one step left. +-- This function returns 'Nothing' if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryMoveL :: ZAVL e -> Maybe (ZAVL e) +tryMoveL (ZAVL p E _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> cR p t ht + where cR EP _ _ = Nothing + cR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cR p_ t ht + cR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryMoveL (ZAVL p (N ll le lr) hl e r hr) = Just $! let p_ = RP (LP p e r hr) le ll DECINT2(hl) + in p_ `seq` openR_ p_ DECINT1(hl) lr +tryMoveL (ZAVL p (Z ll le lr) hl e r hr) = Just $! openRZ (LP p e r hr) hl ll le lr +tryMoveL (ZAVL p (P ll le lr) hl e r hr) = Just $! openRP (LP p e r hr) hl ll le lr + +-- | Moves one step right. +-- This function raises an error if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertMoveR :: ZAVL e -> ZAVL e +assertMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht + where cL EP _ _ = error "assertMoveR: Can't move right." + cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht + cL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertMoveR (ZAVL p l hl e (N rl re rr) hr) = openLN (RP p e l hl) hr rl re rr +assertMoveR (ZAVL p l hl e (Z rl re rr) hr) = openLZ (RP p e l hl) hr rl re rr +assertMoveR (ZAVL p l hl e (P rl re rr) hr) = let p_ = LP (RP p e l hl) re rr DECINT2(hr) + in p_ `seq` openL_ p_ DECINT1(hr) rl + +-- | Attempts to move one step right. +-- This function returns 'Nothing' if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryMoveR :: ZAVL e -> Maybe (ZAVL e) +tryMoveR (ZAVL p l hl e E _ ) = case pushHR l hl e of UBT2(t,ht) -> cL p t ht + where cL EP _ _ = Nothing + cL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> cL p_ t ht + cL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryMoveR (ZAVL p l hl e (N rl re rr) hr) = Just $! openLN (RP p e l hl) hr rl re rr +tryMoveR (ZAVL p l hl e (Z rl re rr) hr) = Just $! openLZ (RP p e l hl) hr rl re rr +tryMoveR (ZAVL p l hl e (P rl re rr) hr) = Just $! let p_ = LP (RP p e l hl) re rr DECINT2(hr) + in p_ `seq` openL_ p_ DECINT1(hr) rl + +-- | Returns 'True' if the current element is the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +isLeftmost :: ZAVL e -> Bool +isLeftmost (ZAVL p E _ _ _ _) = iL p + where iL EP = True + iL (LP p_ _ _ _) = iL p_ + iL (RP _ _ _ _) = False +isLeftmost (ZAVL _ _ _ _ _ _) = False + +-- | Returns 'True' if the current element is the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +isRightmost :: ZAVL e -> Bool +isRightmost (ZAVL p _ _ _ E _) = iR p + where iR EP = True + iR (RP p_ _ _ _) = iR p_ + iR (LP _ _ _ _) = False +isRightmost (ZAVL _ _ _ _ _ _) = False + +-- | Inserts a new element to the immediate left of the current element. +-- +-- Complexity: O(1) average, O(log n) worst case. +insertL :: e -> ZAVL e -> ZAVL e +insertL e0 (ZAVL p l hl e1 r hr) = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr + +-- | Inserts a new element to the immediate left of the current element and then +-- moves one step left (so the newly inserted element becomes the current element). +-- +-- Complexity: O(1) average, O(log n) worst case. +insertMoveL :: e -> ZAVL e -> ZAVL e +insertMoveL e0 (ZAVL p l hl e1 r hr) = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_ + +-- | Inserts a new element to the immediate right of the current element. +-- +-- Complexity: O(1) average, O(log n) worst case. +insertR :: ZAVL e -> e -> ZAVL e +insertR (ZAVL p l hl e0 r hr) e1 = case pushHL e1 r hr of UBT2(r_,hr_) -> ZAVL p l hl e0 r_ hr_ + +-- | Inserts a new element to the immediate right of the current element and then +-- moves one step right (so the newly inserted element becomes the current element). +-- +-- Complexity: O(1) average, O(log n) worst case. +insertMoveR :: ZAVL e -> e -> ZAVL e +insertMoveR (ZAVL p l hl e0 r hr) e1 = case pushHR l hl e0 of UBT2(l_,hl_) -> ZAVL p l_ hl_ e1 r hr + +-- | Inserts a new AVL tree to the immediate left of the current element. +-- +-- Complexity: O(log n), where n is the size of the inserted tree. +insertTreeL :: AVL e -> ZAVL e -> ZAVL e +insertTreeL E zavl = zavl +insertTreeL t@(N l _ _) zavl = insertLH t (addHeight L(2) l) zavl -- Absolute height required!! +insertTreeL t@(Z l _ _) zavl = insertLH t (addHeight L(1) l) zavl -- Absolute height required!! +insertTreeL t@(P _ _ r) zavl = insertLH t (addHeight L(2) r) zavl -- Absolute height required!! + + +-- Local utility to insert an AVL to the immediate left of the current element. +-- This operation carries a minor overhead in that we must convert the absolute +-- AVL height into a relative height with the same offset as the rest of the ZAVL. +-- This requires calculation of the absolute height at the current position, but +-- this should be relatively cheap because the overwhelming majority of elements will +-- be close to the bottom of any tree. +insertLH :: AVL e -> UINT -> ZAVL e -> ZAVL e +insertLH t ht (ZAVL p l hl e r hr) = + let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hl,height l) + GT -> SUBINT(hr,height r) + in case joinH l hl t ADDINT(ht,offset) of UBT2(l_,hl_) -> ZAVL p l_ hl_ e r hr + +-- | Inserts a new AVL tree to the immediate right of the current element. +-- +-- Complexity: O(log n), where n is the size of the inserted tree. +insertTreeR :: ZAVL e -> AVL e -> ZAVL e +insertTreeR zavl E = zavl +insertTreeR zavl t@(N l _ _) = insertRH t (addHeight L(2) l) zavl -- Absolute height required!! +insertTreeR zavl t@(Z l _ _) = insertRH t (addHeight L(1) l) zavl -- Absolute height required!! +insertTreeR zavl t@(P _ _ r) = insertRH t (addHeight L(2) r) zavl -- Absolute height required!! + +-- Local utility to insert an AVL to the immediate right of the current element. +-- This operation carries a minor overhead in that we must convert the absolute +-- AVL height into a relative height with the same offset as the rest of the ZAVL. +-- This requires calculation of the absolute height at the current position, but +-- this should be relatively cheap because the overwhelming majority of elements will +-- be close to the bottom of any tree. +insertRH :: AVL e -> UINT -> ZAVL e -> ZAVL e +insertRH t ht (ZAVL p l hl e r hr) = + let offset = case COMPAREUINT hl hr of -- chose smaller sub-tree to calculate absolute height + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hr,height r) + GT -> SUBINT(hr,height r) + in case joinH t ADDINT(ht,offset) r hr of UBT2(r_,hr_) -> ZAVL p l hl e r_ hr_ + + +-- | Deletes the current element and moves one step left. +-- This function raises an error if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertDelMoveL :: ZAVL e -> ZAVL e +assertDelMoveL (ZAVL p E _ _ r hr) = dR p r hr + where dR EP _ _ = error "assertDelMoveL: Can't move left." + dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht + dR (RP p_ e_ l_ hl_) r_ hr_ = ZAVL p_ l_ hl_ e_ r_ hr_ +assertDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = case popRN ll le lr of + UBT2(l,e) -> case l of + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + N _ _ _ -> ZAVL p l hl e r hr + _ -> error "assertDelMoveL: Bug0" -- impossible +assertDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = case popRZ ll le lr of + UBT2(l,e) -> case l of + E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!! + N _ _ _ -> error "assertDelMoveL: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +assertDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = case popRP ll le lr of + UBT2(l,e) -> case l of + E -> error "assertDelMoveL: Bug2" -- impossible + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + _ -> ZAVL p l hl e r hr + + +-- | Attempts to delete the current element and move one step left. +-- This function returns 'Nothing' if the current element is already the leftmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryDelMoveL :: ZAVL e -> Maybe (ZAVL e) +tryDelMoveL (ZAVL p E _ _ r hr) = dR p r hr + where dR EP _ _ = Nothing + dR (LP p_ e_ r_ hr_) l_ hl_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dR p_ t ht + dR (RP p_ e_ l_ hl_) r_ hr_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ +tryDelMoveL (ZAVL p (N ll le lr) hl _ r hr) = Just $! case popRN ll le lr of + UBT2(l,e) -> case l of + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + N _ _ _ -> ZAVL p l hl e r hr + _ -> error "tryDelMoveL: Bug0" -- impossible +tryDelMoveL (ZAVL p (Z ll le lr) hl _ r hr) = Just $! case popRZ ll le lr of + UBT2(l,e) -> case l of + E -> ZAVL p l DECINT1(hl) e r hr -- Don't use E!! + N _ _ _ -> error "tryDelMoveL: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +tryDelMoveL (ZAVL p (P ll le lr) hl _ r hr) = Just $! case popRP ll le lr of + UBT2(l,e) -> case l of + E -> error "tryDelMoveL: Bug2" -- impossible + Z _ _ _ -> ZAVL p l DECINT1(hl) e r hr + _ -> ZAVL p l hl e r hr + + +-- | Deletes the current element and moves one step right. +-- This function raises an error if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +assertDelMoveR :: ZAVL e -> ZAVL e +assertDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl + where dL EP _ _ = error "delMoveR: Can't move right." + dL (LP p_ e_ r_ hr_) l_ hl_ = ZAVL p_ l_ hl_ e_ r_ hr_ + dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht +assertDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = case popLN rl re rr of + UBT2(e,r) -> case r of + E -> error "delMoveR: Bug0" -- impossible + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + _ -> ZAVL p l hl e r hr +assertDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = case popLZ rl re rr of + UBT2(e,r) -> case r of + E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!! + P _ _ _ -> error "delMoveR: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +assertDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = case popLP rl re rr of + UBT2(e,r) -> case r of + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + P _ _ _ -> ZAVL p l hl e r hr + _ -> error "delMoveR: Bug2" -- impossible + + +-- | Attempts to delete the current element and move one step right. +-- This function returns 'Nothing' if the current element is already the rightmost element. +-- +-- Complexity: O(1) average, O(log n) worst case. +tryDelMoveR :: ZAVL e -> Maybe (ZAVL e) +tryDelMoveR (ZAVL p l hl _ E _ ) = dL p l hl + where dL EP _ _ = Nothing + dL (LP p_ e_ r_ hr_) l_ hl_ = Just $! ZAVL p_ l_ hl_ e_ r_ hr_ + dL (RP p_ e_ l_ hl_) r_ hr_ = case spliceH l_ hl_ e_ r_ hr_ of UBT2(t,ht) -> dL p_ t ht +tryDelMoveR (ZAVL p l hl _ (N rl re rr) hr) = Just $! case popLN rl re rr of + UBT2(e,r) -> case r of + E -> error "tryDelMoveR: Bug0" -- impossible + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + _ -> ZAVL p l hl e r hr +tryDelMoveR (ZAVL p l hl _ (Z rl re rr) hr) = Just $! case popLZ rl re rr of + UBT2(e,r) -> case r of + E -> ZAVL p l hl e r DECINT1(hr) -- Don't use E!! + P _ _ _ -> error "tryDelMoveR: Bug1" -- impossible + _ -> ZAVL p l hl e r hr +tryDelMoveR (ZAVL p l hl _ (P rl re rr) hr) = Just $! case popLP rl re rr of + UBT2(e,r) -> case r of + Z _ _ _ -> ZAVL p l hl e r DECINT1(hr) + P _ _ _ -> ZAVL p l hl e r hr + _ -> error "tryDelMoveR: Bug2" -- impossible + + +-- | Delete all elements to the left of the current element. +-- +-- Complexity: O(log n) +delAllL :: ZAVL e -> ZAVL e +delAllL (ZAVL p l hl e r hr) = + let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hr,height r) + GT -> SUBINT(hr,height r) + p_ = noRP p -- remove right paths (current element becomes leftmost) + in p_ `seq` ZAVL p_ E hE e r hr + +-- | Delete all elements to the right of the current element. +-- +-- Complexity: O(log n) +delAllR :: ZAVL e -> ZAVL e +delAllR (ZAVL p l hl e r hr) = + let hE = case COMPAREUINT hl hr of -- Calculate relative offset and use this as height of empty tree + LT -> SUBINT(hl,height l) + EQ -> SUBINT(hl,height l) + GT -> SUBINT(hr,height r) + p_ = noLP p -- remove left paths (current element becomes rightmost) + in p_ `seq` ZAVL p_ l hl e E hE + +-- | Similar to 'delAllL', in that all elements to the left of the current element are deleted, +-- but this function also closes the tree in the process. +-- +-- Complexity: O(log n) +delAllCloseL :: ZAVL e -> AVL e +delAllCloseL (ZAVL p _ _ e r hr) = case pushHL e r hr of UBT2(t,ht) -> closeNoRP p t ht + +-- | Similar to 'delAllR', in that all elements to the right of the current element are deleted, +-- but this function also closes the tree in the process. +-- +-- Complexity: O(log n) +delAllCloseR :: ZAVL e -> AVL e +delAllCloseR (ZAVL p l hl e _ _) = case pushHR l hl e of UBT2(t,ht) -> closeNoLP p t ht + +-- | Similar to 'delAllCloseL', but in this case the current element and all +-- those to the left of the current element are deleted. +-- +-- Complexity: O(log n) +delAllIncCloseL :: ZAVL e -> AVL e +delAllIncCloseL (ZAVL p _ _ _ r hr) = closeNoRP p r hr + +-- | Similar to 'delAllCloseR', but in this case the current element and all +-- those to the right of the current element are deleted. +-- +-- Complexity: O(log n) +delAllIncCloseR :: ZAVL e -> AVL e +delAllIncCloseR (ZAVL p l hl _ _ _) = closeNoLP p l hl + +-- | Counts the number of elements to the left of the current element +-- (this does not include the current element). +-- +-- Complexity: O(n), where n is the count result. +sizeL :: ZAVL e -> Int +sizeL (ZAVL p l _ _ _ _) = addSizeRP (size l) p + +-- | Counts the number of elements to the right of the current element +-- (this does not include the current element). +-- +-- Complexity: O(n), where n is the count result. +sizeR :: ZAVL e -> Int +sizeR (ZAVL p _ _ _ r _) = addSizeLP (size r) p + +-- | Counts the total number of elements in a ZAVL. +-- +-- Complexity: O(n) +sizeZAVL :: ZAVL e -> Int +sizeZAVL (ZAVL p l _ _ r _) = addSizeP (addSize (addSize 1 l) r) p + + +{-------------------- BAVL stuff below ----------------------------------} + +-- | A 'BAVL' is like a pointer reference to somewhere inside an 'AVL' tree. It may be either \"full\" +-- (meaning it points to an actual tree node containing an element), or \"empty\" (meaning it +-- points to the position in a tree where an element was expected but wasn\'t found). +data BAVL e = BAVL (AVL e) (BinPath e) + +-- | Search for an element in a /sorted/ 'AVL' tree using the supplied selector. +-- Returns a \"full\" 'BAVL' if a matching element was found, otherwise returns an \"empty\" 'BAVL'. +-- +-- Complexity: O(log n) +genOpenBAVL :: (e -> Ordering) -> AVL e -> BAVL e +{-# INLINE genOpenBAVL #-} +genOpenBAVL c t = bp `seq` BAVL t bp + where bp = genOpenPath c t + +-- | Returns the original tree, extracted from the 'BAVL'. Typically you will not need this, as +-- the original tree will still be in scope in most cases. +-- +-- Complexity: O(1) +closeBAVL :: BAVL e -> AVL e +{-# INLINE closeBAVL #-} +closeBAVL (BAVL t _) = t + +-- | Returns 'True' if the 'BAVL' is \"full\" (a corresponding element was found). +-- +-- Complexity: O(1) +fullBAVL :: BAVL e -> Bool +{-# INLINE fullBAVL #-} +fullBAVL (BAVL _ (FullBP _ _)) = True +fullBAVL (BAVL _ (EmptyBP _ )) = False + +-- | Returns 'True' if the 'BAVL' is \"empty\" (no corresponding element was found). +-- +-- Complexity: O(1) +emptyBAVL :: BAVL e -> Bool +{-# INLINE emptyBAVL #-} +emptyBAVL (BAVL _ (FullBP _ _)) = False +emptyBAVL (BAVL _ (EmptyBP _ )) = True + +-- | Read the element value from a \"full\" 'BAVL'. +-- This function returns 'Nothing' if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(1) +tryReadBAVL :: BAVL e -> Maybe e +{-# INLINE tryReadBAVL #-} +tryReadBAVL (BAVL _ (FullBP _ e)) = Just e +tryReadBAVL (BAVL _ (EmptyBP _ )) = Nothing + +-- | Read the element value from a \"full\" 'BAVL'. +-- This function raises an error if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(1) +readFullBAVL :: BAVL e -> e +{-# INLINE readFullBAVL #-} +readFullBAVL (BAVL _ (FullBP _ e)) = e +readFullBAVL (BAVL _ (EmptyBP _ )) = error "readFullBAVL: Empty BAVL." + +-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding +-- element replaced by the new element (first argument). If it\'s \"empty\" the original tree is returned +-- with the new element inserted. +-- +-- Complexity: O(log n) +pushBAVL :: e -> BAVL e -> AVL e +{-# INLINE pushBAVL #-} +pushBAVL e (BAVL t (FullBP p _)) = writePath p e t +pushBAVL e (BAVL t (EmptyBP p )) = insertPath p e t + +-- | If the 'BAVL' is \"full\", this function returns the original tree with the corresponding +-- element deleted. If it\'s \"empty\" the original tree is returned unmodified. +-- +-- Complexity: O(log n) (or O(1) for an empty 'BAVL') +deleteBAVL :: BAVL e -> AVL e +{-# INLINE deleteBAVL #-} +deleteBAVL (BAVL t (FullBP p _)) = deletePath p t +deleteBAVL (BAVL t (EmptyBP _ )) = t + +-- | Converts a \"full\" 'BAVL' as a 'ZAVL'. Raises an error if applied to an \"empty\" 'BAVL'. +-- +-- Complexity: O(log n) +fullBAVLtoZAVL :: BAVL e -> ZAVL e +fullBAVLtoZAVL (BAVL t (FullBP i _)) = openFull i EP L(0) t -- Relative heights !! +fullBAVLtoZAVL (BAVL _ (EmptyBP _ )) = error "fullBAVLtoZAVL: Empty BAVL." +-- Local Utility +openFull :: UINT -> (Path e) -> UINT -> AVL e -> ZAVL e +openFull _ _ _ E = error "openFull: Bug0." +openFull i p h (N l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT2(h) l + EQ -> ZAVL p l DECINT2(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r +openFull i p h (Z l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT1(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT1(h) r +openFull i p h (P l e r) = case sel i of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openFull (goL i) p_ DECINT1(h) l + EQ -> ZAVL p l DECINT1(h) e r DECINT2(h) + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openFull (goR i) p_ DECINT2(h) r + +-- | Converts an \"empty\" 'BAVL' as a 'PAVL'. Raises an error if applied to a \"full\" 'BAVL'. +-- +-- Complexity: O(log n) +emptyBAVLtoPAVL :: BAVL e -> PAVL e +emptyBAVLtoPAVL (BAVL _ (FullBP _ _)) = error "emptyBAVLtoPAVL: Full BAVL." +emptyBAVLtoPAVL (BAVL t (EmptyBP i )) = openEmpty i EP L(0) t -- Relative heights !! +-- Local Utility +openEmpty :: UINT -> (Path e) -> UINT -> AVL e -> PAVL e +openEmpty _ p h E = PAVL p h -- Test for i==0 ?? +openEmpty i p h (N l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT2(h) l + EQ -> error "openEmpty: Bug0" + GT -> let p_ = RP p e l DECINT2(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r +openEmpty i p h (Z l e r) = case sel i of + LT -> let p_ = LP p e r DECINT1(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l + EQ -> error "openEmpty: Bug1" + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT1(h) r +openEmpty i p h (P l e r) = case sel i of + LT -> let p_ = LP p e r DECINT2(h) in p_ `seq` openEmpty (goL i) p_ DECINT1(h) l + EQ -> error "openEmpty: Bug2" + GT -> let p_ = RP p e l DECINT1(h) in p_ `seq` openEmpty (goR i) p_ DECINT2(h) r + + +-- | Converts a 'BAVL' to either a 'PAVL' or 'ZAVL' (depending on whether it is \"empty\" or \"full\"). +-- +-- Complexity: O(log n) +anyBAVLtoEither :: BAVL e -> Either (PAVL e) (ZAVL e) +anyBAVLtoEither (BAVL t (FullBP i _)) = Right (openFull i EP L(0) t) -- Relative heights !! +anyBAVLtoEither (BAVL t (EmptyBP i )) = Left (openEmpty i EP L(0) t) -- Relative heights !! diff --git a/Data/Trie.hs b/Data/Trie.hs new file mode 100644 --- /dev/null +++ b/Data/Trie.hs @@ -0,0 +1,368 @@ +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Trie +-- Copyright : (c) Keith Wansbrough 2005, Christian Maeder 2006, Jean-Philippe Bernardy 2006 +-- License : BSD-style +-- +-- Maintainer : jeanphilippe.bernardy; google mail. +-- Stability : volatile +-- Portability : unknown +-- +-- This module provides a basic implementation of the Trie data type. +-- +-- Note: performance is currently rather bad. See the benchmark directory. Please contribute :) +-- +----------------------------------------------------------------------------- + +module Data.Trie + ( + -- * Data type + Trie(..) + -- * Operators + , (!) + -- , (\\) + -- * Query + , null + -- , size + , member + , lookup + , prefixLookup + -- * Construction + , empty + , singleton + -- ** Insertion + , insert + , insertWith + -- ** Delete\/Update + -- , delete + -- , adjust + -- , update + , alter + -- * Combine + -- ** Union + , union + , unionWith + -- , unions + -- , unionsWith + -- ** Difference + , difference + , differenceWith + -- ** Intersection + , intersection + , intersectionWith + -- * Traversal + -- ** Map + + -- , map + -- ** Fold + + -- , foldr + -- * Conversion + , retypeKeys + + -- , elems + -- , keys + , fromAscList + , fromList + , fromListWith + , toList + -- * Filter + + , filter + -- , partition + --, split + --, splitLookup + -- * Submap + + -- , isSubmapOf + , isSubmapOfBy + -- * Primitive accessors + , upwards, downwards + -- * Derived operations + , takeWhile, takeWhile', fringe + -- * Debugging + , toTree + ) where + +import Control.Monad +import Data.Collections (Sequence, (|>), (><)) +import Data.Maybe +import Data.Monoid +import Data.Tree +import Data.Typeable +import qualified Data.List as List +import Prelude hiding (takeWhile, null, lookup, map, foldr, filter) +import qualified Data.Collections as C +import qualified Data.Foldable as F +import qualified Data.Map.AVL as M + +-- | A Trie with key elements of type @k@ (keys of type @[k]@) and values of type @v@. +-- Note that the type is not opaque: user can pattern match on it and construct and Trie value. +-- This is because there is no non-trivial invariant to preserve. +data Trie s k v = Trie { value :: !(Maybe v), + children :: !(M.Map k (Trie s k v)) + } +-- FIXME: Strictness annotations should NOT be needed. +-- The s type parameter is there to satisfy FDs, maybe it could be removed if this is ported to ATS. + +#include "Typeable.h" +INSTANCE_TYPEABLE3(Trie,theTc,"Data.Trie.Trie") + +retypeKeys :: Trie s1 k v -> Trie s2 k v +retypeKeys (Trie v cs) = Trie v (fmap retypeKeys cs) + +toMaybe :: (a -> Bool) -> a -> Maybe a +toMaybe f b = if f b then Nothing else Just b + +alter :: forall s k v. (C.Foldable s k, Ord k) => (Maybe v -> Maybe v) -> s -> Trie s k v -> Trie s k v +alter f s t = C.foldr rec zero s t + where zero (Trie v cs) = (Trie (f v) cs) + rec k sub (Trie v cs) = Trie v (C.alter (f' sub) k cs) + f' sub t = toMaybe null (sub (fromMaybe empty t)) + -- recursive application: need to "create" empty nodes in case f creates a leaf node. + +-- alternate version faster for insertion/not touching nodes, but requires sequence. +-- alter f s (Trie v cs) = case C.front s of +-- Nothing -> Trie (f v) cs +-- Just (k,ks) -> Trie v (M.alter (f' ks) k cs) +-- where f' ks Nothing = fmap (singleton ks) (f Nothing) +-- f' ks (Just t) = toMaybe (alter f ks t) + +adjust :: forall s k v. (C.Foldable s k, Ord k) => (v -> v) -> s -> Trie s k v -> Trie s k v +adjust f s t = C.foldr rec zero s t + where zero t@(Trie Nothing _) = t + zero (Trie (Just v) cs) = (Trie (Just (f v)) cs) + rec k sub (Trie v cs) = Trie v (C.adjust sub k cs) + +-- | Modify the 'children' field of a trie. +value_u :: (Maybe v -> Maybe v) -> Trie s k v -> Trie s k v +value_u f p = p { value = f (value p) } + +-- | Modify the 'children' field of a trie. +children_u :: (M.Map k (Trie s k v) -> M.Map k (Trie s k v)) -> Trie s k v -> Trie s k v +children_u f p = p { children = f (children p) } + +-- | The empty trie. +empty :: Ord k => Trie s k v +empty = Trie { value = Nothing, children = C.empty } + +-- | Is the trie empty ? +null :: Trie s k v -> Bool +null (Trie Nothing cs) = C.null cs +null _ = False + +-- | The singleton trie. +singleton :: (Ord k, C.Foldable s k) => s -> v -> Trie s k v +singleton k x = C.foldr singleton_ (Trie (Just x) C.empty) k + where singleton_ k sub = Trie {value = Nothing, children = C.singleton (k,sub)} + +-- | Combining two tries. The first shadows the second. +union :: Ord k => Trie s k v -> Trie s k v -> Trie s k v +union p1 p2 = + Trie { + value = mplus (value p1) (value p2), + children = C.unionWith union (children p1) (children p2) + } + +-- | Combining two tries. If the two define the same key, the +-- specified combining function is used. +unionWith :: Ord k => (v -> v -> v) -> Trie s k v -> Trie s k v -> Trie s k v +unionWith f p1 p2 = + Trie { + value = lift (value p1) (value p2), + children = C.unionWith (unionWith f) (children p1) (children p2) + } + where lift Nothing y = y + lift x Nothing = x + lift (Just x) (Just y) = Just (f x y) + +-- | Combining two tries. If the two tries define the same key, the +-- specified combining function is used. +intersectionWith :: Ord k => (v -> v -> v) -> Trie s k v -> Trie s k v -> Trie s k v +intersectionWith f p1 p2 = + Trie { + value = lift (value p1) (value p2), + children = C.filter (not . null . snd) $ C.intersectionWith (intersectionWith f) (children p1) (children p2) + } + where lift (Just x) (Just y) = Just (f x y) + lift _ _ = Nothing + +intersection :: Ord k => Trie s k v -> Trie s k v -> Trie s k v +intersection = intersectionWith const + +differenceWith :: Ord k => (v -> v -> Maybe v) -> Trie s k v -> Trie s k v -> Trie s k v +differenceWith f p1 p2 = + Trie { + value = lift (value p1) (value p2), + children = C.differenceWith combine (children p1) (children p2) + } + where lift Nothing _ = Nothing + lift (Just x) Nothing = Just x + lift (Just x) (Just y) = f x y + combine x y = let i = differenceWith f x y in if null i then Nothing else Just i + +difference :: Ord k => Trie s k v -> Trie s k v -> Trie s k v +difference = differenceWith (\_ _->Nothing) + +isSubmapOfBy :: Ord k => (v -> v -> Bool) -> Trie s k v -> Trie s k v -> Bool +isSubmapOfBy f p1 p2 = ok (value p1) (value p2) && + C.isSubmapBy (isSubmapOfBy f) (children p1) (children p2) + where ok Nothing _ = True + ok _ Nothing = False + ok (Just x) (Just y) = f x y + +lookup :: forall s m k v. (C.Foldable s k, Monad m, Ord k) => s -> Trie s k v -> m v +lookup s t = maybe (fail "key not found in Trie") return + (C.foldl' lookup_ (Just t) s >>= value) + where --lookup_ :: k -> Maybe (Trie s k v) -> Maybe (Trie s k v) + lookup_ t k = t >>= C.lookup k . children + +(!) :: forall s k v. (C.Foldable s k, Ord k) => Trie s k v -> s -> v +(!) = (C.!) + +member :: forall s k v. (C.Foldable s k, Ord k) => s -> Trie s k v -> Bool +member k = isJust . lookup k + +insert :: forall s k v. (C.Foldable s k, Ord k) => s -> v -> Trie s k v -> Trie s k v +insert = insertWith const + +insertWith :: forall s k v. (C.Foldable s k, Ord k) => (v -> v -> v) -> s -> v -> Trie s k v -> Trie s k v +insertWith f k a c = alter (\x -> Just $ case x of {Nothing->a;Just a' -> f a a'}) k c + +-- | @prefixLookup k p@ returns a sequence of all @(k',v)@ pairs, such that @k@ is a prefix of @k'@. +-- The sequence is sorted by lexicographic order of keys. +prefixLookup :: forall s k v result. (Ord k, Sequence s k, Sequence result (s,v)) => s -> Trie s k v -> result +prefixLookup ks p = getNode p >< C.concatMap (\(k,p') -> prefixLookup (ks |> k) p') (C.toList (children p)) + where getNode :: Trie s k v -> result + getNode p = maybe C.empty (\v -> C.singleton (ks,v)) (value p) + +-- | An upwards accumulation on the trie. +upwards :: Ord k => (Trie s k v -> Trie s k v) -> Trie s k v -> Trie s k v +upwards f = f . children_u (fmap (upwards f)) + +-- | A downwards accumulation on the trie. +downwards :: Ord k => (Trie s k v -> Trie s k v) -> Trie s k v -> Trie s k v +downwards f = children_u (fmap (downwards f)) . f + +-- | Return the prefix of the trie satisfying @f@. +takeWhile :: Ord k => (Trie s k v -> Bool) -> Trie s k v -> Trie s k v +takeWhile f = downwards (children_u (C.filter (f . snd))) + +-- | Return the prefix of the trie satisfying @f@ on all values present. +takeWhile' :: Ord k => (v -> Bool) -> Trie s k v -> Trie s k v +takeWhile' f = takeWhile (maybe True f . value) + +-- | Return the fringe of the trie (the trie composed of only the leaf nodes). +fringe :: Ord k => Trie s k v -> Trie s k v +fringe = upwards (\p -> if C.null (children p) then p else value_u (const Nothing) p) + + +toList :: (Sequence s k, Ord k) => Trie s k v -> [(s,v)] +toList = C.toList + +-- TODO: put those in the class instances. + +fromAscList :: forall s k v. (Sequence s k, Ord k) => [(s,v)] -> Trie s k v +fromAscList l = Trie (fmap snd . listToMaybe $ values) + (M.fromAscList $ List.map mkVal $ List.groupBy (testing (C.head . fst)) l') + where (values, l') = span (C.null . fst) l + mkVal grp = (C.head . fst . head $ grp, fromAscList $ fmap dropHead grp) + dropHead (k, val) = (C.tail k, val) + +testing :: Eq b => (a -> b) -> (a -> a -> Bool) +testing f x y = f x == f y + +fromList :: forall s k v. (Sequence s k, Ord k) => [(s,v)] -> Trie s k v +fromList = fromListWith (\x _ -> x) + +fromListWith :: forall s k v. (Sequence s k, Ord k) => (v -> v -> v) -> [(s,v)] -> Trie s k v +fromListWith f l = Trie (reduce values) (fmap (fromListWith f) subMap) + where (values,l') = List.partition (C.null . fst) l + mkVal (k, val) = (C.head k, [(C.tail k, val)]) + subMap = M.fromListWith (flip (++)) $ fmap mkVal l' + reduce [] = Nothing + reduce l = Just (List.foldr1 f . fmap snd $ l) + + + +filterWithKey :: forall k v s. (Ord k, Sequence s k) => (s -> v -> Bool) -> Trie s k v -> Trie s k v +filterWithKey f t = f' C.empty t + where f' :: s -> Trie s k v -> Trie s k v + f' ks t = Trie (do {x <- value t; + if f ks x then return x else Nothing}) + (C.filter (not . null . snd) $ C.mapWithKey (\k -> f' (ks |> k)) (children t)) + +filter :: forall k v s. (Ord k, Sequence s k) => (v -> Bool) -> Trie s k v -> Trie s k v +filter f (Trie v cs) = Trie (f' v) (C.filter (not . null . snd) $ fmap (filter f) cs) + where f' v@(Just x) | f x = v + f' _ = Nothing + +mapWithKey :: forall k v v' s. (Ord k, Sequence s k) => (s -> v -> v') -> Trie s k v -> Trie s k v' +mapWithKey f t = f' C.empty t + where f' :: s -> Trie s k v -> Trie s k v' + f' ks t = Trie (fmap (f ks) (value t)) + (C.mapWithKey' (\k -> f' (ks |> k)) (children t)) + +instance F.Foldable (Trie s k) where + foldMap f t = F.foldMap f (value t) `mappend` F.foldMap (F.foldMap f) (children t) + +instance Sequence s k => C.Foldable (Trie s k v) (s,v) where + null = null + foldMap f t = fm C.empty f t + where fm ks f t = C.foldMap f (fmap (\v->(ks,v)) (value t)) + `mappend` + C.foldMap (\(k,t) -> fm (ks |> k) f t) (children t) + +instance (Ord k, Sequence s k) => C.Unfoldable (Trie s k v) (s,v) where + insert = uncurry (C.insertWith (\x _ -> x)) + empty = empty + insertMany l c | null c = fromList (C.toList l) + | otherwise = C.foldr C.insert c l + insertManySorted l c | null c = fromAscList (C.toList l) + | otherwise = C.foldr C.insert c l + {-# SPECIALIZE instance C.Unfoldable (Trie String Char v) (String,v) #-} + +instance (Ord k, Sequence s k) => C.Collection (Trie s k v) (s,v) where + filter f = filterWithKey (curry f) + +instance (Ord k,Sequence s k) => C.Map (Trie s k v) s v where + alter = alter + lookup = lookup + intersectionWith = intersectionWith + fromFoldableWith f = fromListWith f . C.toList + unionWith = unionWith + isSubmapBy = isSubmapOfBy + differenceWith = differenceWith + mapWithKey = mapWithKey + {-# SPECIALIZE instance C.Map (Trie String Char v) String v #-} + +instance (Ord k,C.Foldable s k) => C.Indexed (Trie s k v) s v where + index k = fromJust . lookup k + adjust = adjust + inDomain = member + +instance (Show k, Show v) => Show (Trie [k] k v) where + show t = "fromList " ++ show (C.toList t :: [([k],v)]) + +instance Ord k => Monoid (Trie s k v) where + mempty = empty + mappend = union + +instance (Eq k, Eq v) => Eq (Trie s k v) where + (Trie v cs) == (Trie v' cs') = v == v' && cs == cs' + +toTree :: k -> Trie s k v -> Tree (k,Maybe v) +toTree k (Trie v cs) = Node (k,v) $ C.foldr f [] cs + where f (k,t) = (toTree k t :) + + +-- foldWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> Map k a -> b +-- foldWithKey f k t = f' [] k t +-- where f' :: [k] -> b -> Map k a -> b +-- f' ks t = Trie (do {x <- value t; +-- if f ks x then return x else Nothing}) +-- (C.mapWithKey (\k -> f' (ks++[k])) (children t)) +-- -- C.filter (not . null) . +-- diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +See the AUTHORS file for a list of copyright holders. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of + other contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + 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/collections.cabal b/collections.cabal new file mode 100644 --- /dev/null +++ b/collections.cabal @@ -0,0 +1,53 @@ +name: collections +version: 0.3 +category: Data Structures +description: + This package provides a suite of data structures types, with a consistent API. + It is intended as an evolution of the data structures in the @base@ package. +license: BSD3 +license-file: LICENSE +author: Jean-Philippe Bernardy, Adrian Hey and others (see AUTHORS file) +maintainer: jeanphilippe.bernardy (google mail) +synopsis: Useful standard collections types and related functions. +exposed-modules: + Data.COrdering, + Data.Collections, + Data.Collections.Foldable, + Data.Collections.Properties, + Data.Map.AVL, + Data.Map.List, + Data.Ranged, + Data.Ranged.Boundaries, + Data.Ranged.RangedSet, + Data.Ranged.Ranges, + Data.Set.AVL, + Data.Set.Enum, + Data.Set.List, + Data.Tree.AVL, + Data.Tree.AVL.Delete, + Data.Tree.AVL.Join, + Data.Tree.AVL.List, + Data.Tree.AVL.Push, + Data.Tree.AVL.Read, + Data.Tree.AVL.Set, + Data.Tree.AVL.Size, + Data.Tree.AVL.Split, + Data.Tree.AVL.Test.Counter, + Data.Tree.AVL.Test.Utils, + Data.Tree.AVL.Types, + Data.Tree.AVL.Write, + Data.Tree.AVL.Zipper, + Data.Trie +other-modules: + Data.Tree.AVL.Internals.BinPath, + Data.Tree.AVL.Internals.DelUtils, + Data.Tree.AVL.Internals.HAVL, + Data.Tree.AVL.Internals.HJoin, + Data.Tree.AVL.Internals.HPush, + Data.Tree.AVL.Internals.HSet, + Data.Tree.AVL.Internals.HeightUtils +include-dirs: include +extra-source-files: include/Typeable.h include/ghcdefs.h include/h98defs.h +build-depends: base >= 2.0, QuickCheck +extensions: CPP +ghc-options: -O -Wall -fno-warn-name-shadowing -fno-warn-incomplete-patterns diff --git a/include/Typeable.h b/include/Typeable.h new file mode 100644 --- /dev/null +++ b/include/Typeable.h @@ -0,0 +1,64 @@ +/* ---------------------------------------------------------------------------- + * Macros to help make Typeable instances. + * + * INSTANCE_TYPEABLEn(tc,tcname,"tc") defines + * + * instance Typeable/n/ tc + * instance Typeable a => Typeable/n-1/ (tc a) + * instance (Typeable a, Typeable b) => Typeable/n-2/ (tc a b) + * ... + * instance (Typeable a1, ..., Typeable an) => Typeable (tc a1 ... an) + * -------------------------------------------------------------------------- */ + +#ifndef TYPEABLE_H +#define TYPEABLE_H + +#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } + +#ifdef __GLASGOW_HASKELL__ + +/* For GHC, the extra instances follow from general instance declarations + * defined in Data.Typeable. */ + +#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } + +#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } + +#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } + +#else /* !__GLASGOW_HASKELL__ */ + +#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable (tycon a) where { typeOf = typeOfDefault } + +#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable1 (tycon a) where { \ + typeOf1 = typeOf1Default }; \ +instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \ + typeOf = typeOfDefault } + +#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ +tcname = mkTyCon str; \ +instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] }; \ +instance Typeable a => Typeable2 (tycon a) where { \ + typeOf2 = typeOf2Default }; \ +instance (Typeable a, Typeable b) => Typeable1 (tycon a b) where { \ + typeOf1 = typeOf1Default }; \ +instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where { \ + typeOf = typeOfDefault } + +#endif /* !__GLASGOW_HASKELL__ */ + +#endif diff --git a/include/ghcdefs.h b/include/ghcdefs.h new file mode 100644 --- /dev/null +++ b/include/ghcdefs.h @@ -0,0 +1,25 @@ +#define UINT Int# +#define COMPAREUINT compareInt# +#define INCINT1(n) ((n)+#1#) +#define INCINT2(n) ((n)+#2#) +#define INCINT3(n) ((n)+#3#) +#define INCINT4(n) ((n)+#4#) +#define DECINT1(n) ((n)-#1#) +#define DECINT2(n) ((n)-#2#) +#define DECINT3(n) ((n)-#3#) +#define DECINT4(n) ((n)-#4#) +#define SUBINT(m,n) ((m)-#(n)) +#define ADDINT(m,n) ((m)+#(n)) +#define L(n) n# +#define LEQ <=# +#define EQL ==# +#define ASINT(n) (I# (n)) +#define NEGATE(n) (0#-#(n)) +#define _MODULO_(n,m) (modInt# n m) +#define UBT2(y,z) (# y,z #) +#define UBT3(x,y,z) (# x,y,z #) +#define UBT4(w,x,y,z) (# w,x,y,z #) +#define UBT5(v,w,x,y,z) (# v,w,x,y,z #) +#define IS_NEG(n) (n <# 0#) +#define LEFT_JUSTIFY_INT(m,n) (iShiftL# (m) (32#-#n)) + diff --git a/include/h98defs.h b/include/h98defs.h new file mode 100644 --- /dev/null +++ b/include/h98defs.h @@ -0,0 +1,24 @@ +#define UINT Int +#define COMPAREUINT compare +#define INCINT1(n) ((n) + 1) +#define INCINT2(n) ((n) + 2) +#define INCINT3(n) ((n) + 3) +#define INCINT4(n) ((n) + 4) +#define DECINT1(n) ((n) - 1) +#define DECINT2(n) ((n) - 2) +#define DECINT3(n) ((n) - 3) +#define DECINT4(n) ((n) - 4) +#define SUBINT(m,n) ((m)- (n)) +#define ADDINT(m,n) ((m)+ (n)) +#define L(n) n +#define LEQ <= +#define EQL == +#define ASINT(n) (n) +#define NEGATE(n) (0 - (n)) +#define _MODULO_(n,m) (n `mod` m) +#define UBT2(y,z) ( y,z ) +#define UBT3(x,y,z) ( x,y,z ) +#define UBT4(w,x,y,z) ( w,x,y,z ) +#define UBT5(v,w,x,y,z) ( v,w,x,y,z ) +#define IS_NEG(n) (n < 0) +#define LEFT_JUSTIFY_INT(m,n) (shiftL (m) (32-n))