Tue Jun 17 14:00:13 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Minor Webpage Update
{
hunk ./index.html 19
- 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>.
hunk ./index.html 34
- To use INblobs you must make a copy of the <a href="http://abridgegame.org/darcs/">darcs</a> repository.<p/>
+ To use INblobs you must make a copy of the <a href="http://darcs.net/">darcs</a> repository.<p/>
hunk ./index.html 40
- 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
(Windows only)
{
hunk ./index.html 56
- Probably works as well for 95 or 98.
hunk ./index.html 61
- </ol> [_$_]
-[_^I_] [_$_]
+ </ol>
+ <p><b>Note:</b> When you run the executable, if you see the error message <i>The applicattion failed to initialize properly (0xc0150002). Click OK to terminate the application.</i> 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>.</p>
+
hunk ./makeDist.bat 6
-copy wxc-msw2.4.2-0.9.4.dll INblobs[_^M_][_$_]
+copy wxc-msw*.dll INblobs[_^M_][_$_]
binary ./wxc-msw2.4.2-0.9.4.dll
rmfile ./wxc-msw2.4.2-0.9.4.dll
addfile ./wxc-msw2.6.4-0.10.3.dll
binary ./wxc-msw2.6.4-0.10.3.dll
}
Tue Jun 17 13:49:36 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>
* More Cleanup
- Change local IntMap to external Data.IntMap
- Change some old module names to new ones
- minor cabal adds
{
hunk ./lib/DData/IntMap.hs 1
-{-# 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)
- > import IntMap
-
- 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 ( [_$_]
- -- * Map type
- IntMap, Key -- instance Eq,Show
-
- -- * Operators
- , (!), (\\)
-
- -- * Query
- , isEmpty
- , size
- , member
- , lookup
- , find [_$_]
- , findWithDefault
- [_$_]
- -- * Construction
- , empty
- , single
-
- -- ** Insertion
- , insert
- , insertWith, insertWithKey, insertLookupWithKey
- [_$_]
- -- ** Delete\/Update
- , delete
- , adjust
- , adjustWithKey
- , update
- , updateWithKey
- , updateLookupWithKey
- [_$_]
- -- * Combine
-
- -- ** Union
- , union [_$_]
- , unionWith [_$_]
- , unionWithKey
- , unions
-
- -- ** Difference
- , difference
- , differenceWith
- , differenceWithKey
- [_$_]
- -- ** Intersection
- , intersection [_$_]
- , intersectionWith
- , intersectionWithKey
-
- -- * Traversal
- -- ** Map
- , map
- , mapWithKey
- , mapAccum
- , mapAccumWithKey
- [_$_]
- -- ** Fold
- , fold
- , foldWithKey
-
- -- * Conversion
- , elems
- , keys
- , assocs
- [_$_]
- -- ** Lists
- , toList
- , fromList
- , fromListWith
- , fromListWithKey
-
- -- ** Ordered lists
- , toAscList
- , fromAscList
- , fromAscListWith
- , fromAscListWithKey
- , fromDistinctAscList
-
- -- * Filter [_$_]
- , filter
- , filterWithKey
- , partition
- , partitionWithKey
-
- , split [_$_]
- , splitLookup [_$_]
-
- -- * Subset
- , subset, subsetBy
- , properSubset, properSubsetBy
- [_$_]
- -- * Debugging
- , showTree
- , showTreeWith
- ) where
-
-
-import Prelude hiding (lookup,map,filter)
-import Bits [_$_]
-import Int
-
-{-
--- 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.Word
-import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#else
-import Word
-import GlaExts ( Word(..), Int(..), shiftRL# )
-#endif
-
-infixl 9 \\ -- cpp nonsense
-
-type Nat = Word
-
-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)
-
-#elif __HUGS__
-{--------------------------------------------------------------------
- Hugs: [_$_]
- * 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.
---------------------------------------------------------------------}
-import Word
-infixl 9 \\
-
-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
-
-#else
-{--------------------------------------------------------------------
- 'Standard' Haskell
- * A "Nat" is a natural machine word (an unsigned Int)
---------------------------------------------------------------------}
-import Word
-infixl 9 \\
-
-type Nat = Word
-
-natFromInt :: Key -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Key
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Key -> Nat
-shiftRL w i = shiftR w i
-
-#endif
-
-
-{--------------------------------------------------------------------
- Operators
---------------------------------------------------------------------}
-
--- | /O(min(n,W))/. See 'find'.
-(!) :: IntMap a -> Key -> a
-m ! k = find k m
-
--- | /O(n+m)/. See 'difference'.
-(\\) :: IntMap a -> IntMap a -> IntMap a
-m1 \\ m2 = difference m1 m2
-
-{--------------------------------------------------------------------
- Types [_$_]
---------------------------------------------------------------------}
--- | A map of integers to values @a@.
-data IntMap a = Nil
- | Tip !Key a
- | Bin !Prefix !Mask !(IntMap a) !(IntMap a) [_$_]
-
-type Prefix = Int
-type Mask = Int
-type Key = Int
-
-{--------------------------------------------------------------------
- Query
---------------------------------------------------------------------}
--- | /O(1)/. Is the map empty?
-isEmpty :: IntMap a -> Bool
-isEmpty Nil = True
-isEmpty other = False
-
--- | /O(n)/. Number of elements in the map.
-size :: IntMap a -> Int
-size t
- = case t of
- Bin p m l r -> size l + size r
- Tip k x -> 1
- Nil -> 0
-
--- | /O(min(n,W))/. Is the key a member of the map?
-member :: Key -> IntMap a -> Bool
-member k m
- = case lookup k m of
- Nothing -> False
- Just x -> True
- [_$_]
--- | /O(min(n,W))/. Lookup the value of a key in the map.
-lookup :: Key -> IntMap a -> Maybe a
-lookup k t
- = case t of
- Bin p m l r [_$_]
- | nomatch k p m -> Nothing
- | zero k m -> lookup k l
- | otherwise -> lookup k r
- Tip kx x [_$_]
- | (k==kx) -> Just x
- | otherwise -> Nothing
- Nil -> 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
-find k m
- = case lookup k m of
- Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")
- Just x -> x
-
--- | /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
- Nothing -> def
- Just x -> x
-
-{--------------------------------------------------------------------
- Construction
---------------------------------------------------------------------}
--- | /O(1)/. The empty map.
-empty :: IntMap a
-empty
- = Nil
-
--- | /O(1)/. A map of one element.
-single :: Key -> a -> IntMap a
-single k x
- = Tip k x
-
-{--------------------------------------------------------------------
- Insert
- '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
-insert k x t
- = case t of
- Bin p m l r [_$_]
- | 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)
- Tip ky y [_$_]
- | k==ky -> Tip k x
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
--- 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
-insertWith f k x t
- = 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
- = case t of
- Bin p m l r [_$_]
- | 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)
- Tip ky y [_$_]
- | k==ky -> Tip k (f k x y)
- | otherwise -> join k (Tip k x) ky t
- Nil -> Tip k x
-
-
--- | /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
- = case t of
- Bin p m l r [_$_]
- | 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')
- Tip ky y [_$_]
- | k==ky -> (Just y,Tip k (f k x y))
- | otherwise -> (Nothing,join k (Tip k x) ky t)
- Nil -> (Nothing,Tip k x)
-
-
-{--------------------------------------------------------------------
- Deletion
- [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
-delete k t
- = case t of
- Bin p m l r [_$_]
- | nomatch k p m -> t
- | zero k m -> bin p m (delete k l) r
- | otherwise -> bin p m l (delete k r)
- Tip ky y [_$_]
- | k==ky -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /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
-adjust f k m
- = 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
-update f k m
- = 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
- = case t of
- Bin p m l r [_$_]
- | 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)
- Tip ky y [_$_]
- | k==ky -> case (f k y) of
- Just y' -> Tip ky y'
- Nothing -> Nil
- | otherwise -> t
- Nil -> Nil
-
--- | /O(min(n,W))/. Lookup and update.
-updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)
-updateLookupWithKey f k t
- = case t of
- Bin p m l r [_$_]
- | 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')
- Tip ky y [_$_]
- | k==ky -> case (f k y) of
- Just y' -> (Just y,Tip ky y')
- Nothing -> (Just y,Nil)
- | otherwise -> (Nothing,t)
- Nil -> (Nothing,Nil)
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
--- | The union of a list of maps.
-unions :: [IntMap a] -> IntMap a
-unions xs
- = 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
- where
- 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
-union Nil t = t
-union t Nil = t
-
--- | /O(n+m)/. The union with a combining function. [_$_]
-unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
-unionWith f m1 m2
- = 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
- where
- 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
-
-{--------------------------------------------------------------------
- Difference
---------------------------------------------------------------------}
--- | /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)
- | otherwise = t1
- where
- 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
- | otherwise = t1
-
-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)
- | otherwise = t1
- where
- 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'
- Nothing -> Nil
- Nothing -> t1
-
-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
-
-
-{--------------------------------------------------------------------
- Intersection
---------------------------------------------------------------------}
--- | /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)
- | otherwise = Nil
- where
- 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
- | otherwise = Nil
-intersection t (Tip k x) [_$_]
- = case lookup k t of
- Just y -> Tip k y
- Nothing -> Nil
-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)
- | otherwise = Nil
- where
- 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)
- Nothing -> Nil
-intersectionWithKey f t1 (Tip k y) [_$_]
- = case lookup k t1 of
- Just x -> Tip k (f k x y)
- Nothing -> Nil
-intersectionWithKey f Nil t = Nil
-intersectionWithKey f t Nil = Nil
-
-
-{--------------------------------------------------------------------
- Subset
---------------------------------------------------------------------}
--- | /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
-properSubset m1 m2
- = 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 [_$_]
- LT -> True
- ge -> False
-
-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
- where
- 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
- (GT,_ ) -> GT
- (_ ,GT) -> GT
- (EQ,EQ) -> EQ
- other -> LT
-
-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
-subset m1 m2
- = 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
-
-{--------------------------------------------------------------------
- Mapping
---------------------------------------------------------------------}
--- | /O(n)/. Map a function over all values in the map.
-map :: (a -> b) -> IntMap a -> IntMap b
-map f m
- = 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 [_$_]
- = case t of
- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)
- Tip k x -> Tip k (f k x)
- Nil -> Nil
-
--- | /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)
-mapAccum f a m
- = 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
- = mapAccumL 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)
-mapAccumL f a t
- = case t of
- 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')
- Nil -> (a,Nil)
-
-
--- | /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)
-mapAccumR f a t
- = case t of
- 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')
- Nil -> (a,Nil)
-
-{--------------------------------------------------------------------
- Filter
---------------------------------------------------------------------}
--- | /O(n)/. Filter all values that satisfy some predicate.
-filter :: (a -> Bool) -> IntMap a -> IntMap a
-filter p m
- = 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
- = case t of
- Bin p m l r [_$_]
- -> bin p m (filterWithKey pred l) (filterWithKey pred r)
- Tip k x [_$_]
- | pred k x -> t
- | otherwise -> Nil
- Nil -> 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)
-partition p m
- = 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
- = case t of
- Bin p m l r [_$_]
- -> let (l1,l2) = partitionWithKey pred l
- (r1,r2) = partitionWithKey pred r
- in (bin p m l1 r1, bin p m l2 r2)
- Tip k x [_$_]
- | pred k x -> (t,Nil)
- | otherwise -> (Nil,t)
- Nil -> (Nil,Nil)
-
-
--- | /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)
-split k t
- = case t of
- Bin p m l r
- | 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)
- Tip ky y [_$_]
- | k>ky -> (t,Nil)
- | k<ky -> (Nil,t)
- | otherwise -> (Nil,Nil)
- Nil -> (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)
-splitLookup k t
- = case t of
- Bin p m l r
- | 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)
- Tip ky y [_$_]
- | k>ky -> (Nothing,t,Nil)
- | k<ky -> (Nothing,Nil,t)
- | otherwise -> (Just y,Nil,Nil)
- Nil -> (Nothing,Nil,Nil)
-
-{--------------------------------------------------------------------
- Fold
---------------------------------------------------------------------}
--- | /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
-fold f z t
- = 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
-foldWithKey f z t
- = foldR f z t
-
-foldR :: (Key -> a -> b -> b) -> b -> IntMap a -> b
-foldR f z t
- = case t of
- Bin p m l r -> foldR f (foldR f z r) l
- Tip k x -> f k x z
- Nil -> z
-
-{--------------------------------------------------------------------
- List variations [_$_]
---------------------------------------------------------------------}
--- | /O(n)/. Return all elements of the map.
-elems :: IntMap a -> [a]
-elems m
- = foldWithKey (\k x xs -> x:xs) [] m [_$_]
-
--- | /O(n)/. Return all keys of the map.
-keys :: IntMap a -> [Key]
-keys m
- = foldWithKey (\k x ks -> k:ks) [] m
-
--- | /O(n)/. Return all key\/value pairs in the map.
-assocs :: IntMap a -> [(Key,a)]
-assocs m
- = toList m
-
-
-{--------------------------------------------------------------------
- Lists [_$_]
---------------------------------------------------------------------}
--- | /O(n)/. Convert the map to a list of key\/value pairs.
-toList :: IntMap a -> [(Key,a)]
-toList t
- = 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)]
-toAscList t [_$_]
- = -- 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
-fromList xs
- = foldlStrict ins empty xs
- where
- 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 [_$_]
-fromListWith f xs
- = 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
- where
- 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
-fromAscList xs
- = fromList 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.
-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
- = fromList xs
-
-
-{--------------------------------------------------------------------
- Eq [_$_]
---------------------------------------------------------------------}
-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
-showMap [] [_$_]
- = showString "{}" [_$_]
-showMap (x:xs) [_$_]
- = showChar '{' . showElem x . showTail xs
- where
- showTail [] = showChar '}'
- showTail (x:xs) = showChar ',' . showElem x . showTail xs
- [_$_]
- showElem (k,x) = shows k . showString ":=" . shows x
- [_$_]
-{--------------------------------------------------------------------
- Debugging
---------------------------------------------------------------------}
--- | /O(n)/. Show the tree that implements the map. The tree is shown
--- in a compressed, hanging format.
-showTree :: Show a => IntMap a -> String
-showTree s
- = 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
- = case t of
- Bin p m l r
- -> 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
- Tip k x
- -> 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
- = case t of
- Bin p m l r
- -> showsBars bars . showString (showBin p m) . showString "\n" . [_$_]
- showWide wide bars .
- showsTreeHang wide (withBar bars) l .
- showWide wide bars .
- showsTreeHang wide (withEmpty bars) r
- Tip k x
- -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n" [_$_]
- Nil -> showsBars bars . showString "|\n" [_$_]
- [_$_]
-showBin p m
- = "*" -- ++ show (p,m)
-
-showWide wide bars [_$_]
- | wide = showString (concat (reverse bars)) . showString "|\n" [_$_]
- | otherwise = id
-
-showsBars :: [String] -> ShowS
-showsBars bars
- = case bars of
- [] -> id
- _ -> showString (concat (reverse (tail bars))) . showString node
-
-node = "+--"
-withBar bars = "| ":bars
-withEmpty bars = " ":bars
-
-
-{--------------------------------------------------------------------
- Helpers
---------------------------------------------------------------------}
-{--------------------------------------------------------------------
- Join
---------------------------------------------------------------------}
-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a
-join p1 t1 p2 t2
- | zero p1 m = Bin p m t1 t2
- | otherwise = Bin p m t2 t1
- where
- m = branchMask p1 p2
- p = mask p1 m
-
-{--------------------------------------------------------------------
- @bin@ assures that we never have empty trees within a tree.
---------------------------------------------------------------------}
-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a
-bin p m l Nil = l
-bin p m Nil r = r
-bin p m l r = Bin p m l r
-
- [_$_]
-{--------------------------------------------------------------------
- Endian independent bit twiddling
---------------------------------------------------------------------}
-zero :: Key -> Mask -> Bool
-zero i m
- = (natFromInt i) .&. (natFromInt m) == 0
-
-nomatch,match :: Key -> Prefix -> Mask -> Bool
-nomatch i p m
- = (mask i m) /= p
-
-match i p m
- = (mask i m) == p
-
-mask :: Key -> Mask -> Prefix
-mask i m
- = maskW (natFromInt i) (natFromInt m)
-
-
-{--------------------------------------------------------------------
- Big endian operations [_$_]
---------------------------------------------------------------------}
-maskW :: Nat -> Nat -> Prefix
-maskW i m
- = intFromNat (i .&. (complement (m-1) `xor` m))
-
-shorter :: Mask -> Mask -> Bool
-shorter m1 m2
- = (natFromInt m1) > (natFromInt m2)
-
-branchMask :: Prefix -> Prefix -> Mask
-branchMask p1 p2
- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))
- [_$_]
-{----------------------------------------------------------------------
- Finding the highest bit (mask) in a word [x] can be done efficiently in
- three ways:
- * 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 [_$_]
- numbers.
- * 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
- --------------
- frexp 200
- float 33
- bit 11
- asm 12
-
- highestBit: method cycles
- --------------
- frexp 195
- float 33
- bit 11
- asm 11
-
- 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
-highestBitMask x
- = 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))
-
-
-{--------------------------------------------------------------------
- Utilities [_$_]
---------------------------------------------------------------------}
-foldlStrict f z xs
- = case xs of
- [] -> z
- (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
-
-{-
-{--------------------------------------------------------------------
- Testing
---------------------------------------------------------------------}
-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]
-
-{--------------------------------------------------------------------
- QuickCheck
---------------------------------------------------------------------}
-qcheck prop
- = check config prop
- where
- config = Config
- { 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
-prop_Single k x
- = (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
-
-
-{--------------------------------------------------------------------
- Union
---------------------------------------------------------------------}
-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
-prop_Diff xs ys
- = 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
-prop_Int xs ys
- = List.sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys))) [_$_]
- == List.sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))
-
-{--------------------------------------------------------------------
- Lists
---------------------------------------------------------------------}
-prop_Ordered
- = forAll (choose (5,100)) $ \n ->
- let xs = [(x,()) | x <- [0..n::Int]] [_$_]
- in fromAscList xs == fromList xs
-
-prop_List :: [Key] -> Bool
-prop_List xs
- = (sort (nub xs) == [x | (x,()) <- toAscList (fromList [(x,()) | x <- xs])])
--}
rmfile ./lib/DData/IntMap.hs
rmdir ./lib/DData
rmdir ./lib
hunk ./INblobs.cabal 16
+Category: Compilers/Interpreters
+
+Build-type: Simple
hunk ./INblobs.cabal 31
- Hs-Source-Dirs: src lib/DData
- Ghc-Options: -O2
+ Hs-Source-Dirs: src
hunk ./Makefile 45
-DDATA = lib/DData/IntMap.hs
hunk ./Makefile 46
-SRCS = $(INBLOBS) $(DDATA)
+SRCS = $(INBLOBS)
hunk ./Makefile 48
-IFACES = src:lib/DData:src/Functional
+IFACES = src:src/Functional
hunk ./Makefile 75
- ghc -cpp -E -optP-P -D__HADDOCK__ lib/DData/IntMap.hs -o lib/DData/IntMap.hspp
hunk ./Makefile 80
- lib/DData/IntMap.hspp \
hunk ./Makefile 89
- $(RM) lib/DData/*.o
- $(RM) lib/DData/*.hi
+ $(RM) src/Functional/*.o
+ $(RM) src/Functional/*.hi
hunk ./Makefile 126
-lib/DData/IntMap.o : lib/DData/IntMap.hs
hunk ./Makefile 136
-src/Common.o : lib/DData/IntMap.hi
hunk ./Makefile 163
-src/Network.o : lib/DData/IntMap.hi
hunk ./Makefile 185
-src/INRule.o : lib/DData/IntMap.hi
hunk ./Makefile 204
-src/NetworkView.o : lib/DData/IntMap.hi
hunk ./Makefile 235
-src/INTextual.o : lib/DData/IntMap.hi
hunk ./Makefile 273
-src/Operations.o : lib/DData/IntMap.hi
hunk ./Makefile 411
-src/Main.o : lib/DData/IntMap.hi
-src/Main.o : lib/DData/IntMap.hi
hunk ./src/Common.hs 5
-import qualified IntMap
-import Char(isSpace)
+import qualified Data.IntMap as IntMap
+import Data.Char(isSpace)
hunk ./src/Common.hs 8
-import List
+import Data.List
hunk ./src/CommonIO.hs 9
-import List(elemIndex)
+import Data.List(elemIndex)
hunk ./src/DisplayOptions.hs 3
-import List ((\\))
+import Data.List ((\\))
hunk ./src/GUIEvents.hs 3
-import List (nub,(\\))
+import Data.List (nub,(\\))
hunk ./src/INRule.hs 34
-import IntMap (empty)
+import qualified Data.IntMap as IntMap (empty)
hunk ./src/INTextual.hs 20
-import qualified IntMap as IM
+import qualified Data.IntMap as IM
hunk ./src/Main.hs 11
-import IntMap (IntMap)
-import qualified IntMap
-import List (nub)
-import Maybe (fromJust, fromMaybe)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.List (nub)
+import Data.Maybe (fromJust, fromMaybe)
hunk ./src/Network.hs 70
-import IntMap hiding (map)
-import qualified Data.List
+import Data.IntMap as IntMap hiding (map)
+import qualified Data.List as List
hunk ./src/Network.hs 275
-getUnusedNodeNr network | null used = 1
+getUnusedNodeNr network | List.null used = 1
hunk ./src/Network.hs 282
-getUnusedEdgeNr network | null used = 1
+getUnusedEdgeNr network | List.null used = 1
hunk ./src/Network.hs 395
-isEmpty = IntMap.isEmpty . networkNodes [_$_]
+isEmpty = IntMap.null . networkNodes
hunk ./src/NetworkControl.hs 40
-import Char (isSpace)
+import Data.Char (isSpace)
hunk ./src/NetworkFile.hs 22
-import Char
-import Maybe
+import Data.Char
+import Data.Maybe
hunk ./src/NetworkFile.hs 25
-import List(nub,isPrefixOf)
+import Data.List(nub,isPrefixOf)
hunk ./src/NetworkView.hs 22
-import Maybe
+import Data.Maybe
hunk ./src/NetworkView.hs 29
-import qualified IntMap
+import qualified Data.IntMap as IntMap
hunk ./src/Operations.hs 8
-import IntMap
+import Data.IntMap
hunk ./src/Palette.hs 3
-import List (nub, (\\), deleteBy)
+import Data.List (nub, (\\), deleteBy)
hunk ./src/StateUtil.hs 10
-import Maybe
+import Data.Maybe
}
Tue Jun 17 10:39:56 WEST 2008 Miguel Vilaca <jmvilaca@di.uminho.pt>
* Remove unnecessary module
{
hunk ./Makefile 30
- src/XTC.hs \
hunk ./Makefile 96
+ifdef MAC
+ $(RM) -rf $(MAIN).app
+ $(RM) -rf $(MAIN)
+endif
+
+cabalClean:
+ $(RM) -rf dist
+
hunk ./Makefile 132
-src/XTC.o : src/XTC.hs
hunk ./src/XTC.hs 1
---------------------------------------------------------------------------------
-{-| [_$_]
- Module : XTC
- 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 )
- -- * Controls
- -- ** Radio view
- , RadioView, mkRadioView, mkRadioViewEx
- -- ** Single-selection list view
- , ListView, mkListView, mkListViewEx
- -- ** Multiple-selection list view
- , MultiListView, mkMultiListView, mkMultiListViewEx
- -- ** Choice view
- , ChoiceView, mkChoiceView, mkChoiceViewEx
- -- ** Value entry
- , ValueEntry, mkValueEntry, mkValueEntryEx
- ) where
-
-import Graphics.UI.WX hiding (window, label)
-import qualified Graphics.UI.WX
-import Graphics.UI.WXCore hiding (label, Event)
-import List
-import Maybe
-
--- | 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
- toLabel str = str
-
--- | 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)
-
-
-{--------------------------------------------------------------------------------
- Radio view
---------------------------------------------------------------------------------}
-
-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
- typedSelection
- = 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
- ; case mSel of
- Just item -> return item
- Nothing -> internalError "XTC" "radioViewGetTypedSelection" "Radio view has empty selection"
- }
- [_$_]
-{--------------------------------------------------------------------------------
- Single-selection list view
---------------------------------------------------------------------------------}
-
-data CListView a b
-
--- | 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
--- label.
--- 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)
- selectedIndices)
- }
-
-
-{--------------------------------------------------------------------------------
- Choice view
---------------------------------------------------------------------------------}
-
-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
--- 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'.
---
-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)] ->
- IO (WxObject b)
-mkViewEx mkView window present props =
- do { model <- varCreate []
- ; view <- fmap objectCast $ mkView window []
- ; objectSetClientData view (return ()) (model, present)
- ; set view props
- ; return view
- }
-
--- 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
- Nothing -> -1
- 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
- Just ix -> ix
- Nothing -> -1
- [_$_]
--- 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 ]
- }
-
-
-{--------------------------------------------------------------------------------
- Value entry
---------------------------------------------------------------------------------}
-
-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
- typedValue
- = 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
- _ -> white
- ]
- ; 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
- ; case mValue of
- 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
- _ -> Nothing
-
-safeIndex :: String -> [a] -> Int -> a
-safeIndex msg xs i
- | 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)
-
-
-
-
-
-
-
-xtc :: IO ()
-xtc = start $
- do { -- counterV <- mkObservableVar 1
- ; f <- frame []
-
--- ; listV <- singleListBox f [items := ["hallo"]]
- ; listV <- mkListView f [ typedItems := ["sdfsdf", "fdssd"]
- , enabled := True
- ]
-
- ; radioV <- mkRadioView f Vertical [ "Een", "Twee" ] []
- ; choiceV <- mkChoiceView f [ typedItems := ["sdfsdf", "fdssd"]
- , enabled := True
- ]
- -- ; 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
- ; print (s1)
- ; s2 <- get listV typedMaybeSelection
- ; print (s2)
- } ] -- 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 ]
- , widget bUp
- -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ]
- -- , hfloatCenter $ widget bChangeHandler
- , widget listV
- -- , widget choiceV
- -- , widget comboV
- -- , widget ve
- ]
- ]
-
- }
rmfile ./src/XTC.hs
}