darcs - INblobs

Tue Jun 17 14:00:13 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>

* Minor Webpage Update

- INblobs is being developed by Miguel VilaÃ§a (<a href="mailto:jmvilaca@di.uminho.pt?subject=INblobs">jmvilaca@di.uminho.pt</a>) at <a href="http://www.uminho.pt">University of Minho</a> integrated in the <a href="http://www.di.uminho.pt/pure">PURe project</a>

+ INblobs is being developed by <a href="http://www.di.uminho.pt/~jmvilaca">Miguel Vilaça</a> (<a href="mailto:jmvilaca@di.uminho.pt?subject=INblobs">jmvilaca@di.uminho.pt</a>) at <a href="http://www.uminho.pt">University of Minho</a>.

- To use INblobs you must make a copy of the <a href="http://abridgegame.org/darcs/">darcs</a> repository.

+ To use INblobs you must make a copy of the <a href="http://darcs.net/">darcs</a> repository.

- The repository is browsable here through <a href="http://haskell.di.uminho.pt/repos/darcsweb.cgi?r=INblobs;a=summary">darcsweb</a>

+ The repository is browsable here through <a href="http://haskell.di.uminho.pt/cgi-bin/darcsweb.cgi?r=INblobs;a=summary">darcsweb</a>

Tue Jun 17 13:54:55 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>

* More Recent wxHaskell DLL

- Probably works as well for 95 or 98.

+ Note: When you run the executable, if you see the error message The applicattion failed to initialize properly (0xc0150002). Click OK to terminate the application. then you need to install the

+ <a href="http://www.microsoft.com/downloads/details.aspx?FamilyID=200b2fd9-ae1a-4a14-984d-389c36f85647&DisplayLang=en">Microsoft Visual C++ 2005 SP1 Redistributable Package</a>.

-copy wxc-msw2.4.2-0.9.4.dll INblobs[_^M_][_$_]

+copy wxc-msw*.dll INblobs[_^M_][_$_]

Tue Jun 17 13:49:36 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>

- Change local IntMap to external Data.IntMap

- Change some old module names to new ones

-{-# OPTIONS -cpp -fglasgow-exts #-} [_$_]

--------------------------------------------------------------------------------- [_$_]

-{-| Module : IntMap

- Copyright : (c) Daan Leijen 2002

- License : BSD-style

- Maintainer : daan@cs.uu.nl

- Stability : provisional

- Portability : portable

- An efficient implementation of maps from integer keys to values. [_$_]

- 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. [_$_]

- If you want to use "IntMap" unqualified, these functions should be hidden.

- > import Prelude hiding (map,lookup,filter)

- Another solution is to use qualified names. [_$_]

- > import qualified IntMap

- > ... IntMap.single "Paris" "France"

- Or, if you prefer a terse coding style:

- > import qualified IntMap as M

- > ... M.single "Paris" "France"

- 2) The implementation is based on /big-endian patricia trees/. This data structure [_$_]

- performs especially well on binary operations like 'union' and 'intersection'. However,

- my benchmarks show that it is also (much) faster on insertions and deletions when [_$_]

- compared to a generic size-balanced map implementation (see "Map" and "Data.FiniteMap").

- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",

- Workshop on ML, September 1998, pages 77--86, <http://www.cse.ogi.edu/~andy/pub/finite.htm>

- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information

- Coded In Alphanumeric/\", Journal of the ACM, 15(4), October 1968, pages 514--534.

- 3) Many operations have a worst-case complexity of /O(min(n,W))/. This means that the

- operation can become linear in the number of elements [_$_]

- with a maximum of /W/ -- the number of bits in an 'Int' (32 or 64). [_$_]

---------------------------------------------------------------------------------- [_$_]

-module IntMap ( [_$_]

- IntMap, Key -- instance Eq,Show

- , insertWith, insertWithKey, insertLookupWithKey

- -- ** Delete\/Update

- , updateLookupWithKey

- , differenceWithKey

- -- ** Intersection

- , intersection [_$_]

- , intersectionWith

- , intersectionWithKey

- -- ** Ordered lists

- , fromAscListWithKey

- , fromDistinctAscList

- , partitionWithKey

- , splitLookup [_$_]

- , subset, subsetBy

- , properSubset, properSubsetBy

-import Prelude hiding (lookup,map,filter)

--- just for testing

-import qualified Prelude

-import Debug.QuickCheck [_$_]

-import List (nub,sort)

-import qualified List

-#ifdef __GLASGOW_HASKELL__

-{--------------------------------------------------------------------

- GHC: use unboxing to get @shiftRL@ inlined.

---------------------------------------------------------------------}

-#if __GLASGOW_HASKELL__ >= 503

-import GHC.Exts ( Word(..), Int(..), shiftRL# )

-import GlaExts ( Word(..), Int(..), shiftRL# )

-infixl 9 \\ -- cpp nonsense

-natFromInt :: Key -> Nat

-natFromInt i = fromIntegral i

-intFromNat :: Nat -> Key

-intFromNat w = fromIntegral w

-shiftRL :: Nat -> Key -> Nat

-shiftRL (W# x) (I# i)

- = W# (shiftRL# x i)

-{--------------------------------------------------------------------

- * raises errors on boundary values when using 'fromIntegral'

- but not with the deprecated 'fromInt/toInt'. [_$_]

- * Older Hugs doesn't define 'Word'.

- * Newer Hugs defines 'Word' in the Prelude but no operations.

---------------------------------------------------------------------}

-type Nat = Word32 -- illegal on 64-bit platforms!

-natFromInt :: Key -> Nat

-natFromInt i = fromInt i

-intFromNat :: Nat -> Key

-intFromNat w = toInt w

-shiftRL :: Nat -> Key -> Nat

-shiftRL x i = shiftR x i

-{--------------------------------------------------------------------

- 'Standard' Haskell

- * A "Nat" is a natural machine word (an unsigned Int)

---------------------------------------------------------------------}

-natFromInt :: Key -> Nat

-natFromInt i = fromIntegral i

-intFromNat :: Nat -> Key

-intFromNat w = fromIntegral w

-shiftRL :: Nat -> Key -> Nat

-shiftRL w i = shiftR w i

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(min(n,W))/. See 'find'.

-(!) :: IntMap a -> Key -> a

--- | /O(n+m)/. See 'difference'.

-(\\) :: IntMap a -> IntMap a -> IntMap a

-m1 \\ m2 = difference m1 m2

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | A map of integers to values @a@.

-data IntMap a = Nil

- | Bin !Prefix !Mask !(IntMap a) !(IntMap a) [_$_]

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(1)/. Is the map empty?

-isEmpty :: IntMap a -> Bool

-isEmpty other = False

--- | /O(n)/. Number of elements in the map.

-size :: IntMap a -> Int

- Bin p m l r -> size l + size r

--- | /O(min(n,W))/. Is the key a member of the map?

-member :: Key -> IntMap a -> Bool

- = case lookup k m of

--- | /O(min(n,W))/. Lookup the value of a key in the map.

-lookup :: Key -> IntMap a -> Maybe a

- | nomatch k p m -> Nothing

- | zero k m -> lookup k l

- | otherwise -> lookup k r

- | (k==kx) -> Just x

- | otherwise -> Nothing

--- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.

-find :: Key -> IntMap a -> a

- = case lookup k m of

- Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")

--- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when

--- the key is not an element of the map.

-findWithDefault :: a -> Key -> IntMap a -> a

-findWithDefault def k m

- = case lookup k m of

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(1)/. The empty map.

--- | /O(1)/. A map of one element.

-single :: Key -> a -> IntMap a

-{--------------------------------------------------------------------

- 'insert' is the inlined version of 'insertWith (\k x y -> x)'

---------------------------------------------------------------------}

--- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key [_$_]

--- is already an element of the set, it's value is replaced by the new value, [_$_]

--- ie. 'insert' is left-biased.

-insert :: Key -> a -> IntMap a -> IntMap a

- | nomatch k p m -> join k (Tip k x) p t

- | zero k m -> Bin p m (insert k x l) r

- | otherwise -> Bin p m l (insert k x r)

- | k==ky -> Tip k x

- | otherwise -> join k (Tip k x) ky t

--- right-biased insertion, used by 'union'

--- | /O(min(n,W))/. Insert with a combining function.

-insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a

- = insertWithKey (\k x y -> f x y) k x t

--- | /O(min(n,W))/. Insert with a combining function.

-insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a

-insertWithKey f k x t

- | nomatch k p m -> join k (Tip k x) p t

- | zero k m -> Bin p m (insertWithKey f k x l) r

- | otherwise -> Bin p m l (insertWithKey f k x r)

- | k==ky -> Tip k (f k x y)

- | otherwise -> join k (Tip k x) ky t

--- | /O(min(n,W))/. 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@).

-insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)

-insertLookupWithKey f k x t

- | nomatch k p m -> (Nothing,join k (Tip k x) p t)

- | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r)

- | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r')

- | k==ky -> (Just y,Tip k (f k x y))

- | otherwise -> (Nothing,join k (Tip k x) ky t)

- Nil -> (Nothing,Tip k x)

-{--------------------------------------------------------------------

- [delete] is the inlined version of [deleteWith (\k x -> Nothing)]

---------------------------------------------------------------------}

--- | /O(min(n,W))/. 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 :: Key -> IntMap a -> IntMap a

- | nomatch k p m -> t

- | zero k m -> bin p m (delete k l) r

- | otherwise -> bin p m l (delete k r)

--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not

--- a member of the map, the original map is returned.

-adjust :: (a -> a) -> Key -> IntMap a -> IntMap a

- = adjustWithKey (\k x -> f x) k m

--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not

--- a member of the map, the original map is returned.

-adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a

-adjustWithKey f k m

- = updateWithKey (\k x -> Just (f k x)) k m

--- | /O(min(n,W))/. 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 :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a

- = updateWithKey (\k x -> f x) k m

--- | /O(min(n,W))/. The expression (@update 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 :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a

-updateWithKey f k t

- | nomatch k p m -> t

- | zero k m -> bin p m (updateWithKey f k l) r

- | otherwise -> bin p m l (updateWithKey f k r)

- | k==ky -> case (f k y) of

- Just y' -> Tip ky y'

--- | /O(min(n,W))/. Lookup and update.

-updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)

-updateLookupWithKey f k t

- | nomatch k p m -> (Nothing,t)

- | zero k m -> let (found,l') = updateLookupWithKey f k l in (found,bin p m l' r)

- | otherwise -> let (found,r') = updateLookupWithKey f k r in (found,bin p m l r')

- | k==ky -> case (f k y) of

- Just y' -> (Just y,Tip ky y')

- Nothing -> (Just y,Nil)

- | otherwise -> (Nothing,t)

- Nil -> (Nothing,Nil)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | The union of a list of maps.

-unions :: [IntMap a] -> IntMap a

- = foldlStrict union empty xs

--- | /O(n+m)/. The (left-biased) union of two sets. [_$_]

-union :: IntMap a -> IntMap a -> IntMap a

-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = union1

- | shorter m2 m1 = union2

- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)

- | otherwise = join p1 t1 p2 t2

- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2

- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1

- | otherwise = Bin p1 m1 l1 (union r1 t2)

- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2

- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2

- | otherwise = Bin p2 m2 l2 (union t1 r2)

-union (Tip k x) t = insert k x t

-union t (Tip k x) = insertWith (\x y -> y) k x t -- right bias

--- | /O(n+m)/. The union with a combining function. [_$_]

-unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a

- = unionWithKey (\k x y -> f x y) m1 m2

--- | /O(n+m)/. The union with a combining function. [_$_]

-unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a

-unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = union1

- | shorter m2 m1 = union2

- | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)

- | otherwise = join p1 t1 p2 t2

- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2

- | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1

- | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)

- union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2

- | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2

- | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)

-unionWithKey f (Tip k x) t = insertWithKey f k x t

-unionWithKey f t (Tip k x) = insertWithKey (\k x y -> f k y x) k x t -- right bias

-unionWithKey f Nil t = t

-unionWithKey f t Nil = t

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n+m)/. Difference between two maps (based on keys). [_$_]

-difference :: IntMap a -> IntMap a -> IntMap a

-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = difference1

- | shorter m2 m1 = difference2

- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)

- difference1 | nomatch p2 p1 m1 = t1

- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1

- | otherwise = bin p1 m1 l1 (difference r1 t2)

- difference2 | nomatch p1 p2 m2 = t1

- | zero p1 m2 = difference t1 l2

- | otherwise = difference t1 r2

-difference t1@(Tip k x) t2 [_$_]

- | member k t2 = Nil

-difference Nil t = Nil

-difference t (Tip k x) = delete k t

-difference t Nil = t

--- | /O(n+m)/. Difference with a combining function. [_$_]

-differenceWith :: (a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a

-differenceWith f m1 m2

- = differenceWithKey (\k x y -> f x y) m1 m2

--- | /O(n+m)/. Difference with a combining function. When two equal keys are

--- encountered, the combining function is applied to the key and both values.

--- If it returns @Nothing@, the element is discarded (proper set difference). If

--- it returns (@Just y@), the element is updated with a new value @y@. [_$_]

-differenceWithKey :: (Key -> a -> a -> Maybe a) -> IntMap a -> IntMap a -> IntMap a

-differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = difference1

- | shorter m2 m1 = difference2

- | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)

- difference1 | nomatch p2 p1 m1 = t1

- | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1

- | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)

- difference2 | nomatch p1 p2 m2 = t1

- | zero p1 m2 = differenceWithKey f t1 l2

- | otherwise = differenceWithKey f t1 r2

-differenceWithKey f t1@(Tip k x) t2 [_$_]

- = case lookup k t2 of

- Just y -> case f k x y of

- Just y' -> Tip k y'

-differenceWithKey f Nil t = Nil

-differenceWithKey f t (Tip k y) = updateWithKey (\k x -> f k x y) k t

-differenceWithKey f t Nil = t

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys). [_$_]

-intersection :: IntMap a -> IntMap a -> IntMap a

-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = intersection1

- | shorter m2 m1 = intersection2

- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)

- intersection1 | nomatch p2 p1 m1 = Nil

- | zero p2 m1 = intersection l1 t2

- | otherwise = intersection r1 t2

- intersection2 | nomatch p1 p2 m2 = Nil

- | zero p1 m2 = intersection t1 l2

- | otherwise = intersection t1 r2

-intersection t1@(Tip k x) t2 [_$_]

- | member k t2 = t1

-intersection t (Tip k x) [_$_]

- = case lookup k t of

-intersection Nil t = Nil

-intersection t Nil = Nil

--- | /O(n+m)/. The intersection with a combining function. [_$_]

-intersectionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a

-intersectionWith f m1 m2

- = intersectionWithKey (\k x y -> f x y) m1 m2

--- | /O(n+m)/. The intersection with a combining function. [_$_]

-intersectionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a

-intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = intersection1

- | shorter m2 m1 = intersection2

- | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)

- intersection1 | nomatch p2 p1 m1 = Nil

- | zero p2 m1 = intersectionWithKey f l1 t2

- | otherwise = intersectionWithKey f r1 t2

- intersection2 | nomatch p1 p2 m2 = Nil

- | zero p1 m2 = intersectionWithKey f t1 l2

- | otherwise = intersectionWithKey f t1 r2

-intersectionWithKey f t1@(Tip k x) t2 [_$_]

- = case lookup k t2 of

- Just y -> Tip k (f k x y)

-intersectionWithKey f t1 (Tip k y) [_$_]

- = case lookup k t1 of

- Just x -> Tip k (f k x y)

-intersectionWithKey f Nil t = Nil

-intersectionWithKey f t Nil = Nil

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). [_$_]

--- Defined as (@properSubset = properSubsetBy (==)@).

-properSubset :: Eq a => IntMap a -> IntMap a -> Bool

- = properSubsetBy (==) m1 m2

-{- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).

- The expression (@properSubsetBy f m1 m2@) returns @True@ when

- @m1@ and @m2@ are not equal,

- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when

- applied to their respective values. For example, the following [_$_]

- expressions are all @True@.

- > properSubsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

- > properSubsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

- But the following are all @False@:

- > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])

- > properSubsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])

- > properSubsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

-properSubsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool

-properSubsetBy pred t1 t2

- = case subsetCmp pred t1 t2 of [_$_]

-subsetCmp pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = GT

- | shorter m2 m1 = subsetCmpLt

- | p1 == p2 = subsetCmpEq

- | otherwise = GT -- disjoint

- subsetCmpLt | nomatch p1 p2 m2 = GT

- | zero p1 m2 = subsetCmp pred t1 l2

- | otherwise = subsetCmp pred t1 r2

- subsetCmpEq = case (subsetCmp pred l1 l2, subsetCmp pred r1 r2) of

-subsetCmp pred (Bin p m l r) t = GT

-subsetCmp pred (Tip kx x) (Tip ky y) [_$_]

- | (kx == ky) && pred x y = EQ

- | otherwise = GT -- disjoint

-subsetCmp pred (Tip k x) t [_$_]

- = case lookup k t of

- Just y | pred x y -> LT

- other -> GT -- disjoint

-subsetCmp pred Nil Nil = EQ

-subsetCmp pred Nil t = LT

--- | /O(n+m)/. Is this a subset? Defined as (@subset = subsetBy (==)@).

-subset :: Eq a => IntMap a -> IntMap a -> Bool

- = subsetBy (==) m1 m2

-{- | /O(n+m)/. [_$_]

- The expression (@subsetBy f m1 m2@) returns @True@ if

- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when

- applied to their respective values. For example, the following [_$_]

- expressions are all @True@.

- > subsetBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

- > subsetBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

- > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])

- But the following are all @False@:

- > subsetBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])

- > subsetBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])

- > subsetBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])

-subsetBy :: (a -> a -> Bool) -> IntMap a -> IntMap a -> Bool

-subsetBy pred t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)

- | shorter m1 m2 = False

- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then subsetBy pred t1 l2

- else subsetBy pred t1 r2) [_$_]

- | otherwise = (p1==p2) && subsetBy pred l1 l2 && subsetBy pred r1 r2

-subsetBy pred (Bin p m l r) t = False

-subsetBy pred (Tip k x) t = case lookup k t of

- Just y -> pred x y

- Nothing -> False [_$_]

-subsetBy pred Nil t = True

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Map a function over all values in the map.

-map :: (a -> b) -> IntMap a -> IntMap b

- = mapWithKey (\k x -> f x) m

--- | /O(n)/. Map a function over all values in the map.

-mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b

-mapWithKey f t [_$_]

- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)

- Tip k x -> Tip k (f k x)

--- | /O(n)/. The function @mapAccum@ threads an accumulating

--- argument through the map in an unspecified order.

-mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)

- = mapAccumWithKey (\a k x -> f a x) a m

--- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating

--- argument through the map in an unspecified order.

-mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)

-mapAccumWithKey f a t

--- | /O(n)/. The function @mapAccumL@ threads an accumulating

--- argument through the map in pre-order.

-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)

- Bin p m l r -> let (a1,l') = mapAccumL f a l

- (a2,r') = mapAccumL f a1 r

- in (a2,Bin p m l' r')

- Tip k x -> let (a',x') = f a k x in (a',Tip k x')

--- | /O(n)/. The function @mapAccumR@ threads an accumulating

--- argument throught the map in post-order.

-mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)

- Bin p m l r -> let (a1,r') = mapAccumR f a r

- (a2,l') = mapAccumR f a1 l

- in (a2,Bin p m l' r')

- Tip k x -> let (a',x') = f a k x in (a',Tip k x')

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Filter all values that satisfy some predicate.

-filter :: (a -> Bool) -> IntMap a -> IntMap a

- = filterWithKey (\k x -> p x) m

--- | /O(n)/. Filter all keys\/values that satisfy some predicate.

-filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a

-filterWithKey pred t

- -> bin p m (filterWithKey pred l) (filterWithKey pred r)

- | otherwise -> Nil

--- | /O(n)/. partition the map according to some predicate. The first

--- map contains all elements that satisfy the predicate, the second all

--- elements that fail the predicate. See also 'split'.

-partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)

- = partitionWithKey (\k x -> p x) m

--- | /O(n)/. partition the map according to some predicate. The first

--- map contains all elements that satisfy the predicate, the second all

--- elements that fail the predicate. See also 'split'.

-partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)

-partitionWithKey pred t

- -> let (l1,l2) = partitionWithKey pred l

- (r1,r2) = partitionWithKey pred r

- in (bin p m l1 r1, bin p m l2 r2)

- | pred k x -> (t,Nil)

- | otherwise -> (Nil,t)

--- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@

--- where all keys in @map1@ are lower than @k@ and all keys in

--- @map2@ larger than @k@.

-split :: Key -> IntMap a -> (IntMap a,IntMap a)

- | zero k m -> let (lt,gt) = split k l in (lt,union gt r)

- | otherwise -> let (lt,gt) = split k r in (union l lt,gt)

- | otherwise -> (Nil,Nil)

--- | /O(log n)/. Performs a 'split' but also returns whether the pivot

--- key was found in the original map.

-splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)

- | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)

- | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)

- | k>ky -> (Nothing,t,Nil)

- | k<ky -> (Nothing,Nil,t)

- | otherwise -> (Just y,Nil,Nil)

- Nil -> (Nothing,Nil,Nil)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Fold over the elements of a map in an unspecified order.

--- > sum map = fold (+) 0 map

--- > elems map = fold (:) [] map

-fold :: (a -> b -> b) -> b -> IntMap a -> b

- = foldWithKey (\k x y -> f x y) z t

--- | /O(n)/. Fold over the elements of a map in an unspecified order.

--- > keys map = foldWithKey (\k x ks -> k:ks) [] map

-foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b

-foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b

- Bin p m l r -> foldR f (foldR f z r) l

- Tip k x -> f k x z

-{--------------------------------------------------------------------

- List variations [_$_]

---------------------------------------------------------------------}

--- | /O(n)/. Return all elements of the map.

-elems :: IntMap a -> [a]

- = foldWithKey (\k x xs -> x:xs) [] m [_$_]

--- | /O(n)/. Return all keys of the map.

-keys :: IntMap a -> [Key]

- = foldWithKey (\k x ks -> k:ks) [] m

--- | /O(n)/. Return all key\/value pairs in the map.

-assocs :: IntMap a -> [(Key,a)]

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Convert the map to a list of key\/value pairs.

-toList :: IntMap a -> [(Key,a)]

- = foldWithKey (\k x xs -> (k,x):xs) [] t

--- | /O(n)/. Convert the map to a list of key\/value pairs where the

--- keys are in ascending order.

-toAscList :: IntMap a -> [(Key,a)]

- = -- NOTE: the following algorithm only works for big-endian trees

- let (pos,neg) = span (\(k,x) -> k >=0) (foldR (\k x xs -> (k,x):xs) [] t) in neg ++ pos

--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.

-fromList :: [(Key,a)] -> IntMap a

- = foldlStrict ins empty xs

- ins t (k,x) = insert k x t

--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.

-fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a [_$_]

- = fromListWithKey (\k x y -> f x y) xs

--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.

-fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a [_$_]

-fromListWithKey f xs [_$_]

- = foldlStrict ins empty xs

- ins t (k,x) = insertWithKey f k x t

--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where

--- the keys are in ascending order.

-fromAscList :: [(Key,a)] -> IntMap a

--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where

--- the keys are in ascending order, with a combining function on equal keys.

-fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a

-fromAscListWith f xs

- = fromListWith f xs

--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where

--- the keys are in ascending order, with a combining function on equal keys.

-fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a

-fromAscListWithKey f xs

- = fromListWithKey f xs

--- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs where

--- the keys are in ascending order and all distinct.

-fromDistinctAscList :: [(Key,a)] -> IntMap a

-fromDistinctAscList xs

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-instance Eq a => Eq (IntMap a) where

- t1 == t2 = equal t1 t2

- t1 /= t2 = nequal t1 t2

-equal :: Eq a => IntMap a -> IntMap a -> Bool

-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)

- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) [_$_]

-equal (Tip kx x) (Tip ky y)

- = (kx == ky) && (x==y)

-equal Nil Nil = True

-equal t1 t2 = False

-nequal :: Eq a => IntMap a -> IntMap a -> Bool

-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)

- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) [_$_]

-nequal (Tip kx x) (Tip ky y)

- = (kx /= ky) || (x/=y)

-nequal Nil Nil = False

-nequal t1 t2 = True

-instance Show a => Show (IntMap a) where

- showsPrec d t = showMap (toList t)

-showMap :: (Show a) => [(Key,a)] -> ShowS

- = showString "{}" [_$_]

-showMap (x:xs) [_$_]

- = showChar '{' . showElem x . showTail xs

- showTail [] = showChar '}'

- showTail (x:xs) = showChar ',' . showElem x . showTail xs

- showElem (k,x) = shows k . showString ":=" . shows x

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Show the tree that implements the map. The tree is shown

--- in a compressed, hanging format.

-showTree :: Show a => IntMap a -> String

- = showTreeWith True False s

-{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows

- the tree that implements the map. If @hang@ is

- @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If

- @wide@ is true, an extra wide version is shown.

-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String

-showTreeWith hang wide t

- | hang = (showsTreeHang wide [] t) ""

- | otherwise = (showsTree wide [] [] t) ""

-showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS

-showsTree wide lbars rbars t

- -> showsTree wide (withBar rbars) (withEmpty rbars) r .

- showWide wide rbars .

- showsBars lbars . showString (showBin p m) . showString "\n" .

- showWide wide lbars .

- showsTree wide (withEmpty lbars) (withBar lbars) l

- -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n" [_$_]

- Nil -> showsBars lbars . showString "|\n"

-showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS

-showsTreeHang wide bars t

- -> showsBars bars . showString (showBin p m) . showString "\n" . [_$_]

- showWide wide bars .

- showsTreeHang wide (withBar bars) l .

- showWide wide bars .

- showsTreeHang wide (withEmpty bars) r

- -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" [_$_]

- Nil -> showsBars bars . showString "|\n" [_$_]

- = "*" -- ++ show (p,m)

-showWide wide bars [_$_]

- | wide = showString (concat (reverse bars)) . showString "|\n" [_$_]

-showsBars :: [String] -> ShowS

- _ -> showString (concat (reverse (tail bars))) . showString node

-withBar bars = "| ":bars

-withEmpty bars = " ":bars

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a

- | zero p1 m = Bin p m t1 t2

- | otherwise = Bin p m t2 t1

- m = branchMask p1 p2

-{--------------------------------------------------------------------

- @bin@ assures that we never have empty trees within a tree.

---------------------------------------------------------------------}

-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a

-bin p m l r = Bin p m l r

-{--------------------------------------------------------------------

- Endian independent bit twiddling

---------------------------------------------------------------------}

-zero :: Key -> Mask -> Bool

- = (natFromInt i) .&. (natFromInt m) == 0

-nomatch,match :: Key -> Prefix -> Mask -> Bool

-mask :: Key -> Mask -> Prefix

- = maskW (natFromInt i) (natFromInt m)

-{--------------------------------------------------------------------

- Big endian operations [_$_]

---------------------------------------------------------------------}

-maskW :: Nat -> Nat -> Prefix

- = intFromNat (i .&. (complement (m-1) `xor` m))

-shorter :: Mask -> Mask -> Bool

- = (natFromInt m1) > (natFromInt m2)

-branchMask :: Prefix -> Prefix -> Mask

- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))

-{----------------------------------------------------------------------

- Finding the highest bit (mask) in a word [x] can be done efficiently in

- * convert to a floating point value and the mantissa tells us the [_$_]

- [log2(x)] that corresponds with the highest bit position. The mantissa [_$_]

- is retrieved either via the standard C function [frexp] or by some bit [_$_]

- twiddling on IEEE compatible numbers (float). Note that one needs to [_$_]

- use at least [double] precision for an accurate mantissa of 32 bit [_$_]

- * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).

- * use processor specific assembler instruction (asm).

- The most portable way would be [bit], but is it efficient enough?

- I have measured the cycle counts of the different methods on an AMD [_$_]

- Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:

- highestBitMask: method cycles

- highestBit: method cycles

- Wow, the bit twiddling is on today's RISC like machines even faster

- than a single CISC instruction (BSR)!

-----------------------------------------------------------------------}

-{----------------------------------------------------------------------

- [highestBitMask] returns a word where only the highest bit is set.

- It is found by first setting all bits in lower positions than the [_$_]

- highest bit and than taking an exclusive or with the original value.

- Allthough the function may look expensive, GHC compiles this into

- excellent C code that subsequently compiled into highly efficient

- machine code. The algorithm is derived from Jorg Arndt's FXT library.

-----------------------------------------------------------------------}

-highestBitMask :: Nat -> Nat

- = case (x .|. shiftRL x 1) of [_$_]

- x -> case (x .|. shiftRL x 2) of [_$_]

- x -> case (x .|. shiftRL x 4) of [_$_]

- x -> case (x .|. shiftRL x 8) of [_$_]

- x -> case (x .|. shiftRL x 16) of [_$_]

- x -> case (x .|. shiftRL x 32) of -- for 64 bit platforms

- x -> (x `xor` (shiftRL x 1))

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-testTree :: [Int] -> IntMap Int

-testTree xs = fromList [(x,x*x*30696 `mod` 65521) | x <- xs]

-test1 = testTree [1..20]

-test2 = testTree [30,29..10]

-test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

- = check config prop

- { configMaxTest = 500

- , configMaxFail = 5000

- , configSize = \n -> (div n 2 + 3)

- , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]

-{--------------------------------------------------------------------

- Arbitrary, reasonably balanced trees

---------------------------------------------------------------------}

-instance Arbitrary a => Arbitrary (IntMap a) where

- arbitrary = do{ ks <- arbitrary

- ; xs <- mapM (\k -> do{ x <- arbitrary; return (k,x)}) ks

- ; return (fromList xs)

-{--------------------------------------------------------------------

- Single, Insert, Delete

---------------------------------------------------------------------}

-prop_Single :: Key -> Int -> Bool

- = (insert k x empty == single k x)

-prop_InsertDelete :: Key -> Int -> IntMap Int -> Property

-prop_InsertDelete k x t

- = not (member k t) ==> delete k (insert k x t) == t

-prop_UpdateDelete :: Key -> IntMap Int -> Bool [_$_]

-prop_UpdateDelete k t

- = update (const Nothing) k t == delete k t

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-prop_UnionInsert :: Key -> Int -> IntMap Int -> Bool

-prop_UnionInsert k x t

- = union (single k x) t == insert k x t

-prop_UnionAssoc :: IntMap Int -> IntMap Int -> IntMap Int -> Bool

-prop_UnionAssoc t1 t2 t3

- = union t1 (union t2 t3) == union (union t1 t2) t3

-prop_UnionComm :: IntMap Int -> IntMap Int -> Bool

-prop_UnionComm t1 t2

- = (union t1 t2 == unionWith (\x y -> y) t2 t1)

-prop_Diff :: [(Key,Int)] -> [(Key,Int)] -> Bool

- = List.sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys))) [_$_]

- == List.sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))

-prop_Int :: [(Key,Int)] -> [(Key,Int)] -> Bool

- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) [_$_]

- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

- = forAll (choose (5,100)) $ \n ->

- let xs = [(x,()) | x <- [0..n::Int]] [_$_]

- in fromAscList xs == fromList xs

-prop_List :: [Key] -> Bool

- = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])

+Category: Compilers/Interpreters

- Hs-Source-Dirs: src lib/DData

+ Hs-Source-Dirs: src

-DDATA = lib/DData/IntMap.hs

-SRCS = $(INBLOBS) $(DDATA)

-IFACES = src:lib/DData:src/Functional

+IFACES = src:src/Functional

- ghc -cpp -E -optP-P -D__HADDOCK__ lib/DData/IntMap.hs -o lib/DData/IntMap.hspp

- lib/DData/IntMap.hspp \

- $(RM) lib/DData/*.o

- $(RM) lib/DData/*.hi

+ $(RM) src/Functional/*.o

+ $(RM) src/Functional/*.hi

-lib/DData/IntMap.o : lib/DData/IntMap.hs

-src/Common.o : lib/DData/IntMap.hi

-src/Network.o : lib/DData/IntMap.hi

-src/INRule.o : lib/DData/IntMap.hi

-src/NetworkView.o : lib/DData/IntMap.hi

-src/INTextual.o : lib/DData/IntMap.hi

-src/Operations.o : lib/DData/IntMap.hi

-src/Main.o : lib/DData/IntMap.hi

-import qualified IntMap

-import Char(isSpace)

+import qualified Data.IntMap as IntMap

+import Data.Char(isSpace)

-import List(elemIndex)

+import Data.List(elemIndex)

+import Data.List ((\\))

-import List (nub,(\\))

+import Data.List (nub,(\\))

-import IntMap (empty)

+import qualified Data.IntMap as IntMap (empty)

-import qualified IntMap as IM

+import qualified Data.IntMap as IM

-import IntMap (IntMap)

-import qualified IntMap

-import Maybe (fromJust, fromMaybe)

+import Data.IntMap (IntMap)

+import qualified Data.IntMap as IntMap

+import Data.List (nub)

+import Data.Maybe (fromJust, fromMaybe)

-import IntMap hiding (map)

-import qualified Data.List

+import Data.IntMap as IntMap hiding (map)

+import qualified Data.List as List

-getUnusedNodeNr network | null used = 1

+getUnusedNodeNr network | List.null used = 1

-getUnusedEdgeNr network | null used = 1

+getUnusedEdgeNr network | List.null used = 1

-isEmpty = IntMap.isEmpty . networkNodes [_$_]

+isEmpty = IntMap.null . networkNodes

-import Char (isSpace)

+import Data.Char (isSpace)

-import List(nub,isPrefixOf)

+import Data.List(nub,isPrefixOf)

-import qualified IntMap

+import qualified Data.IntMap as IntMap

-import List (nub, (\\), deleteBy)

+import Data.List (nub, (\\), deleteBy)

Tue Jun 17 10:39:56 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>

* Remove unnecessary module

+ $(RM) -rf $(MAIN).app

-src/XTC.o : src/XTC.hs

---------------------------------------------------------------------------------

- Copyright : (c) Martijn Schrage 2005

- Maintainer : martijn@cs.uu.nl

- Stability : experimental

- Portability : portable

- XTC: eXtended & Typed Controls for wxHaskell

- The XTC library provides a typed interface to several wxHaskell controls.

- - radio view (typed radio box)

- - single-selection list view (typed single-selection list box)

- - muliple-selection list view (typed multiple-selection list box)

- - choice view (typed choice box)

- - value entry (typed text entry)

- XTC controls keep track of typed values and items, rather than

- being string based. Selections in XTC controls consist of actual values

- instead of indices.

---------------------------------------------------------------------------------

-module XTC ( -- * Classes

- Labeled( toLabel )

- , TypedValued( typedValue )

- , TypedItems( typedItems )

- , TypedSelection( typedSelection )

- , TypedMaybeSelection( typedMaybeSelection )

- , TypedSelections( typedSelections )

- , RadioView, mkRadioView, mkRadioViewEx

- -- ** Single-selection list view

- , ListView, mkListView, mkListViewEx

- -- ** Multiple-selection list view

- , MultiListView, mkMultiListView, mkMultiListViewEx

- , ChoiceView, mkChoiceView, mkChoiceViewEx

- , ValueEntry, mkValueEntry, mkValueEntryEx

-import Graphics.UI.WX hiding (window, label)

-import qualified Graphics.UI.WX

-import Graphics.UI.WXCore hiding (label, Event)

--- | The labeled class is used by 'mkRadioView', 'mkListView', 'mkMultiListView', and

--- 'mkChoiceView' for conveniently passing the function that maps an item onto its label.

-class Labeled x where

- toLabel :: x -> String

-instance Labeled String where

--- | Widgets that have a typed selection. The selection can be accessed via the attribute 'typedSelection', and has type @x@.

-class Selection w => TypedSelection x w | w -> x where

- typedSelection :: Attr w x

--- | Widgets that have a typed selection that may be empty. The selection can be accessed via the attribute 'typedMaybeSelection', and has type @Maybe x@.

-class Selection w => TypedMaybeSelection x w | w -> x where

- typedMaybeSelection :: Attr w (Maybe x)

--- | Widgets that have a typed list of selections. The selection list can be accessed via the attribute 'typedSelections', and has type @[x]@.

-class Selections w => TypedSelections x w | w -> x where

- typedSelections :: Attr w [x]

--- | Widgets that have a typed list of items. The item list can be accessed via the attribute 'typedItems', and has type @[x]@.

-class Items w String => TypedItems x w | w -> x where

- typedItems :: Attr w [x]

--- | Widgets that have a typed value. The value can be accessed via the attribute 'typedValue', and has type @x@.

-class TypedValued x w | w -> x where

- typedValue :: Attr w (Maybe x)

-{--------------------------------------------------------------------------------

---------------------------------------------------------------------------------}

-data CRadioView x b

--- | Pointer to a radio view, deriving from 'RadioBox'.

-type RadioView x b = RadioBox (CRadioView x b)

-instance TypedSelection x (RadioView x ()) where

- = newAttr "typedSelection" radioViewGetTypedSelection radioViewSetTypedSelection

-instance TypedItems x (RadioView x ()) where

- typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems

--- | Create a new radio view with an initial orientation and a list of

--- typed items. The item type (@x@) must be an instance of 'Labeled' to show each item's

--- label. Use attribute 'typedSelection' to access the currently selected item, and 'typedItems' to access the list of items. Note:

--- for a radio view (or radio box) the items may not be modified dynamically.

--- * Instances: 'TypedSelection', 'TypedItems', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkRadioView :: Labeled x => Window a -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ())

-mkRadioView window orientation viewItems props =

- mkRadioViewEx window toLabel orientation viewItems props

--- | Create a new radio view with an initial orientation and a list of

--- typed items. A function of type @(x -> String)@ maps items onto labels. [_$_]

--- Use attribute 'typedSelection' to access the currently selected item, and 'typedItems' to access the list of items. Note:

--- for a radio view (or radio box) the items may not be modified dynamically.

--- * Instances: 'TypedSelection', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkRadioViewEx :: Window a -> (x -> String) -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ())

-mkRadioViewEx window present orientation viewItems props =

- do { model <- varCreate viewItems

- ; radioView <- fmap objectCast $ radioBox window orientation (map present viewItems) []

- ; objectSetClientData radioView (return ()) (model, present)

- ; set radioView props

- ; return radioView

- } -- cannot use mkViewEx because items must be set at creation (items is not writeable)

-radioViewSetTypedSelection :: RadioView x () -> x -> IO ()

-radioViewSetTypedSelection radioView x = viewSetTypedMaybeSelection radioView (Just x)

-radioViewGetTypedSelection :: RadioView x () -> IO x

-radioViewGetTypedSelection radioView = [_$_]

- do { mSel <- viewGetTypedMaybeSelection radioView

- Just item -> return item

- Nothing -> internalError "XTC" "radioViewGetTypedSelection" "Radio view has empty selection"

-{--------------------------------------------------------------------------------

- Single-selection list view

---------------------------------------------------------------------------------}

--- | Pointer to a single-selection list view, deriving from 'SingleListBox'.

-type ListView a b = SingleListBox (CListView a b)

-instance TypedMaybeSelection x (ListView x ()) where

- typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection

-instance TypedItems x (ListView x ()) where

- typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems

--- | Create a single-selection list view. The item type (@x@) must be an instance of 'Labeled' to show each item's

--- label. Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.

--- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted','Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkListView :: Labeled x => Window a -> [Prop (ListView x ())] -> IO (ListView x ())

-mkListView window props = mkListViewEx window toLabel props

--- | Create a single-selection list view. A function of type @(x -> String)@ maps items onto labels. [_$_]

--- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.

--- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted','Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkListViewEx :: Window a -> (x -> String) -> [Prop (ListView x ())] -> IO (ListView x ())

-mkListViewEx window present props = mkViewEx singleListBox window present props

-{--------------------------------------------------------------------------------

- Multiple-selection list view

---------------------------------------------------------------------------------}

-data CMultiListView a b

--- | Pointer to a multiple-selection list view, deriving from 'MultiListBox'.

-type MultiListView a b = MultiListBox (CMultiListView a b)

-instance TypedSelections x (MultiListView x ()) where

- typedSelections = newAttr "typedSelections" multiListViewGetTypedSelections multiListViewSetTypedSelections

-instance TypedItems x (MultiListView x ()) where

- typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems

--- | Create a multiple-selection list view. The item type (@x@) must be an instance of 'Labeled' to show each item's

--- Use attribute 'typedSelections' to access the currently selected items, and 'typedItems' to access the list of items.

--- * Instances: 'TypedSelections', 'TypedItems', 'Sorted', 'Selecting','Selections','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkMultiListView :: Labeled x => Window a -> [Prop (MultiListView x ())] -> IO (MultiListView x ())

-mkMultiListView window props = mkMultiListViewEx window toLabel props

--- | Create a multiple-selection list view. A function of type @(x -> String)@ maps items onto labels. [_$_]

--- Use attribute 'typedSelections' to access the currently selected items, and 'typedItems' to access the list of items.

--- * Instances: 'TypedSelections', 'TypedItems', 'Sorted', 'Selecting','Selections','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkMultiListViewEx :: Window a -> (x -> String) -> [Prop (MultiListView x ())] -> IO (MultiListView x ())

-mkMultiListViewEx window present props = mkViewEx multiListBox window present props

-multiListViewSetTypedSelections :: MultiListView x () -> [x] -> IO ()

-multiListViewSetTypedSelections (multiListView :: MultiListView x ()) selectionItems =

- do { Just ((model, present) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData multiListView

- ; viewItems <- get model value

- ; let labels = map present selectionItems

- ; let indices = catMaybes [ findIndex (\it -> present it == label) viewItems

- | label <- labels ]

- ; set multiListView [ selections := indices ]

-multiListViewGetTypedSelections :: forall x. MultiListView x () -> IO [x]

-multiListViewGetTypedSelections multiListView =

- do { Just ((model, _) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData multiListView

- ; selectedIndices <- get multiListView selections

- ; viewItems <- get model value

- ; return (map (safeIndex "XTC.multiListViewGetTypedSelections" viewItems)

-{--------------------------------------------------------------------------------

---------------------------------------------------------------------------------}

-data CChoiceView a b

--- | Pointer to a choice view, deriving from 'Choice'.

-type ChoiceView a b = Choice (CChoiceView a b)

-instance TypedMaybeSelection x (ChoiceView x ()) where

- typedMaybeSelection = newAttr "typedMaybeSelection" viewGetTypedMaybeSelection viewSetTypedMaybeSelection

-instance TypedItems x (ChoiceView x ()) where

- typedItems = newAttr "typedItems" viewGetTypedItems viewSetTypedItems

--- | Create a choice view to select one item from a list of typed items. The item type (@x@) must be an instance of 'Labeled' to show each item's

--- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.

--- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkChoiceView :: Labeled x => Window a -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ())

-mkChoiceView window (props :: [Prop (ChoiceView x ())]) =

- mkViewEx choice window (toLabel :: x -> String) props

--- | Create a choice view to select one item from a list of typed items. A function of type @(x -> String)@ maps items onto labels. [_$_]

--- Use attribute 'typedMaybeSelection' to access the currently selected item, and 'typedItems' to access the list of items.

--- * Instances: 'TypedMaybeSelection', 'TypedItems', 'Sorted', 'Selecting','Selection','Items' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkChoiceViewEx :: Window a -> (x -> String) -> Style -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ())

-mkChoiceViewEx window present stl props =

- mkViewEx (\win -> choiceEx win stl) window present props

--- Generic constructors, getters, and setters

--- Generic mk function that puts a model and a present function in the client data.

--- Used for ListView, MultiListView, and ChoiceView.

-mkViewEx :: (parent -> [p] -> IO (Object a)) -> parent -> (x -> String) -> [Prop (WxObject b)] ->

-mkViewEx mkView window present props =

- do { model <- varCreate []

- ; view <- fmap objectCast $ mkView window []

- ; objectSetClientData view (return ()) (model, present)

--- Generic getTypedMaybeSelection for RadioView, ListView, and ChoiceView.

-viewGetTypedMaybeSelection :: forall a x. Selection (WxObject a) => WxObject a -> IO (Maybe x)

-viewGetTypedMaybeSelection view =

- do { Just ((model, _) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData view

- ; selectedIndex <- get view selection

- ; if selectedIndex == -1

- then return Nothing

- else do { viewItems <- get model value

- ; return $ Just (safeIndex "XTC.viewGetTypedMaybeSelection" viewItems selectedIndex)

--- Generic setTypedMaybeSelection for RadioView, ListView, and ChoiceView.

-viewSetTypedMaybeSelection :: forall a x. Selection (WxObject a) => WxObject a -> Maybe x -> IO ()

-viewSetTypedMaybeSelection view mSelectionItem =

- do { Just ((model, present) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData view

- ; viewItems <- get model value

- ; let index = case mSelectionItem of

- Just selectionItem -> let label = present selectionItem

- in findLabelIndex present label viewItems

- ; set view [ selection := index ]

- where findLabelIndex :: (x -> String) -> String -> [x] -> Int

- findLabelIndex present label theItems =

- case findIndex (\it -> present it == label) theItems of

--- Generic getTypedItems for ListView, MultiListView, and ChoiceView.

-viewGetTypedItems :: forall a x. TypedItems x (WxObject a) => WxObject a -> IO [x]

-viewGetTypedItems view =

- do { Just ((model, _) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData view

- ; viewItems <- get model value

- ; return viewItems

--- Generic setTypedItems for ListView, MultiListView, and ChoiceView.

-viewSetTypedItems :: forall a x. TypedItems x (WxObject a) => WxObject a -> [x] -> IO ()

-viewSetTypedItems view viewItems =

- do { Just ((model, present) :: (Var [x], x -> String)) <-

- unsafeObjectGetClientData view

- ; set model [ value := viewItems ]

- ; set view [ items := map present viewItems ]

-{--------------------------------------------------------------------------------

---------------------------------------------------------------------------------}

-data CValueEntry x b

--- | Pointer to a choice view, deriving from 'TextCtrl'.

-type ValueEntry x b = TextCtrl (CValueEntry x b)

-instance TypedValued x (ValueEntry x ()) where

- = newAttr "typedValue" valueEntryGetTypedValue valueEntrySetTypedValue

--- | Create a single-line value entry control. The value type (@x@) must be an instance of 'Show' and 'Read'

--- to present a value as a string in the entry and parse the string from the entry back to (maybe) a value.

--- Use 'typedValue' to access the value.

--- Note: 'alignment' has to

--- be set at creation time (or the entry has default alignment (=left) ).

--- * Instances: 'TypedValued', 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkValueEntry :: (Show x, Read x) => Window b -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ())

-mkValueEntry window props = mkValueEntryEx window show readParse props

--- | Create a single-line value entry control. The two functions of type @(x -> String)@ and @(String -> Maybe x)@ are used

--- to present a value as a string in the entry and parse the string from the entry back to (maybe) a value.

--- Use 'typedValue' to access the value.

--- Note: 'alignment' has to

--- be set at creation time (or the entry has default alignment (=left) ).

--- * Instances: 'TypedValued', 'Wrap', 'Aligned', 'Commanding' -- 'Textual', 'Literate', 'Dimensions', 'Colored', 'Visible', 'Child',

--- 'Able', 'Tipped', 'Identity', 'Styled', 'Reactive', 'Paint'.

-mkValueEntryEx :: Window b -> (x -> String) -> (String -> Maybe x) -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ())

-mkValueEntryEx window present parse props =

- do { valueEntry <- fmap objectCast $ textEntry window []

- ; objectSetClientData valueEntry (return ()) (present, parse)

- ; set valueEntry $ props ++ [ on change := validate valueEntry ]

- ; return valueEntry

- where validate :: ValueEntry x () -> IO ()

- validate valueEntry =

- do { mVal <- get valueEntry typedValue

- ; set valueEntry [ bgcolor := case mVal of

- Nothing -> lightgrey

- ; repaint valueEntry

- } -- drawing a squiggly is not possible because font metrics are not available

-valueEntryGetTypedValue :: forall x. ValueEntry x () -> IO (Maybe x)

-valueEntryGetTypedValue valueEntry =

- do { Just ((_, parse) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry

- ; valueStr <- get valueEntry text

- ; return $ parse valueStr

-valueEntrySetTypedValue :: forall x. ValueEntry x () -> Maybe x -> IO ()

-valueEntrySetTypedValue valueEntry mValue =

- do { Just ((present, _) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry

- Nothing -> return ()

- Just theValue -> set valueEntry [ text := present theValue ]

--- Utility functions

--- A variation of 'read' that returns Nothing if the string cannot be parsed.

-readParse :: Read x => String -> Maybe x

-readParse str = case reads str of

- [(x, "")] -> Just x

-safeIndex :: String -> [a] -> Int -> a

- | i >= 0 && i < length xs = xs !! i

- | otherwise = internalError "XTC" "safeIndex" msg

-internalError :: String -> String -> String -> a

-internalError moduleName functionName errorString =

- error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)

--- Some bits that should be part of wxHaskell

-instance Selecting (ChoiceView x ()) where

- select = newEvent "select" choiceGetOnCommand choiceOnCommand

--- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of

--- "Selecting (Choice a)".

-instance Selection (ChoiceView x ()) where

- selection = newAttr "selection" choiceGetSelection choiceSetSelection

--- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of

--- "Selection (Choice a)".

--- The Observable class is missing from wxHaskell, even though the components are there.

-class Observable w where

- change :: Event w (IO ())

-instance Observable (TextCtrl a) where

- change = newEvent "change" (controlGetOnText) (controlOnText)

- do { -- counterV <- mkObservableVar 1

--- ; listV <- singleListBox f [items := ["hallo"]]

- ; listV <- mkListView f [ typedItems := ["sdfsdf", "fdssd"]

- ; radioV <- mkRadioView f Vertical [ "Een", "Twee" ] []

- ; choiceV <- mkChoiceView f [ typedItems := ["sdfsdf", "fdssd"]

- -- ; comboV <- mkComboView f [ typedItems := ["sdfsdf", "fdssd"]

- -- , enabled := True

- ; t <- textEntry f []

- ; ve <- mkValueEntry f [ typedValue := Just True ]

- -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ]

- ; bUp <- button f [ text := "increase", on command := do { -- s1 <- get comboV typedSelection

- ; s1 <- get radioV typedSelection

- ; s2 <- get listV typedMaybeSelection

- } ] -- set counterV [ value :~ (+1) ] ]

- -- ; bDown <- button f [ text := "decrease", on command := set counterV [ value :~ (+ (-1::Int)) ] ]

- -- ; bChangeHandler <- button f [ text := "change handler"

- -- , on command := set t [ on (change counterV) := \i -> set t [text := "<<"++show i++">>"] ]]

- ; set f [ layout := column 5 [ row 5 [ Graphics.UI.WX.label "Counter value:", widget t ]

- -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ]

- -- , hfloatCenter $ widget bChangeHandler

- -- , widget choiceV

- -- , widget comboV

Wed Mar 19 16:31:52 WET 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>

* Clean unnecessary stuff

-DDATA = lib/DData/IntBag.hs lib/DData/IntMap.hs lib/DData/IntSet.hs \

- lib/DData/Map.hs lib/DData/MultiSet.hs \

- lib/DData/Queue.hs lib/DData/Scc.hs \

- lib/DData/Seq.hs lib/DData/Set.hs \

+DDATA = lib/DData/IntMap.hs

-lib/DData/Set.o : lib/DData/Set.hs

-lib/DData/Seq.o : lib/DData/Seq.hs

-lib/DData/Queue.o : lib/DData/Queue.hs

-lib/DData/Map.o : lib/DData/Map.hs

-lib/DData/MultiSet.o : lib/DData/MultiSet.hs

-lib/DData/MultiSet.o : lib/DData/Map.hi

-lib/DData/Scc.o : lib/DData/Scc.hs

-lib/DData/Scc.o : lib/DData/Set.hi

-lib/DData/Scc.o : lib/DData/Map.hi

-lib/DData/IntSet.o : lib/DData/IntSet.hs

-lib/DData/IntBag.o : lib/DData/IntBag.hs

-lib/DData/IntBag.o : lib/DData/IntMap.hi

---------------------------------------------------------------------------------

-{-| Module : IntBag

- Copyright : (c) Daan Leijen 2002

- License : BSD-style

- Maintainer : daan@cs.uu.nl

- Stability : provisional

- Portability : portable

- An efficient implementation of bags of integers on top of the "IntMap" module. [_$_]

- Many operations have a worst-case complexity of /O(min(n,W))/. This means that the

- operation can become linear in the number of elements with a maximum of /W/ [_$_]

- -- the number of bits in an 'Int' (32 or 64). For more information, see

- the references in the "IntMap" module.

----------------------------------------------------------------------------------}

-module IntBag ( [_$_]

- IntBag -- instance Eq,Show

- -- ** Ordered list

- , fromDistinctAscList

- -- ** Occurrence lists

- , fromAscOccurList

-import Prelude hiding (map,filter)

-import qualified Prelude (map,filter)

-import qualified IntMap as M

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n+m)/. See 'difference'.

-(\\) :: IntBag -> IntBag -> IntBag

-b1 \\ b2 = difference b1 b2

-{--------------------------------------------------------------------

- IntBags are a simple wrapper around Maps, 'Map.Map'

---------------------------------------------------------------------}

--- | A bag of integers.

-newtype IntBag = IntBag (M.IntMap Int)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(1)/. Is the bag empty?

-isEmpty :: IntBag -> Bool

-isEmpty (IntBag m) [_$_]

--- | /O(n)/. Returns the number of distinct elements in the bag, ie. (@distinctSize bag == length (nub (toList bag))@).

-distinctSize :: IntBag -> Int

-distinctSize (IntBag m) [_$_]

--- | /O(n)/. The number of elements in the bag.

-size :: IntBag -> Int

- = foldOccur (\x n m -> n+m) 0 b

--- | /O(min(n,W))/. Is the element in the bag?

-member :: Int -> IntBag -> Bool

--- | /O(min(n,W))/. The number of occurrences of an element in the bag.

-occur :: Int -> IntBag -> Int

- = case M.lookup x m of

--- | /O(n+m)/. Is this a subset of the bag? [_$_]

-subset :: IntBag -> IntBag -> Bool

-subset (IntBag m1) (IntBag m2)

- = M.subsetBy (<=) m1 m2

--- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)

-properSubset :: IntBag -> IntBag -> Bool

- = subset b1 b2 && (b1 /= b2)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(1)/. Create an empty bag.

- = IntBag (M.empty)

--- | /O(1)/. Create a singleton bag.

-single :: Int -> IntBag

- = IntBag (M.single x 0)

-{--------------------------------------------------------------------

- Insertion, Deletion

---------------------------------------------------------------------}

--- | /O(min(n,W))/. Insert an element in the bag.

-insert :: Int -> IntBag -> IntBag

-insert x (IntBag m) [_$_]

- = IntBag (M.insertWith (+) x 1 m)

--- | /O(min(n,W))/. The expression (@insertMany x count bag@)

--- inserts @count@ instances of @x@ in the bag @bag@.

-insertMany :: Int -> Int -> IntBag -> IntBag

-insertMany x count (IntBag m) [_$_]

- = IntBag (M.insertWith (+) x count m)

--- | /O(min(n,W))/. Delete a single element.

-delete :: Int -> IntBag -> IntBag

-delete x (IntBag m)

- = IntBag (M.updateWithKey f x m)

- f x n | n > 0 = Just (n-1)

- | otherwise = Nothing

--- | /O(min(n,W))/. Delete all occurrences of an element.

-deleteAll :: Int -> IntBag -> IntBag

-deleteAll x (IntBag m)

- = IntBag (M.delete x m)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n+m)/. Union of two bags. The union adds the elements together.

--- > IntBag\> union (fromList [1,1,2]) (fromList [1,2,2,3])

--- > {1,1,1,2,2,2,3}

-union :: IntBag -> IntBag -> IntBag

-union (IntBag t1) (IntBag t2)

- = IntBag (M.unionWith (+) t1 t2)

--- | /O(n+m)/. Intersection of two bags.

--- > IntBag\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])

-intersection :: IntBag -> IntBag -> IntBag

-intersection (IntBag t1) (IntBag t2)

- = IntBag (M.intersectionWith min t1 t2)

--- | /O(n+m)/. Difference between two bags.

--- > IntBag\> difference (fromList [1,1,2]) (fromList [1,2,2,3])

-difference :: IntBag -> IntBag -> IntBag

-difference (IntBag t1) (IntBag t2)

- = IntBag (M.differenceWithKey f t1 t2)

- f x n m | n-m > 0 = Just (n-m)

- | otherwise = Nothing

--- | The union of a list of bags.

-unions :: [IntBag] -> IntBag

- = IntBag (M.unions [m | IntBag m <- bags])

-{--------------------------------------------------------------------

- Filter and partition

---------------------------------------------------------------------}

--- | /O(n)/. Filter all elements that satisfy some predicate.

-filter :: (Int -> Bool) -> IntBag -> IntBag

-filter p (IntBag m)

- = IntBag (M.filterWithKey (\x n -> p x) m)

--- | /O(n)/. Partition the bag according to some predicate.

-partition :: (Int -> Bool) -> IntBag -> (IntBag,IntBag)

-partition p (IntBag m)

- = (IntBag l,IntBag r)

- (l,r) = M.partitionWithKey (\x n -> p x) m

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Fold over each element in the bag.

-fold :: (Int -> b -> b) -> b -> IntBag -> b

-fold f z (IntBag m)

- = M.foldWithKey apply z m

- apply x n z | n > 0 = apply x (n-1) (f x z)

--- | /O(n)/. Fold over all occurrences of an element at once. [_$_]

--- In a call (@foldOccur f z bag@), the function @f@ takes

--- the element first and than the occur count.

-foldOccur :: (Int -> Int -> b -> b) -> b -> IntBag -> b

-foldOccur f z (IntBag m)

- = M.foldWithKey f z m

-{--------------------------------------------------------------------

- List variations [_$_]

---------------------------------------------------------------------}

--- | /O(n)/. The list of elements.

-elems :: IntBag -> [Int]

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Create a list with all elements.

-toList :: IntBag -> [Int]

--- | /O(n)/. Create an ascending list of all elements.

-toAscList :: IntBag -> [Int]

-toAscList (IntBag m)

- = [y | (x,n) <- M.toAscList m, y <- replicate n x]

--- | /O(n*min(n,W))/. Create a bag from a list of elements.

-fromList :: [Int] -> IntBag [_$_]

- = IntBag (M.fromListWith (+) [(x,1) | x <- xs])

--- | /O(n*min(n,W))/. Create a bag from an ascending list.

-fromAscList :: [Int] -> IntBag [_$_]

- = IntBag (M.fromAscListWith (+) [(x,1) | x <- xs])

--- | /O(n*min(n,W))/. Create a bag from an ascending list of distinct elements.

-fromDistinctAscList :: [Int] -> IntBag [_$_]

-fromDistinctAscList xs

- = IntBag (M.fromDistinctAscList [(x,1) | x <- xs])

--- | /O(n)/. Create a list of element\/occurrence pairs.

-toOccurList :: IntBag -> [(Int,Int)]

- = toAscOccurList b

--- | /O(n)/. Create an ascending list of element\/occurrence pairs.

-toAscOccurList :: IntBag -> [(Int,Int)]

-toAscOccurList (IntBag m)

--- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs.

-fromOccurList :: [(Int,Int)] -> IntBag

- = IntBag (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))

--- | /O(n*min(n,W))/. Create a bag from an ascending list of element\/occurrence pairs.

-fromAscOccurList :: [(Int,Int)] -> IntBag

-fromAscOccurList xs

- = IntBag (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences.

-toMap :: IntBag -> M.IntMap Int

--- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.

-fromMap :: M.IntMap Int -> IntBag

- = IntBag (M.filter (>0) m)

--- | /O(1)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.

--- Assumes that the 'IntMap.IntMap' contains only elements that occur at least once.

-fromOccurMap :: M.IntMap Int -> IntBag

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-instance Eq (IntBag) where

- (IntBag m1) == (IntBag m2) = (m1==m2) [_$_]

- (IntBag m1) /= (IntBag m2) = (m1/=m2)

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

-instance Show (IntBag) where

- showsPrec d b = showSet (toAscList b)

-showSet :: Show a => [a] -> ShowS

- = showString "{}" [_$_]

-showSet (x:xs) [_$_]

- = showChar '{' . shows x . showTail xs

- showTail [] = showChar '}'

- showTail (x:xs) = showChar ',' . shows x . showTail xs

-{--------------------------------------------------------------------

---------------------------------------------------------------------}

--- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree

--- is shown as a compressed and /hanging/.

-showTree :: IntBag -> String

- = showTreeWith True False bag

--- | /O(n)/. The expression (@showTreeWith hang wide map@) shows

--- the tree that implements the bag. The tree is shown /hanging/ when @hang@ is @True@ [_$_]

--- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version

-showTreeWith :: Bool -> Bool -> IntBag -> String

-showTreeWith hang wide (IntBag m)

- = M.showTreeWith hang wide m

-{-# OPTIONS -cpp -fglasgow-exts #-}

---------------------------------------------------------------------------------

-{-| Module : IntSet

- Copyright : (c) Daan Leijen 2002

- License : BSD-style

- Maintainer : daan@cs.uu.nl

- Stability : provisional

- Portability : portable

- An efficient implementation of integer sets.

- 1) The 'filter' function clashes with the "Prelude". [_$_]

- If you want to use "IntSet" unqualified, this function should be hidden.

- > import Prelude hiding (filter)

- Another solution is to use qualified names. [_$_]

- > import qualified IntSet

- > ... IntSet.fromList [1..5]

- Or, if you prefer a terse coding style:

- > import qualified IntSet as S

- > ... S.fromList [1..5]

- 2) The implementation is based on /big-endian patricia trees/. This data structure [_$_]

- performs especially well on binary operations like 'union' and 'intersection'. However,

- my benchmarks show that it is also (much) faster on insertions and deletions when [_$_]

- compared to a generic size-balanced set implementation (see "Set").