collections (empty) → 0.3
raw patch · 41 files changed
+13227/−0 lines, 41 filesdep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: QuickCheck, base
Files
- Data/COrdering.hs +208/−0
- Data/Collections.hs +1081/−0
- Data/Collections/Foldable.hs +311/−0
- Data/Collections/Properties.hs +679/−0
- Data/Map/AVL.hs +639/−0
- Data/Map/List.hs +87/−0
- Data/Ranged.hs +10/−0
- Data/Ranged/Boundaries.hs +170/−0
- Data/Ranged/RangedSet.hs +544/−0
- Data/Ranged/Ranges.hs +247/−0
- Data/Set/AVL.hs +455/−0
- Data/Set/Enum.hs +415/−0
- Data/Set/List.hs +72/−0
- Data/Tree/AVL.hs +132/−0
- Data/Tree/AVL/Delete.hs +518/−0
- Data/Tree/AVL/Internals/BinPath.hs +377/−0
- Data/Tree/AVL/Internals/DelUtils.hs +790/−0
- Data/Tree/AVL/Internals/HAVL.hs +98/−0
- Data/Tree/AVL/Internals/HJoin.hs +329/−0
- Data/Tree/AVL/Internals/HPush.hs +189/−0
- Data/Tree/AVL/Internals/HSet.hs +655/−0
- Data/Tree/AVL/Internals/HeightUtils.hs +150/−0
- Data/Tree/AVL/Join.hs +123/−0
- Data/Tree/AVL/List.hs +652/−0
- Data/Tree/AVL/Push.hs +718/−0
- Data/Tree/AVL/Read.hs +171/−0
- Data/Tree/AVL/Set.hs +423/−0
- Data/Tree/AVL/Size.hs +41/−0
- Data/Tree/AVL/Split.hs +838/−0
- Data/Tree/AVL/Test/Counter.hs +49/−0
- Data/Tree/AVL/Test/Utils.hs +223/−0
- Data/Tree/AVL/Types.hs +165/−0
- Data/Tree/AVL/Write.hs +198/−0
- Data/Tree/AVL/Zipper.hs +902/−0
- Data/Trie.hs +368/−0
- LICENSE +31/−0
- Setup.hs +3/−0
- collections.cabal +53/−0
- include/Typeable.h +64/−0
- include/ghcdefs.h +25/−0
- include/h98defs.h +24/−0
+ Data/COrdering.hs view
@@ -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+ +
+ Data/Collections.hs view
@@ -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/\".+-- <http://research.microsoft.com/Users/simonpj/Papers/collections.ps.gz>+-- +-- 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+++
+ Data/Collections/Foldable.hs view
@@ -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 [])
+ Data/Collections/Properties.hs view
@@ -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 _ = "<func>"++-- | 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}+
+ Data/Map/AVL.hs view
@@ -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)
+ Data/Map/List.hs view
@@ -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)
+ Data/Ranged.hs view
@@ -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
+ Data/Ranged/Boundaries.hs view
@@ -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+
+ Data/Ranged/RangedSet.hs view
@@ -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
+ Data/Ranged/Ranges.hs view
@@ -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
+ Data/Set/AVL.hs view
@@ -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
+ Data/Set/Enum.hs view
@@ -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++
+ Data/Set/List.hs view
@@ -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
+ Data/Tree/AVL.hs view
@@ -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+
+ Data/Tree/AVL/Delete.hs view
@@ -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+
+ Data/Tree/AVL/Internals/BinPath.hs view
@@ -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 --------------------------+-----------------------------------------------------------------------+
+ Data/Tree/AVL/Internals/DelUtils.hs view
@@ -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+
+ Data/Tree/AVL/Internals/HAVL.hs view
@@ -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_+
+ Data/Tree/AVL/Internals/HJoin.hs view
@@ -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 --------------------------+-----------------------------------------------------------------------
+ Data/Tree/AVL/Internals/HPush.hs view
@@ -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 --------------------------+-----------------------------------------------------------------------+
+ Data/Tree/AVL/Internals/HSet.hs view
@@ -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 ----------------------+-----------------------------------------------------------------------
+ Data/Tree/AVL/Internals/HeightUtils.hs view
@@ -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"+
+ Data/Tree/AVL/Join.hs view
@@ -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)
+ Data/Tree/AVL/List.hs view
@@ -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++
+ Data/Tree/AVL/Push.hs view
@@ -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 -- <e, so put in L subtree+ Eq e' -> 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 -- <e, so put in L subtree+ Eq e' -> 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 -- <e, so put in L subtree+ Eq e' -> 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 -- <e, so put in L subtree+ Eq e' -> 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 -- <e, so put in L subtree+ Eq e' -> 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 -- <e, so put in L subtree+ Eq e' -> 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 ---------------------------+-----------------------------------------------------------------------++
+ Data/Tree/AVL/Read.hs view
@@ -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
+ Data/Tree/AVL/Set.hs view
@@ -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+
+ Data/Tree/AVL/Size.hs view
@@ -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)
+ Data/Tree/AVL/Split.hs view
@@ -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+
+ Data/Tree/AVL/Test/Counter.hs view
@@ -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++
+ Data/Tree/AVL/Test/Utils.hs view
@@ -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)
+ Data/Tree/AVL/Types.hs view
@@ -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
+ Data/Tree/AVL/Write.hs view
@@ -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++
+ Data/Tree/AVL/Zipper.hs view
@@ -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 ..+--+-- <http://haskell.org/hawiki/TheZipper>+--+-- 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 !!
+ Data/Trie.hs view
@@ -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) . +--
+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/runhaskell+import Distribution.Simple+main = defaultMain
+ collections.cabal view
@@ -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
+ include/Typeable.h view
@@ -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
+ include/ghcdefs.h view
@@ -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)) +
+ include/h98defs.h view
@@ -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))