Tue Jul 26 11:33:03 WEST 2005 Malcolm.Wallace@cs.york.ac.uk
* initial import
The original "Blobs" source code, supplied by Arjan van IJzendoorn.
Trimmed down from the Universiteit Utrecht application for Bayesian
networks, "Dazzle".
http://www.cs.uu.nl/dazzle/
{
adddir ./lib
adddir ./lib/DData
adddir ./src
addfile ./Blobs.zip
binary ./Blobs.zip
addfile ./Makefile
hunk ./Makefile 1
+# Tools and options
+STRIP = strip
+HC = ghc
+MAIN = blobs
+EXE = .exe
+HC_OPTS = -package HaXml -package wx -package lang -fglasgow-exts -i$(IFACES) -Wall -static $(EXTRA_OPTS)
+# -optl-mwindows
+# voor GHC 6.4: -ignore-package network-1.0
+
+.SUFFIXES : .o .hs .hi .lhs .hc .s .ag
+
+# Sources
+BLOBS = src/Main.hs src/State.hs src/StateUtil.hs src/Math.hs src/GUIEvents.hs \
+ src/Common.hs src/CommonIO.hs \
+ src/Network.hs src/Node.hs src/NetworkFile.hs \
+ src/Colors.hs src/Constants.hs src/SafetyNet.hs \
+ src/Document.hs \
+ src/NetworkUI.hs src/NetworkView.hs src/NetworkControl.hs \
+ src/ContextMenu.hs \
+ src/PersistentDocument.hs src/PDDefaults.hs \
+ src/XTC.hs \
+
+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
+
+SRCS = $(BLOBS) $(DDATA)
+OBJS = $(SRCS:.hs=.o) [_$_]
+IFACES = src:lib/DData
+
+# Main target
+blobs: $(OBJS)
+ $(HC) -o $(MAIN)$(EXE) $(HC_OPTS) $(OBJS)
+ifdef STRIP
+ $(STRIP) $(MAIN)$(EXE)
+endif
+
+# Documentation target (use Haddock 0.5 in combination with GHC 6.0.1)[_^I_][_$_]
+doc:
+ haddock +RTS -K4M -RTS \
+ -h -o docs/haddock \
+ --lib C:\cygwin\home\administrator\haddock-0.5\haddock\html \
+ $(BLOBS)
+
+# Clean target
+clean:
+ $(RM) src/*.o
+ $(RM) src/*.hi
+ $(RM) lib/DData/*.o
+ $(RM) lib/DData/*.hi
+ $(RM) $(MAIN)$(EXE)
+
+# Inter-module dependencies
+depend :
+ # Checking dependencies
+ $(HC) -M $(HC_OPTS) $(SRCS)
+
+# Standard suffix rules
+.o.hi:
+ @:
+
+.lhs.o:
+ $(HC) -c $< $(HC_OPTS)
+
+.hs.o:
+ $(HC) -c $< $(HC_OPTS)
+
+.hs.hi:
+ $(HC) -c $< $(HC_OPTS) [_$_]
+
+.lhs.hi:
+ $(HC) -c $< $(HC_OPTS)
+
+.ag.hs:
+ $(AG) -a $<
+
+# DO NOT DELETE: Beginning of Haskell dependencies
+src/Main.o : src/Main.hs
+src/Main.o : src/State.hi
+src/Main.o : src/NetworkUI.hi
+src/State.o : src/State.hs
+src/State.o : src/PersistentDocument.hi
+src/State.o : src/Math.hi
+src/State.o : src/Document.hi
+src/StateUtil.o : src/StateUtil.hs
+src/StateUtil.o : src/PersistentDocument.hi
+src/StateUtil.o : src/Common.hi
+src/StateUtil.o : src/State.hi
+src/Math.o : src/Math.hs
+src/GUIEvents.o : src/GUIEvents.hs
+src/GUIEvents.o : src/PersistentDocument.hi
+src/GUIEvents.o : src/ContextMenu.hi
+src/GUIEvents.o : src/Document.hi
+src/GUIEvents.o : src/CommonIO.hi
+src/GUIEvents.o : src/Common.hi
+src/GUIEvents.o : src/State.hi
+src/GUIEvents.o : src/NetworkControl.hi
+src/GUIEvents.o : src/NetworkView.hi
+src/Common.o : src/Common.hs
+src/Common.o : lib/DData/IntMap.hi
+src/Common.o : src/Colors.hi
+src/CommonIO.o : src/CommonIO.hs
+src/CommonIO.o : src/SafetyNet.hi
+src/CommonIO.o : src/Common.hi
+src/CommonIO.o : src/Math.hi
+src/Network.o : src/Network.hs
+src/Network.o : lib/DData/IntMap.hi
+src/Network.o : src/Node.hi
+src/Network.o : src/Math.hi
+src/Network.o : src/Common.hi
+src/Node.o : src/Node.hs
+src/Node.o : src/Math.hi
+src/NetworkFile.o : src/NetworkFile.hs
+src/NetworkFile.o : src/Common.hi
+src/NetworkFile.o : src/Math.hi
+src/NetworkFile.o : src/Node.hi
+src/NetworkFile.o : src/Network.hi
+src/Colors.o : src/Colors.hs
+src/Constants.o : src/Constants.hs
+src/SafetyNet.o : src/SafetyNet.hs
+src/Document.o : src/Document.hs
+src/Document.o : src/Network.hi
+src/NetworkUI.o : src/NetworkUI.hs
+src/NetworkUI.o : src/PDDefaults.hi
+src/NetworkUI.o : src/PersistentDocument.hi
+src/NetworkUI.o : src/CommonIO.hi
+src/NetworkUI.o : src/Common.hi
+src/NetworkUI.o : src/Document.hi
+src/NetworkUI.o : src/NetworkFile.hi
+src/NetworkUI.o : src/NetworkView.hi
+src/NetworkUI.o : src/Network.hi
+src/NetworkUI.o : src/StateUtil.hi
+src/NetworkUI.o : src/State.hi
+src/NetworkUI.o : src/SafetyNet.hi
+src/NetworkUI.o : src/GUIEvents.hi
+src/NetworkView.o : src/NetworkView.hs
+src/NetworkView.o : src/Math.hi
+src/NetworkView.o : src/Common.hi
+src/NetworkView.o : src/Colors.hi
+src/NetworkView.o : src/Document.hi
+src/NetworkView.o : src/Network.hi
+src/NetworkView.o : src/Node.hi
+src/NetworkView.o : src/CommonIO.hi
+src/NetworkView.o : src/Constants.hi
+src/NetworkControl.o : src/NetworkControl.hs
+src/NetworkControl.o : src/PersistentDocument.hi
+src/NetworkControl.o : src/Math.hi
+src/NetworkControl.o : src/CommonIO.hi
+src/NetworkControl.o : src/Common.hi
+src/NetworkControl.o : src/Document.hi
+src/NetworkControl.o : src/Node.hi
+src/NetworkControl.o : src/Network.hi
+src/NetworkControl.o : src/StateUtil.hi
+src/NetworkControl.o : src/State.hi
+src/ContextMenu.o : src/ContextMenu.hs
+src/ContextMenu.o : src/PersistentDocument.hi
+src/ContextMenu.o : src/CommonIO.hi
+src/ContextMenu.o : src/SafetyNet.hi
+src/ContextMenu.o : src/NetworkControl.hi
+src/ContextMenu.o : src/Document.hi
+src/ContextMenu.o : src/Node.hi
+src/ContextMenu.o : src/Network.hi
+src/ContextMenu.o : src/State.hi
+src/PersistentDocument.o : src/PersistentDocument.hs
+src/PDDefaults.o : src/PDDefaults.hs
+src/XTC.o : src/XTC.hs
+lib/DData/IntBag.o : lib/DData/IntBag.hs
+lib/DData/IntBag.o : lib/DData/IntMap.hi
+lib/DData/IntMap.o : lib/DData/IntMap.hs
+lib/DData/IntSet.o : lib/DData/IntSet.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/Queue.o : lib/DData/Queue.hs
+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/Seq.o : lib/DData/Seq.hs
+lib/DData/Set.o : lib/DData/Set.hs
+# DO NOT DELETE: End of Haskell dependencies
addfile ./lib/DData/IntBag.hs
hunk ./lib/DData/IntBag.hs 1
+--------------------------------------------------------------------------------
+{-| 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 ( [_$_]
+ -- * Bag type
+ IntBag -- instance Eq,Show
+ [_$_]
+ -- * Operators
+ , (\\)
+
+ -- *Query
+ , isEmpty
+ , size
+ , distinctSize
+ , member
+ , occur
+
+ , subset
+ , properSubset
+ [_$_]
+ -- * Construction
+ , empty
+ , single
+ , insert
+ , insertMany
+ , delete
+ , deleteAll
+ [_$_]
+ -- * Combine
+ , union
+ , difference
+ , intersection
+ , unions
+ [_$_]
+ -- * Filter
+ , filter
+ , partition
+
+ -- * Fold
+ , fold
+ , foldOccur
+ [_$_]
+ -- * Conversion
+ , elems
+
+ -- ** List
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- ** Occurrence lists
+ , toOccurList
+ , toAscOccurList
+ , fromOccurList
+ , fromAscOccurList
+
+ -- ** IntMap
+ , toMap
+ , fromMap
+ , fromOccurMap
+ [_$_]
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ ) where
+
+import Prelude hiding (map,filter)
+import qualified Prelude (map,filter)
+
+import qualified IntMap as M
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 \\
+
+-- | /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)
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the bag empty?
+isEmpty :: IntBag -> Bool
+isEmpty (IntBag m) [_$_]
+ = M.isEmpty 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) [_$_]
+ = M.size m
+
+-- | /O(n)/. The number of elements in the bag.
+size :: IntBag -> Int
+size b
+ = foldOccur (\x n m -> n+m) 0 b
+
+-- | /O(min(n,W))/. Is the element in the bag?
+member :: Int -> IntBag -> Bool
+member x m
+ = (occur x m > 0)
+
+-- | /O(min(n,W))/. The number of occurrences of an element in the bag.
+occur :: Int -> IntBag -> Int
+occur x (IntBag m)
+ = case M.lookup x m of
+ Nothing -> 0
+ Just n -> n
+
+-- | /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
+properSubset b1 b2
+ = subset b1 b2 && (b1 /= b2)
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. Create an empty bag.
+empty :: IntBag
+empty
+ = IntBag (M.empty)
+
+-- | /O(1)/. Create a singleton bag.
+single :: Int -> IntBag
+single x [_$_]
+ = 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)
+ where
+ 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)
+
+{--------------------------------------------------------------------
+ Combine
+--------------------------------------------------------------------}
+-- | /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])
+-- > {1,2}
+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])
+-- > {1}
+difference :: IntBag -> IntBag -> IntBag
+difference (IntBag t1) (IntBag t2)
+ = IntBag (M.differenceWithKey f t1 t2)
+ where
+ f x n m | n-m > 0 = Just (n-m)
+ | otherwise = Nothing
+
+-- | The union of a list of bags.
+unions :: [IntBag] -> IntBag
+unions bags
+ = 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)
+ where
+ (l,r) = M.partitionWithKey (\x n -> p x) m
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /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
+ where
+ apply x n z | n > 0 = apply x (n-1) (f x z)
+ | otherwise = 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]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Create a list with all elements.
+toList :: IntBag -> [Int]
+toList s
+ = toAscList s
+
+-- | /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 [_$_]
+fromList xs
+ = IntBag (M.fromListWith (+) [(x,1) | x <- xs])
+
+-- | /O(n*min(n,W))/. Create a bag from an ascending list.
+fromAscList :: [Int] -> IntBag [_$_]
+fromAscList xs
+ = 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)]
+toOccurList b
+ = toAscOccurList b
+
+-- | /O(n)/. Create an ascending list of element\/occurrence pairs.
+toAscOccurList :: IntBag -> [(Int,Int)]
+toAscOccurList (IntBag m)
+ = M.toAscList m
+
+-- | /O(n*min(n,W))/. Create a bag from a list of element\/occurrence pairs.
+fromOccurList :: [(Int,Int)] -> IntBag
+fromOccurList xs
+ = 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))
+
+{--------------------------------------------------------------------
+ Maps
+--------------------------------------------------------------------}
+-- | /O(1)/. Convert to an 'IntMap.IntMap' from elements to number of occurrences.
+toMap :: IntBag -> M.IntMap Int
+toMap (IntBag m)
+ = m
+
+-- | /O(n)/. Convert a 'IntMap.IntMap' from elements to occurrences into a bag.
+fromMap :: M.IntMap Int -> IntBag
+fromMap m
+ = 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
+fromOccurMap m
+ = IntBag m
+
+{--------------------------------------------------------------------
+ Eq, Ord
+--------------------------------------------------------------------}
+instance Eq (IntBag) where
+ (IntBag m1) == (IntBag m2) = (m1==m2) [_$_]
+ (IntBag m1) /= (IntBag m2) = (m1/=m2)
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show (IntBag) where
+ showsPrec d b = showSet (toAscList b)
+
+showSet :: Show a => [a] -> ShowS
+showSet [] [_$_]
+ = showString "{}" [_$_]
+showSet (x:xs) [_$_]
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+ [_$_]
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree structure that implements the 'IntBag'. The tree
+-- is shown as a compressed and /hanging/.
+showTree :: IntBag -> String
+showTree bag
+ = 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
+-- is shown.
+showTreeWith :: Bool -> Bool -> IntBag -> String
+showTreeWith hang wide (IntBag m)
+ = M.showTreeWith hang wide m
+
addfile ./lib/DData/IntMap.hs
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 \\
+
+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])])
+-}
addfile ./lib/DData/IntSet.hs
hunk ./lib/DData/IntSet.hs 1
-
+{-# 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)
+ > import IntSet
+
+ 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").
+ [_$_]
+ * 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 IntSet ( [_$_]
+ -- * Set type
+ IntSet -- instance Eq,Show
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , isEmpty
+ , size
+ , member
+ , subset
+ , properSubset
+ [_$_]
+ -- * Construction
+ , empty
+ , single
+ , insert
+ , delete
+ [_$_]
+ -- * Combine
+ , union, unions
+ , difference
+ , intersection
+ [_$_]
+ -- * Filter
+ , filter
+ , partition
+ , split
+ , splitMember
+
+ -- * Fold
+ , fold
+
+ -- * Conversion
+ -- ** List
+ , elems
+ , toList
+ , fromList
+ [_$_]
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+ [_$_]
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ ) where
+
+
+import Prelude hiding (lookup,filter)
+import Bits [_$_]
+import Int
+
+{-
+-- just for testing
+import 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 \\
+
+type Nat = Word
+
+natFromInt :: Int -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Int
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Int -> 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 :: Int -> Nat
+natFromInt i = fromInt i
+
+intFromNat :: Nat -> Int
+intFromNat w = toInt w
+
+shiftRL :: Nat -> Int -> 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 :: Int -> Nat
+natFromInt i = fromIntegral i
+
+intFromNat :: Nat -> Int
+intFromNat w = fromIntegral w
+
+shiftRL :: Nat -> Int -> Nat
+shiftRL w i = shiftR w i
+
+#endif
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+-- | /O(n+m)/. See 'difference'.
+(\\) :: IntSet -> IntSet -> IntSet
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Types [_$_]
+--------------------------------------------------------------------}
+-- | A set of integers.
+data IntSet = Nil
+ | Tip !Int
+ | Bin !Prefix !Mask !IntSet !IntSet
+
+type Prefix = Int
+type Mask = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the set empty?
+isEmpty :: IntSet -> Bool
+isEmpty Nil = True
+isEmpty other = False
+
+-- | /O(n)/. Cardinality of the set.
+size :: IntSet -> Int
+size t
+ = case t of
+ Bin p m l r -> size l + size r
+ Tip y -> 1
+ Nil -> 0
+
+-- | /O(min(n,W))/. Is the value a member of the set?
+member :: Int -> IntSet -> Bool
+member x t
+ = case t of
+ Bin p m l r [_$_]
+ | nomatch x p m -> False
+ | zero x m -> member x l
+ | otherwise -> member x r
+ Tip y -> (x==y)
+ Nil -> False
+ [_$_]
+-- 'lookup' is used by 'intersection' for left-biasing
+lookup :: Int -> IntSet -> Maybe Int
+lookup x t
+ = case t of
+ Bin p m l r [_$_]
+ | nomatch x p m -> Nothing
+ | zero x m -> lookup x l
+ | otherwise -> lookup x r
+ Tip y [_$_]
+ | (x==y) -> Just y
+ | otherwise -> Nothing
+ Nil -> Nothing
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: IntSet
+empty
+ = Nil
+
+-- | /O(1)/. A set of one element.
+single :: Int -> IntSet
+single x
+ = Tip x
+
+{--------------------------------------------------------------------
+ Insert
+--------------------------------------------------------------------}
+-- | /O(min(n,W))/. Add a value to the set. When the value is already
+-- an element of the set, it is replaced by the new one, ie. 'insert'
+-- is left-biased.
+insert :: Int -> IntSet -> IntSet
+insert x t
+ = case t of
+ Bin p m l r [_$_]
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y [_$_]
+ | x==y -> Tip x
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
+
+-- right-biased insertion, used by 'union'
+insertR :: Int -> IntSet -> IntSet
+insertR x t
+ = case t of
+ Bin p m l r [_$_]
+ | nomatch x p m -> join x (Tip x) p t
+ | zero x m -> Bin p m (insert x l) r
+ | otherwise -> Bin p m l (insert x r)
+ Tip y [_$_]
+ | x==y -> t
+ | otherwise -> join x (Tip x) y t
+ Nil -> Tip x
+
+-- | /O(min(n,W))/. Delete a value in the set. Returns the
+-- original set when the value was not present.
+delete :: Int -> IntSet -> IntSet
+delete x t
+ = case t of
+ Bin p m l r [_$_]
+ | nomatch x p m -> t
+ | zero x m -> bin p m (delete x l) r
+ | otherwise -> bin p m l (delete x r)
+ Tip y [_$_]
+ | x==y -> Nil
+ | otherwise -> t
+ Nil -> Nil
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+-- | The union of a list of sets.
+unions :: [IntSet] -> IntSet
+unions xs
+ = foldlStrict union empty xs
+
+
+-- | /O(n+m)/. The union of two sets. [_$_]
+union :: IntSet -> IntSet -> IntSet
+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 x) t = insert x t
+union t (Tip x) = insertR x t -- right bias
+union Nil t = t
+union t Nil = t
+
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference between two sets. [_$_]
+difference :: IntSet -> IntSet -> IntSet
+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 x) t2 [_$_]
+ | member x t2 = Nil
+ | otherwise = t1
+
+difference Nil t = Nil
+difference t (Tip x) = delete x t
+difference t Nil = t
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. The intersection of two sets. [_$_]
+intersection :: IntSet -> IntSet -> IntSet
+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 x) t2 [_$_]
+ | member x t2 = t1
+ | otherwise = Nil
+intersection t (Tip x) [_$_]
+ = case lookup x t of
+ Just y -> Tip y
+ Nothing -> Nil
+intersection Nil t = Nil
+intersection t Nil = Nil
+
+
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+properSubset :: IntSet -> IntSet -> Bool
+properSubset t1 t2
+ = case subsetCmp t1 t2 of [_$_]
+ LT -> True
+ ge -> False
+
+subsetCmp 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 t1 l2
+ | otherwise = subsetCmp t1 r2
+ subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of
+ (GT,_ ) -> GT
+ (_ ,GT) -> GT
+ (EQ,EQ) -> EQ
+ other -> LT
+
+subsetCmp (Bin p m l r) t = GT
+subsetCmp (Tip x) (Tip y) [_$_]
+ | x==y = EQ
+ | otherwise = GT -- disjoint
+subsetCmp (Tip x) t [_$_]
+ | member x t = LT
+ | otherwise = GT -- disjoint
+subsetCmp Nil Nil = EQ
+subsetCmp Nil t = LT
+
+-- | /O(n+m)/. Is this a subset?
+subset :: IntSet -> IntSet -> Bool
+subset 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 subset t1 l2
+ else subset t1 r2) [_$_]
+ | otherwise = (p1==p2) && subset l1 l2 && subset r1 r2
+subset (Bin p m l r) t = False
+subset (Tip x) t = member x t
+subset Nil t = True
+
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy some predicate.
+filter :: (Int -> Bool) -> IntSet -> IntSet
+filter pred t
+ = case t of
+ Bin p m l r [_$_]
+ -> bin p m (filter pred l) (filter pred r)
+ Tip x [_$_]
+ | pred x -> t
+ | otherwise -> Nil
+ Nil -> Nil
+
+-- | /O(n)/. partition the set according to some predicate.
+partition :: (Int -> Bool) -> IntSet -> (IntSet,IntSet)
+partition pred t
+ = case t of
+ Bin p m l r [_$_]
+ -> let (l1,l2) = partition pred l
+ (r1,r2) = partition pred r
+ in (bin p m l1 r1, bin p m l2 r2)
+ Tip x [_$_]
+ | pred x -> (t,Nil)
+ | otherwise -> (Nil,t)
+ Nil -> (Nil,Nil)
+
+
+-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
+-- where all elements in @set1@ are lower than @x@ and all elements in
+-- @set2@ larger than @x@.
+split :: Int -> IntSet -> (IntSet,IntSet)
+split x t
+ = case t of
+ Bin p m l r
+ | zero x m -> let (lt,gt) = split x l in (lt,union gt r)
+ | otherwise -> let (lt,gt) = split x r in (union l lt,gt)
+ Tip y [_$_]
+ | x>y -> (t,Nil)
+ | x<y -> (Nil,t)
+ | otherwise -> (Nil,Nil)
+ Nil -> (Nil,Nil)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Int -> IntSet -> (Bool,IntSet,IntSet)
+splitMember x t
+ = case t of
+ Bin p m l r
+ | zero x m -> let (found,lt,gt) = splitMember x l in (found,lt,union gt r)
+ | otherwise -> let (found,lt,gt) = splitMember x r in (found,union l lt,gt)
+ Tip y [_$_]
+ | x>y -> (False,t,Nil)
+ | x<y -> (False,Nil,t)
+ | otherwise -> (True,Nil,Nil)
+ Nil -> (False,Nil,Nil)
+
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over the elements of a set in an unspecified order.
+--
+-- > sum set = fold (+) 0 set
+-- > elems set = fold (:) [] set
+fold :: (Int -> b -> b) -> b -> IntSet -> b
+fold f z t
+ = foldR f z t
+
+foldR :: (Int -> b -> b) -> b -> IntSet -> b
+foldR f z t
+ = case t of
+ Bin p m l r -> foldR f (foldR f z r) l
+ Tip x -> f x z
+ Nil -> z
+ [_$_]
+{--------------------------------------------------------------------
+ List variations [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. The elements of a set.
+elems :: IntSet -> [Int]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert the set to a list of elements.
+toList :: IntSet -> [Int]
+toList t
+ = fold (:) [] t
+
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toAscList :: IntSet -> [Int]
+toAscList t [_$_]
+ = -- NOTE: the following algorithm only works for big-endian trees
+ let (pos,neg) = span (>=0) (foldR (:) [] t) in neg ++ pos
+
+-- | /O(n*min(n,W))/. Create a set from a list of integers.
+fromList :: [Int] -> IntSet
+fromList xs
+ = foldlStrict ins empty xs
+ where
+ ins t x = insert x t
+
+-- | /O(n*min(n,W))/. Build a set from an ascending list of elements.
+fromAscList :: [Int] -> IntSet [_$_]
+fromAscList xs
+ = fromList xs
+
+-- | /O(n*min(n,W))/. Build a set from an ascending list of distinct elements.
+fromDistinctAscList :: [Int] -> IntSet
+fromDistinctAscList xs
+ = fromList xs
+
+
+{--------------------------------------------------------------------
+ Eq [_$_]
+--------------------------------------------------------------------}
+instance Eq IntSet where
+ t1 == t2 = equal t1 t2
+ t1 /= t2 = nequal t1 t2
+
+equal :: IntSet -> IntSet -> Bool
+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) [_$_]
+equal (Tip x) (Tip y)
+ = (x==y)
+equal Nil Nil = True
+equal t1 t2 = False
+
+nequal :: IntSet -> IntSet -> Bool
+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)
+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) [_$_]
+nequal (Tip x) (Tip y)
+ = (x/=y)
+nequal Nil Nil = False
+nequal t1 t2 = True
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show IntSet where
+ showsPrec d s = showSet (toList s)
+
+showSet :: [Int] -> ShowS
+showSet [] [_$_]
+ = showString "{}" [_$_]
+showSet (x:xs) [_$_]
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: IntSet -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. 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 :: Bool -> Bool -> IntSet -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Bool -> [String] -> [String] -> IntSet -> 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 x
+ -> showsBars lbars . showString " " . shows x . showString "\n" [_$_]
+ Nil -> showsBars lbars . showString "|\n"
+
+showsTreeHang :: Bool -> [String] -> IntSet -> 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 x
+ -> showsBars bars . 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 -> IntSet -> Prefix -> IntSet -> IntSet
+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 -> IntSet -> IntSet -> IntSet
+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 :: Int -> Mask -> Bool
+zero i m
+ = (natFromInt i) .&. (natFromInt m) == 0
+
+nomatch,match :: Int -> Prefix -> Mask -> Bool
+nomatch i p m
+ = (mask i m) /= p
+
+match i p m
+ = (mask i m) == p
+
+mask :: Int -> 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] -> IntSet
+testTree xs = fromList 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 IntSet where
+ arbitrary = do{ xs <- arbitrary
+ ; return (fromList xs)
+ }
+
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Bool
+prop_Single x
+ = (insert x empty == single x)
+
+prop_InsertDelete :: Int -> IntSet -> Property
+prop_InsertDelete k t
+ = not (member k t) ==> delete k (insert k t) == t
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionInsert :: Int -> IntSet -> Bool
+prop_UnionInsert x t
+ = union t (single x) == insert x t
+
+prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: IntSet -> IntSet -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == union t2 t1)
+
+prop_Diff :: [Int] -> [Int] -> Bool
+prop_Diff xs ys
+ = toAscList (difference (fromList xs) (fromList ys))
+ == List.sort ((List.\\) (nub xs) (nub ys))
+
+prop_Int :: [Int] -> [Int] -> Bool
+prop_Int xs ys
+ = toAscList (intersection (fromList xs) (fromList ys))
+ == List.sort (nub ((List.intersect) (xs) (ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [0..n::Int]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == toAscList (fromList xs))
+-}
addfile ./lib/DData/Map.hs
hunk ./lib/DData/Map.hs 1
-
+--------------------------------------------------------------------------------
+{-| Module : Map
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of maps from keys to values (dictionaries). [_$_]
+
+ 1) The module exports some names that clash with the "Prelude" -- 'lookup', 'map', and 'filter'. [_$_]
+ If you want to use "Map" unqualified, these functions should be hidden.
+
+ > import Prelude hiding (lookup,map,filter)
+ > import Map
+
+ Another solution is to use qualified names. This is also the only way how
+ a "Map", "Set", and "MultiSet" can be used within one module. [_$_]
+
+ > import qualified Map
+ >
+ > ... Map.single "Paris" "France"
+
+ Or, if you prefer a terse coding style:
+
+ > import qualified Map as M
+ >
+ > ... M.single "Berlin" "Germany"
+
+ 2) The implementation of "Map" is based on /size balanced/ binary trees (or
+ trees of /bounded balance/) as described by:
+
+ * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional
+ Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.
+
+ * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",
+ SIAM journal of computing 2(1), March 1973.
+ [_$_]
+ 3) Another implementation of finite maps based on size balanced trees
+ exists as "Data.FiniteMap" in the Ghc libraries. The good part about this library [_$_]
+ is that it is highly tuned and thorougly tested. However, it is also fairly old, [_$_]
+ uses @#ifdef@'s all over the place and only supports the basic finite map operations. [_$_]
+ The "Map" module overcomes some of these issues:
+ [_$_]
+ * It tries to export a more complete and consistent set of operations, like
+ 'partition', 'adjust', 'mapAccum', 'elemAt' etc. [_$_]
+ [_$_]
+ * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'
+ (a /hedge/ algorithm is not applicable to 'intersection').
+ [_$_]
+ * It converts ordered lists in linear time ('fromAscList'). [_$_]
+
+ * It takes advantage of the module system with names like 'empty' instead of 'Data.FiniteMap.emptyFM'.
+ [_$_]
+ * It sticks to portable Haskell, avoiding @#ifdef@'s and other magic.
+-}
+----------------------------------------------------------------------------------
+module Map ( [_$_]
+ -- * Map type
+ Map -- 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
+
+ -- * Indexed [_$_]
+ , lookupIndex
+ , findIndex
+ , elemAt
+ , updateAt
+ , deleteAt
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+ , updateMin
+ , updateMax
+ , updateMinWithKey
+ , updateMaxWithKey
+ [_$_]
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+ ) where
+
+import Prelude hiding (lookup,map,filter)
+
+
+{-
+-- for quick check
+import qualified Prelude
+import qualified List
+import Debug.QuickCheck [_$_]
+import List(nub,sort) [_$_]
+-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 !,\\
+
+-- | /O(log n)/. See 'find'.
+(!) :: Ord k => Map k a -> k -> a
+m ! k = find k m
+
+-- | /O(n+m)/. See 'difference'.
+(\\) :: Ord k => Map k a -> Map k a -> Map k a
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Size balanced trees.
+--------------------------------------------------------------------}
+-- | A Map from keys @k@ and values @a@. [_$_]
+data Map k a = Tip [_$_]
+ | Bin !Size !k a !(Map k a) !(Map k a) [_$_]
+
+type Size = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the map empty?
+isEmpty :: Map k a -> Bool
+isEmpty t
+ = case t of
+ Tip -> True
+ Bin sz k x l r -> False
+
+-- | /O(1)/. The number of elements in the map.
+size :: Map k a -> Int
+size t
+ = case t of
+ Tip -> 0
+ Bin sz k x l r -> sz
+
+
+-- | /O(log n)/. Lookup the value of key in the map.
+lookup :: Ord k => k -> Map k a -> Maybe a
+lookup k t
+ = case t of
+ Tip -> Nothing
+ Bin sz kx x l r
+ -> case compare k kx of
+ LT -> lookup k l
+ GT -> lookup k r
+ EQ -> Just x [_$_]
+
+-- | /O(log n)/. Is the key a member of the map?
+member :: Ord k => k -> Map k a -> Bool
+member k m
+ = case lookup k m of
+ Nothing -> False
+ Just x -> True
+
+-- | /O(log n)/. Find the value of a key. Calls @error@ when the element can not be found.
+find :: Ord k => k -> Map k a -> a
+find k m
+ = case lookup k m of
+ Nothing -> error "Map.find: element not in the map"
+ Just x -> x
+
+-- | /O(log n)/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
+-- the key is not in the map.
+findWithDefault :: Ord k => a -> k -> Map k a -> a
+findWithDefault def k m
+ = case lookup k m of
+ Nothing -> def
+ Just x -> x
+
+
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. Create an empty map.
+empty :: Map k a
+empty [_$_]
+ = Tip
+
+-- | /O(1)/. Create a map with a single element.
+single :: k -> a -> Map k a
+single k x [_$_]
+ = Bin 1 k x Tip Tip
+
+{--------------------------------------------------------------------
+ Insertion
+ [insert] is the inlined version of [insertWith (\k x y -> x)]
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert a new key and value in the map.
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert kx x t
+ = case t of
+ Tip -> single kx x
+ Bin sz ky y l r
+ -> case compare kx ky of
+ LT -> balance ky y (insert kx x l) r
+ GT -> balance ky y l (insert kx x r)
+ EQ -> Bin sz kx x l r
+
+-- | /O(log n)/. Insert with a combining function.
+insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWith f k x m [_$_]
+ = insertWithKey (\k x y -> f x y) k x m
+
+-- | /O(log n)/. Insert with a combining function.
+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
+insertWithKey f kx x t
+ = case t of
+ Tip -> single kx x
+ Bin sy ky y l r
+ -> case compare kx ky of
+ LT -> balance ky y (insertWithKey f kx x l) r
+ GT -> balance ky y l (insertWithKey f kx x r)
+ EQ -> Bin sy ky (f ky x y) l r
+
+-- | /O(log n)/. The expression (@insertLookupWithKey f k x map@) is a pair where
+-- the first element is equal to (@lookup k map@) and the second element
+-- equal to (@insertWithKey f k x map@).
+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a,Map k a)
+insertLookupWithKey f kx x t
+ = case t of
+ Tip -> (Nothing, single kx x)
+ Bin sy ky y l r
+ -> case compare kx ky of
+ LT -> let (found,l') = insertLookupWithKey f kx x l in (found,balance ky y l' r)
+ GT -> let (found,r') = insertLookupWithKey f kx x r in (found,balance ky y l r')
+ EQ -> (Just y, Bin sy ky (f ky x y) l r)
+
+{--------------------------------------------------------------------
+ Deletion
+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]
+--------------------------------------------------------------------}
+-- | /O(log n)/. Delete a key and its value from the map. When the key is not
+-- a member of the map, the original map is returned.
+delete :: Ord k => k -> Map k a -> Map k a
+delete k t
+ = case t of
+ Tip -> Tip
+ Bin sx kx x l r [_$_]
+ -> case compare k kx of
+ LT -> balance kx x (delete k l) r
+ GT -> balance kx x l (delete k r)
+ EQ -> glue l r
+
+-- | /O(log n)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
+adjust f k m
+ = adjustWithKey (\k x -> f x) k m
+
+-- | /O(log n)/. Adjust a value at a specific key. When the key is not
+-- a member of the map, the original map is returned.
+adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a
+adjustWithKey f k m
+ = updateWithKey (\k x -> Just (f k x)) k m
+
+-- | /O(log n)/. The expression (@update f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
+-- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
+update f k m
+ = updateWithKey (\k x -> f x) k m
+
+-- | /O(log n)/. 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 :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a
+updateWithKey f k t
+ = case t of
+ Tip -> Tip
+ Bin sx kx x l r [_$_]
+ -> case compare k kx of
+ LT -> balance kx x (updateWithKey f k l) r
+ GT -> balance kx x l (updateWithKey f k r)
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+
+-- | /O(log n)/. Lookup and update.
+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)
+updateLookupWithKey f k t
+ = case t of
+ Tip -> (Nothing,Tip)
+ Bin sx kx x l r [_$_]
+ -> case compare k kx of
+ LT -> let (found,l') = updateLookupWithKey f k l in (found,balance kx x l' r)
+ GT -> let (found,r') = updateLookupWithKey f k r in (found,balance kx x l r') [_$_]
+ EQ -> case f kx x of
+ Just x' -> (Just x',Bin sx kx x' l r)
+ Nothing -> (Just x,glue l r)
+
+{--------------------------------------------------------------------
+ Indexing
+--------------------------------------------------------------------}
+-- | /O(log n)/. Return the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map. Calls 'error' when
+-- the key is not a 'member' of the map.
+findIndex :: Ord k => k -> Map k a -> Int
+findIndex k t
+ = case lookupIndex k t of
+ Nothing -> error "Map.findIndex: element is not in the map"
+ Just idx -> idx
+
+-- | /O(log n)/. Lookup the /index/ of a key. The index is a number from
+-- /0/ up to, but not including, the 'size' of the map. [_$_]
+lookupIndex :: Ord k => k -> Map k a -> Maybe Int
+lookupIndex k t
+ = lookup 0 t
+ where
+ lookup idx Tip = Nothing
+ lookup idx (Bin _ kx x l r)
+ = case compare k kx of
+ LT -> lookup idx l
+ GT -> lookup (idx + size l + 1) r [_$_]
+ EQ -> Just (idx + size l)
+
+-- | /O(log n)/. Retrieve an element by /index/. Calls 'error' when an
+-- invalid index is used.
+elemAt :: Int -> Map k a -> (k,a)
+elemAt i Tip = error "Map.elemAt: index out of range"
+elemAt i (Bin _ kx x l r)
+ = case compare i sizeL of
+ LT -> elemAt i l
+ GT -> elemAt (i-sizeL-1) r
+ EQ -> (kx,x)
+ where
+ sizeL = size l
+
+-- | /O(log n)/. Update the element at /index/. Calls 'error' when an
+-- invalid index is used.
+updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a
+updateAt f i Tip = error "Map.updateAt: index out of range"
+updateAt f i (Bin sx kx x l r)
+ = case compare i sizeL of
+ LT -> updateAt f i l
+ GT -> updateAt f (i-sizeL-1) r
+ EQ -> case f kx x of
+ Just x' -> Bin sx kx x' l r
+ Nothing -> glue l r
+ where
+ sizeL = size l
+
+-- | /O(log n)/. Delete the element at /index/. Defined as (@deleteAt i map = updateAt (\k x -> Nothing) i map@).
+deleteAt :: Int -> Map k a -> Map k a
+deleteAt i map
+ = updateAt (\k x -> Nothing) i map
+
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal key of the map.
+findMin :: Map k a -> (k,a)
+findMin (Bin _ kx x Tip r) = (kx,x)
+findMin (Bin _ kx x l r) = findMin l
+findMin Tip = error "Map.findMin: empty tree has no minimal element"
+
+-- | /O(log n)/. The maximal key of the map.
+findMax :: Map k a -> (k,a)
+findMax (Bin _ kx x l Tip) = (kx,x)
+findMax (Bin _ kx x l r) = findMax r
+findMax Tip = error "Map.findMax: empty tree has no maximal element"
+
+-- | /O(log n)/. Delete the minimal key
+deleteMin :: Map k a -> Map k a
+deleteMin (Bin _ kx x Tip r) = r
+deleteMin (Bin _ kx x l r) = balance kx x (deleteMin l) r
+deleteMin Tip = Tip
+
+-- | /O(log n)/. Delete the maximal key
+deleteMax :: Map k a -> Map k a
+deleteMax (Bin _ kx x l Tip) = l
+deleteMax (Bin _ kx x l r) = balance kx x l (deleteMax r)
+deleteMax Tip = Tip
+
+-- | /O(log n)/. Update the minimal key
+updateMin :: (a -> Maybe a) -> Map k a -> Map k a
+updateMin f m
+ = updateMinWithKey (\k x -> f x) m
+
+-- | /O(log n)/. Update the maximal key
+updateMax :: (a -> Maybe a) -> Map k a -> Map k a
+updateMax f m
+ = updateMaxWithKey (\k x -> f x) m
+
+
+-- | /O(log n)/. Update the minimal key
+updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMinWithKey f t
+ = case t of
+ Bin sx kx x Tip r -> case f kx x of
+ Nothing -> r
+ Just x' -> Bin sx kx x' Tip r
+ Bin sx kx x l r -> balance kx x (updateMinWithKey f l) r
+ Tip -> Tip
+
+-- | /O(log n)/. Update the maximal key
+updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a
+updateMaxWithKey f t
+ = case t of
+ Bin sx kx x l Tip -> case f kx x of
+ Nothing -> l
+ Just x' -> Bin sx kx x' l Tip
+ Bin sx kx x l r -> balance kx x l (updateMaxWithKey f r)
+ Tip -> Tip
+
+
+{--------------------------------------------------------------------
+ Union. [_$_]
+--------------------------------------------------------------------}
+-- | The union of a list of maps: (@unions == foldl union empty@).
+unions :: Ord k => [Map k a] -> Map k a
+unions ts
+ = foldlStrict union empty ts
+
+-- | /O(n+m)/.
+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@. [_$_]
+-- It prefers @t1@ when duplicate keys are encountered, ie. (@union == unionWith const@).
+-- The implementation uses the efficient /hedge-union/ algorithm.
+union :: Ord k => Map k a -> Map k a -> Map k a
+union Tip t2 = t2
+union t1 Tip = t1
+union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset)
+ | size t1 >= size t2 = hedgeUnionL (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnionR (const LT) (const GT) t2 t1
+
+-- left-biased hedge union
+hedgeUnionL cmplo cmphi t1 Tip [_$_]
+ = t1
+hedgeUnionL cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionL cmplo cmphi (Bin _ kx x l r) t2
+ = join kx x (hedgeUnionL cmplo cmpkx l (trim cmplo cmpkx t2)) [_$_]
+ (hedgeUnionL cmpkx cmphi r (trim cmpkx cmphi t2))
+ where
+ cmpkx k = compare kx k
+
+-- right-biased hedge union
+hedgeUnionR cmplo cmphi t1 Tip [_$_]
+ = t1
+hedgeUnionR cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionR cmplo cmphi (Bin _ kx x l r) t2
+ = join kx newx (hedgeUnionR cmplo cmpkx l lt) [_$_]
+ (hedgeUnionR cmpkx cmphi r gt)
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t2
+ (found,gt) = trimLookupLo kx cmphi t2
+ newx = case found of
+ Nothing -> x
+ Just y -> y
+
+{--------------------------------------------------------------------
+ Union with a combining function
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWith f m1 m2
+ = unionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/.
+-- Union with a combining function. The implementation uses the efficient /hedge-union/ algorithm.
+unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
+unionWithKey f Tip t2 = t2
+unionWithKey f t1 Tip = t1
+unionWithKey f t1 t2 -- hedge-union is more efficient on (bigset `union` smallset)
+ | size t1 >= size t2 = hedgeUnionWithKey f (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnionWithKey flipf (const LT) (const GT) t2 t1
+ where
+ flipf k x y = f k y x
+
+hedgeUnionWithKey f cmplo cmphi t1 Tip [_$_]
+ = t1
+hedgeUnionWithKey f cmplo cmphi Tip (Bin _ kx x l r)
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnionWithKey f cmplo cmphi (Bin _ kx x l r) t2
+ = join kx newx (hedgeUnionWithKey f cmplo cmpkx l lt) [_$_]
+ (hedgeUnionWithKey f cmpkx cmphi r gt)
+ where
+ cmpkx k = compare kx k
+ lt = trim cmplo cmpkx t2
+ (found,gt) = trimLookupLo kx cmphi t2
+ newx = case found of
+ Nothing -> x
+ Just y -> f kx x y
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference of two maps. [_$_]
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+difference :: Ord k => Map k a -> Map k a -> Map k a
+difference Tip t2 = Tip
+difference t1 Tip = t1
+difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
+
+hedgeDiff cmplo cmphi Tip t [_$_]
+ = Tip
+hedgeDiff cmplo cmphi (Bin _ kx x l r) Tip [_$_]
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiff cmplo cmphi t (Bin _ kx x l r) [_$_]
+ = merge (hedgeDiff cmplo cmpkx (trim cmplo cmpkx t) l) [_$_]
+ (hedgeDiff cmpkx cmphi (trim cmpkx cmphi t) r)
+ where
+ cmpkx k = compare kx k [_$_]
+
+-- | /O(n+m)/. Difference with a combining function. [_$_]
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+differenceWith :: Ord k => (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k 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@. [_$_]
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+differenceWithKey :: Ord k => (k -> a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a
+differenceWithKey f Tip t2 = Tip
+differenceWithKey f t1 Tip = t1
+differenceWithKey f t1 t2 = hedgeDiffWithKey f (const LT) (const GT) t1 t2
+
+hedgeDiffWithKey f cmplo cmphi Tip t [_$_]
+ = Tip
+hedgeDiffWithKey f cmplo cmphi (Bin _ kx x l r) Tip [_$_]
+ = join kx x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiffWithKey f cmplo cmphi t (Bin _ kx x l r) [_$_]
+ = case found of
+ Nothing -> merge tl tr
+ Just y -> case f kx y x of
+ Nothing -> merge tl tr
+ Just z -> join kx z tl tr
+ where
+ cmpkx k = compare kx k [_$_]
+ lt = trim cmplo cmpkx t
+ (found,gt) = trimLookupLo kx cmphi t
+ tl = hedgeDiffWithKey f cmplo cmpkx lt l
+ tr = hedgeDiffWithKey f cmpkx cmphi gt r
+
+
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Intersection of two maps. The values in the first
+-- map are returned, i.e. (@intersection m1 m2 == intersectionWith const m1 m2@).
+intersection :: Ord k => Map k a -> Map k a -> Map k a
+intersection m1 m2
+ = intersectionWithKey (\k x y -> x) m1 m2
+
+-- | /O(n+m)/. Intersection with a combining function.
+intersectionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
+intersectionWith f m1 m2
+ = intersectionWithKey (\k x y -> f x y) m1 m2
+
+-- | /O(n+m)/. Intersection with a combining function.
+intersectionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
+intersectionWithKey f Tip t = Tip
+intersectionWithKey f t Tip = Tip
+intersectionWithKey f t1 t2 -- intersection is more efficient on (bigset `intersection` smallset)
+ | size t1 >= size t2 = intersectWithKey f t1 t2
+ | otherwise = intersectWithKey flipf t2 t1
+ where
+ flipf k x y = f k y x
+
+intersectWithKey f Tip t = Tip
+intersectWithKey f t Tip = Tip
+intersectWithKey f t (Bin _ kx x l r)
+ = case found of
+ Nothing -> merge tl tr
+ Just y -> join kx (f kx y x) tl tr
+ where
+ (found,lt,gt) = splitLookup kx t
+ tl = intersectWithKey f lt l
+ tr = intersectWithKey f gt r
+
+
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. [_$_]
+-- This function is defined as (@subset = subsetBy (==)@).
+subset :: (Ord k,Eq a) => Map k a -> Map k a -> Bool
+subset m1 m2
+ = subsetBy (==) m1 m2
+
+{- | /O(n+m)/. [_$_]
+ The expression (@subsetBy f t1 t2@) returns @True@ if
+ all keys in @t1@ are in tree @t2@, and when @f@ returns @True@ when
+ applied to their respective values. For example, the following [_$_]
+ expressions are all @True@.
+ [_$_]
+ > subsetBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > subsetBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])
+
+ But the following are all @False@:
+ [_$_]
+ > subsetBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])
+ > subsetBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])
+ > subsetBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])
+-}
+subsetBy :: Ord k => (a->a->Bool) -> Map k a -> Map k a -> Bool
+subsetBy f t1 t2
+ = (size t1 <= size t2) && (subset' f t1 t2)
+
+subset' f Tip t = True
+subset' f t Tip = False
+subset' f (Bin _ kx x l r) t
+ = case found of
+ Nothing -> False
+ Just y -> f x y && subset' f l lt && subset' f r gt
+ where
+ (found,lt,gt) = splitLookup kx t
+
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal). [_$_]
+-- Defined as (@properSubset = properSubsetBy (==)@).
+properSubset :: (Ord k,Eq a) => Map k a -> Map k 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 :: (Ord k,Eq a) => (a -> a -> Bool) -> Map k a -> Map k a -> Bool
+properSubsetBy f t1 t2
+ = (size t1 < size t2) && (subset' f t1 t2)
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all values that satisfy the predicate.
+filter :: Ord k => (a -> Bool) -> Map k a -> Map k a
+filter p m
+ = filterWithKey (\k x -> p x) m
+
+-- | /O(n)/. Filter all keys\values that satisfy the predicate.
+filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a
+filterWithKey p Tip = Tip
+filterWithKey p (Bin _ kx x l r)
+ | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)
+ | otherwise = merge (filterWithKey p l) (filterWithKey p r)
+
+
+-- | /O(n)/. partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partition :: Ord k => (a -> Bool) -> Map k a -> (Map k a,Map k a)
+partition p m
+ = partitionWithKey (\k x -> p x) m
+
+-- | /O(n)/. partition the map according to a predicate. The first
+-- map contains all elements that satisfy the predicate, the second all
+-- elements that fail the predicate. See also 'split'.
+partitionWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)
+partitionWithKey p Tip = (Tip,Tip)
+partitionWithKey p (Bin _ kx x l r)
+ | p kx x = (join kx x l1 r1,merge l2 r2)
+ | otherwise = (merge l1 r1,join kx x l2 r2)
+ where
+ (l1,l2) = partitionWithKey p l
+ (r1,r2) = partitionWithKey p r
+
+
+{--------------------------------------------------------------------
+ Mapping
+--------------------------------------------------------------------}
+-- | /O(n)/. Map a function over all values in the map.
+map :: (a -> b) -> Map k a -> Map k b
+map f m
+ = mapWithKey (\k x -> f x) m
+
+-- | /O(n)/. Map a function over all values in the map.
+mapWithKey :: (k -> a -> b) -> Map k a -> Map k b
+mapWithKey f Tip = Tip
+mapWithKey f (Bin sx kx x l r) [_$_]
+ = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)
+
+-- | /O(n)/. The function @mapAccum@ threads an accumulating
+-- argument through the map in an unspecified order.
+mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k 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 unspecified order. (= ascending pre-order)
+mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumWithKey f a t
+ = mapAccumL f a t
+
+-- | /O(n)/. The function @mapAccumL@ threads an accumulating
+-- argument throught the map in (ascending) pre-order.
+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumL f a t
+ = case t of
+ Tip -> (a,Tip)
+ Bin sx kx x l r
+ -> let (a1,l') = mapAccumL f a l
+ (a2,x') = f a1 kx x
+ (a3,r') = mapAccumL f a2 r
+ in (a3,Bin sx kx x' l' r')
+
+-- | /O(n)/. The function @mapAccumR@ threads an accumulating
+-- argument throught the map in (descending) post-order.
+mapAccumR :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)
+mapAccumR f a t
+ = case t of
+ Tip -> (a,Tip)
+ Bin sx kx x l r [_$_]
+ -> let (a1,r') = mapAccumR f a r
+ (a2,x') = f a1 kx x
+ (a3,l') = mapAccumR f a2 l
+ in (a3,Bin sx kx x' l' r')
+
+{--------------------------------------------------------------------
+ Folds [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
+fold :: (a -> b -> b) -> b -> Map k a -> b
+fold f z m
+ = foldWithKey (\k x z -> f x z) z m
+
+-- | /O(n)/. Fold the map in an unspecified order. (= descending post-order).
+foldWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldWithKey f z t
+ = foldR f z t
+
+-- | /O(n)/. In-order fold.
+foldI :: (k -> a -> b -> b -> b) -> b -> Map k a -> b [_$_]
+foldI f z Tip = z
+foldI f z (Bin _ kx x l r) = f kx x (foldI f z l) (foldI f z r)
+
+-- | /O(n)/. Post-order fold.
+foldR :: (k -> a -> b -> b) -> b -> Map k a -> b
+foldR f z Tip = z
+foldR f z (Bin _ kx x l r) = foldR f (f kx x (foldR f z r)) l
+
+-- | /O(n)/. Pre-order fold.
+foldL :: (b -> k -> a -> b) -> b -> Map k a -> b
+foldL f z Tip = z
+foldL f z (Bin _ kx x l r) = foldL f (f (foldL f z l) kx x) r
+
+{--------------------------------------------------------------------
+ List variations [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Return all elements of the map.
+elems :: Map k a -> [a]
+elems m
+ = [x | (k,x) <- assocs m]
+
+-- | /O(n)/. Return all keys of the map.
+keys :: Map k a -> [k]
+keys m
+ = [k | (k,x) <- assocs m]
+
+-- | /O(n)/. Return all key\/value pairs in the map.
+assocs :: Map k a -> [(k,a)]
+assocs m
+ = toList m
+
+{--------------------------------------------------------------------
+ Lists [_$_]
+ use [foldlStrict] to reduce demand on the control-stack
+--------------------------------------------------------------------}
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.
+fromList :: Ord k => [(k,a)] -> Map k a [_$_]
+fromList xs [_$_]
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insert k x t
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.
+fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a [_$_]
+fromListWith f xs
+ = fromListWithKey (\k x y -> f x y) xs
+
+-- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.
+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a [_$_]
+fromListWithKey f xs [_$_]
+ = foldlStrict ins empty xs
+ where
+ ins t (k,x) = insertWithKey f k x t
+
+-- | /O(n)/. Convert to a list of key\/value pairs.
+toList :: Map k a -> [(k,a)]
+toList t = toAscList t
+
+-- | /O(n)/. Convert to an ascending list.
+toAscList :: Map k a -> [(k,a)]
+toAscList t = foldR (\k x xs -> (k,x):xs) [] t
+
+-- | /O(n)/. [_$_]
+toDescList :: Map k a -> [(k,a)]
+toDescList t = foldL (\xs k x -> (k,x):xs) [] t
+
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+ [_$_]
+ Note that if [xs] is ascending that: [_$_]
+ fromAscList xs == fromList xs
+ fromAscListWith f xs == fromListWith f xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a map from an ascending list in linear time.
+fromAscList :: Eq k => [(k,a)] -> Map k a [_$_]
+fromAscList xs
+ = fromAscListWithKey (\k x y -> x) xs
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.
+fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a [_$_]
+fromAscListWith f xs
+ = fromAscListWithKey (\k x y -> f x y) xs
+
+-- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys
+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a [_$_]
+fromAscListWithKey f xs
+ = fromDistinctAscList (combineEq f xs)
+ where
+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]
+ combineEq f xs
+ = case xs of
+ [] -> []
+ [x] -> [x]
+ (x:xx) -> combineEq' x xx
+
+ combineEq' z [] = [z]
+ combineEq' z@(kz,zz) (x@(kx,xx):xs)
+ | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs
+ | otherwise = z:combineEq' x xs
+
+
+-- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.
+fromDistinctAscList :: [(k,a)] -> Map k a [_$_]
+fromDistinctAscList xs
+ = build const (length xs) xs
+ where
+ -- 1) use continutations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees. [_$_]
+ build c 0 xs = c Tip xs [_$_]
+ build c 5 xs = case xs of
+ ((k1,x1):(k2,x2):(k3,x3):(k4,x4):(k5,x5):xx) [_$_]
+ -> c (bin k4 x4 (bin k2 x2 (single k1 x1) (single k3 x3)) (single k5 x5)) xx
+ build c n xs = seq nr $ build (buildR nr c) nl xs
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l ((k,x):ys) = build (buildB l k x c) n ys
+ buildB l k x c r zs = c (bin k x l r) zs
+ [_$_]
+
+
+{--------------------------------------------------------------------
+ Utility functions that return sub-ranges of the original
+ tree. Some functions take a comparison function as argument to
+ allow comparisons against infinite values. A function [cmplo k]
+ should be read as [compare lo k].
+
+ [trim cmplo cmphi t] A tree that is either empty or where [cmplo k == LT]
+ and [cmphi k == GT] for the key [k] of the root.
+ [filterGt cmp t] A tree where for all keys [k]. [cmp k == LT]
+ [filterLt cmp t] A tree where for all keys [k]. [cmp k == GT]
+
+ [split k t] Returns two trees [l] and [r] where all keys
+ in [l] are <[k] and all keys in [r] are >[k].
+ [splitLookup k t] Just like [split] but also returns whether [k]
+ was found in the tree.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ [trim lo hi t] trims away all subtrees that surely contain no
+ values between the range [lo] to [hi]. The returned tree is either
+ empty or the key of the root is between @lo@ and @hi@.
+--------------------------------------------------------------------}
+trim :: (k -> Ordering) -> (k -> Ordering) -> Map k a -> Map k a
+trim cmplo cmphi Tip = Tip
+trim cmplo cmphi t@(Bin sx kx x l r)
+ = case cmplo kx of
+ LT -> case cmphi kx of
+ GT -> t
+ le -> trim cmplo cmphi l
+ ge -> trim cmplo cmphi r
+ [_$_]
+trimLookupLo :: Ord k => k -> (k -> Ordering) -> Map k a -> (Maybe a, Map k a)
+trimLookupLo lo cmphi Tip = (Nothing,Tip)
+trimLookupLo lo cmphi t@(Bin sx kx x l r)
+ = case compare lo kx of
+ LT -> case cmphi kx of
+ GT -> (lookup lo t, t)
+ le -> trimLookupLo lo cmphi l
+ GT -> trimLookupLo lo cmphi r
+ EQ -> (Just x,trim (compare lo) cmphi r)
+
+
+{--------------------------------------------------------------------
+ [filterGt k t] filter all keys >[k] from tree [t]
+ [filterLt k t] filter all keys <[k] from tree [t]
+--------------------------------------------------------------------}
+filterGt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
+filterGt cmp Tip = Tip
+filterGt cmp (Bin sx kx x l r)
+ = case cmp kx of
+ LT -> join kx x (filterGt cmp l) r
+ GT -> filterGt cmp r
+ EQ -> r
+ [_$_]
+filterLt :: Ord k => (k -> Ordering) -> Map k a -> Map k a
+filterLt cmp Tip = Tip
+filterLt cmp (Bin sx kx x l r)
+ = case cmp kx of
+ LT -> filterLt cmp l
+ GT -> join kx x l (filterLt cmp r)
+ EQ -> l
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@ where
+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.
+split :: Ord k => k -> Map k a -> (Map k a,Map k a)
+split k Tip = (Tip,Tip)
+split k (Bin sx kx x l r)
+ = case compare k kx of
+ LT -> let (lt,gt) = split k l in (lt,join kx x gt r)
+ GT -> let (lt,gt) = split k r in (join kx x l lt,gt)
+ EQ -> (l,r)
+
+-- | /O(log n)/. The expression (@splitLookup k map@) splits a map just
+-- like 'split' but also returns @lookup k map@.
+splitLookup :: Ord k => k -> Map k a -> (Maybe a,Map k a,Map k a)
+splitLookup k Tip = (Nothing,Tip,Tip)
+splitLookup k (Bin sx kx x l r)
+ = case compare k kx of
+ LT -> let (z,lt,gt) = splitLookup k l in (z,lt,join kx x gt r)
+ GT -> let (z,lt,gt) = splitLookup k r in (z,join kx x l lt,gt)
+ EQ -> (Just x,l,r)
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [k] and all values
+ in [r] > [k], and that [l] and [r] are valid trees.
+ [_$_]
+ In order of sophistication:
+ [Bin sz k x l r] The type constructor.
+ [bin k x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance k x l r] Restores the balance and size.
+ Assumes that the original tree was balanced and
+ that [l] or [r] has changed by at most one element.
+ [join k x l r] Restores balance and size. [_$_]
+
+ Furthermore, we can construct a new tree from two trees. Both operations
+ assume that all values in [l] < all values in [r] and that [l] and [r]
+ are valid:
+ [glue l r] Glues [l] and [r] together. Assumes that [l] and
+ [r] are already balanced with respect to each other.
+ [merge l r] Merges two trees and restores balance.
+
+ Note: in contrast to Adam's paper, we use (<=) comparisons instead
+ of (<) comparisons in [join], [merge] and [balance]. [_$_]
+ Quickcheck (on [difference]) showed that this was necessary in order [_$_]
+ to maintain the invariants. It is quite unsatisfactory that I haven't [_$_]
+ been able to find out why this is actually the case! Fortunately, it [_$_]
+ doesn't hurt to be a bit more conservative.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Join [_$_]
+--------------------------------------------------------------------}
+join :: Ord k => k -> a -> Map k a -> Map k a -> Map k a
+join kx x Tip r = insertMin kx x r
+join kx x l Tip = insertMax kx x l
+join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)
+ | delta*sizeL <= sizeR = balance kz z (join kx x l lz) rz
+ | delta*sizeR <= sizeL = balance ky y ly (join kx x ry r)
+ | otherwise = bin kx x l r
+
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: k -> a -> Map k a -> Map k a [_$_]
+insertMax kx x t
+ = case t of
+ Tip -> single kx x
+ Bin sz ky y l r
+ -> balance ky y l (insertMax kx x r)
+ [_$_]
+insertMin kx x t
+ = case t of
+ Tip -> single kx x
+ Bin sz ky y l r
+ -> balance ky y (insertMin kx x l) r
+ [_$_]
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Map k a -> Map k a -> Map k a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)
+ | delta*sizeL <= sizeR = balance ky y (merge l ly) ry
+ | delta*sizeR <= sizeL = balance kx x lx (merge rx r)
+ | otherwise = glue l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Map k a -> Map k a -> Map k a
+glue Tip r = r
+glue l Tip = l
+glue l r [_$_]
+ | size l > size r = let ((km,m),l') = deleteFindMax l in balance km m l' r
+ | otherwise = let ((km,m),r') = deleteFindMin r in balance km m l r'
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+deleteFindMin :: Map k a -> ((k,a),Map k a)
+deleteFindMin t [_$_]
+ = case t of
+ Bin _ k x Tip r -> ((k,x),r)
+ Bin _ k x l r -> let (km,l') = deleteFindMin l in (km,balance k x l' r)
+ Tip -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+deleteFindMax :: Map k a -> ((k,a),Map k a)
+deleteFindMax t
+ = case t of
+ Bin _ k x l Tip -> ((k,x),l)
+ Bin _ k x l r -> let (km,r') = deleteFindMax r in (km,balance k x l r')
+ Tip -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)
+
+
+{--------------------------------------------------------------------
+ [balance l x r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper.
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is correspondes with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+ [_$_]
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ - Balancing is automaic for random data and a balancing
+ scheme is only necessary to avoid pathological worst cases.
+ Almost any choice will do, and in practice, a rather large
+ [delta] may perform better than smaller one.
+
+ Note: in contrast to Adam's paper, we use a ratio of (at least) [2]
+ to decide whether a single or double rotation is needed. Allthough
+ he actually proves that this ratio is needed to maintain the
+ invariants, his implementation uses an invalid ratio of [1].
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 5
+ratio = 2
+
+balance :: k -> a -> Map k a -> Map k a -> Map k a
+balance k x l r
+ | sizeL + sizeR <= 1 = Bin sizeX k x l r
+ | sizeR >= delta*sizeL = rotateL k x l r
+ | sizeL >= delta*sizeR = rotateR k x l r
+ | otherwise = Bin sizeX k x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + 1
+
+-- rotate
+rotateL k x l r@(Bin _ _ _ ly ry)
+ | size ly < ratio*size ry = singleL k x l r
+ | otherwise = doubleL k x l r
+
+rotateR k x l@(Bin _ _ _ ly ry) r
+ | size ry < ratio*size ly = singleR k x l r
+ | otherwise = doubleR k x l r
+
+-- basic rotations
+singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3
+singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)
+
+doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)
+doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: k -> a -> Map k a -> Map k a -> Map k a
+bin k x l r
+ = Bin (size l + size r + 1) k x l r
+
+
+{--------------------------------------------------------------------
+ Eq converts the tree to a list. In a lazy setting, this [_$_]
+ actually seems one of the faster methods to compare two trees [_$_]
+ and it is certainly the simplest :-)
+--------------------------------------------------------------------}
+instance (Eq k,Eq a) => Eq (Map k a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Functor
+--------------------------------------------------------------------}
+instance Functor (Map k) where
+ fmap f m = map f m
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance (Show k, Show a) => Show (Map k a) where
+ showsPrec d m = showMap (toAscList m)
+
+showMap :: (Show k,Show a) => [(k,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
+ [_$_]
+
+-- | /O(n)/. Show the tree that implements the map. The tree is shown
+-- in a compressed, hanging format.
+showTree :: (Show k,Show a) => Map k a -> String
+showTree m
+ = showTreeWith showElem True False m
+ where
+ showElem k x = show k ++ ":=" ++ show x
+
+
+{- | /O(n)/. The expression (@showTreeWith showelem hang wide map@) shows
+ the tree that implements the map. Elements are shown using the @showElem@ function. 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.
+
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False $ fromDistinctAscList [(x,()) | x <- [1..5]]
+> (4,())
+> +--(2,())
+> | +--(1,())
+> | +--(3,())
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True $ fromDistinctAscList [(x,()) | x <- [1..5]]
+> (4,())
+> |
+> +--(2,())
+> | |
+> | +--(1,())
+> | |
+> | +--(3,())
+> |
+> +--(5,())
+>
+> Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True $ fromDistinctAscList [(x,()) | x <- [1..5]]
+> +--(5,())
+> |
+> (4,())
+> |
+> | +--(3,())
+> | |
+> +--(2,())
+> |
+> +--(1,())
+
+-}
+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String
+showTreeWith showelem hang wide t
+ | hang = (showsTreeHang showelem wide [] t) ""
+ | otherwise = (showsTree showelem wide [] [] t) ""
+
+showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS
+showsTree showelem wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin sz kx x Tip Tip
+ -> showsBars lbars . showString (showelem kx x) . showString "\n" [_$_]
+ Bin sz kx x l r
+ -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . showString (showelem kx x) . showString "\n" .
+ showWide wide lbars .
+ showsTree showelem wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS
+showsTreeHang showelem wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n" [_$_]
+ Bin sz kx x Tip Tip
+ -> showsBars bars . showString (showelem kx x) . showString "\n" [_$_]
+ Bin sz kx x l r
+ -> showsBars bars . showString (showelem kx x) . showString "\n" . [_$_]
+ showWide wide bars .
+ showsTreeHang showelem wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang showelem wide (withEmpty bars) r
+
+
+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
+
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal map structure is valid.
+valid :: Ord k => Map k a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t
+ = case t of
+ Tip -> True
+ Bin sz kx x l r -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r
+
+-- | Exported only for "Debug.QuickCheck"
+balanced :: Map k a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin sz kx x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t
+ = case t of
+ Tip -> Just 0
+ Bin sz kx x l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ other -> Nothing
+
+{--------------------------------------------------------------------
+ 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 xs = fromList [(x,"*") | 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 (Enum k,Arbitrary a) => Arbitrary (Map k a) where
+ arbitrary = sized (arbtree 0 maxkey)
+ where maxkey = 10000
+
+arbtree :: (Enum k,Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)
+arbtree lo hi n
+ | n <= 0 = return Tip
+ | lo >= hi = return Tip
+ | otherwise = do{ x <- arbitrary [_$_]
+ ; i <- choose (lo,hi)
+ ; m <- choose (1,30)
+ ; let (ml,mr) | m==(1::Int)= (1,2)
+ | m==2 = (2,1)
+ | m==3 = (1,1)
+ | otherwise = (2,2)
+ ; l <- arbtree lo (i-1) (n `div` ml)
+ ; r <- arbtree (i+1) hi (n `div` mr)
+ ; return (bin (toEnum i) x l r)
+ } [_$_]
+
+
+{--------------------------------------------------------------------
+ Valid tree's
+--------------------------------------------------------------------}
+forValid :: (Show k,Enum k,Show a,Arbitrary a,Testable b) => (Map k a -> b) -> Property
+forValid f
+ = forAll arbitrary $ \t -> [_$_]
+-- classify (balanced t) "balanced" $
+ classify (size t == 0) "empty" $
+ classify (size t > 0 && size t <= 10) "small" $
+ classify (size t > 10 && size t <= 64) "medium" $
+ classify (size t > 64) "large" $
+ balanced t ==> f t
+
+forValidIntTree :: Testable a => (Map Int Int -> a) -> Property
+forValidIntTree f
+ = forValid f
+
+forValidUnitTree :: Testable a => (Map Int () -> a) -> Property
+forValidUnitTree f
+ = forValid f
+
+
+prop_Valid [_$_]
+ = forValidUnitTree $ \t -> valid t
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Int -> Bool
+prop_Single k x
+ = (insert k x empty == single k x)
+
+prop_InsertValid :: Int -> Property
+prop_InsertValid k
+ = forValidUnitTree $ \t -> valid (insert k () t)
+
+prop_InsertDelete :: Int -> Map Int () -> Property
+prop_InsertDelete k t
+ = (lookup k t == Nothing) ==> delete k (insert k () t) == t
+
+prop_DeleteValid :: Int -> Property
+prop_DeleteValid k
+ = forValidUnitTree $ \t -> [_$_]
+ valid (delete k (insert k () t))
+
+{--------------------------------------------------------------------
+ Balance
+--------------------------------------------------------------------}
+prop_Join :: Int -> Property [_$_]
+prop_Join k [_$_]
+ = forValidUnitTree $ \t ->
+ let (l,r) = split k t
+ in valid (join k () l r)
+
+prop_Merge :: Int -> Property [_$_]
+prop_Merge k
+ = forValidUnitTree $ \t ->
+ let (l,r) = split k t
+ in valid (merge l r)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionValid :: Property
+prop_UnionValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (union t1 t2)
+
+prop_UnionInsert :: Int -> Int -> Map Int Int -> Bool
+prop_UnionInsert k x t
+ = union (single k x) t == insert k x t
+
+prop_UnionAssoc :: Map Int Int -> Map Int Int -> Map Int Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: Map Int Int -> Map Int Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == unionWith (\x y -> y) t2 t1)
+
+prop_UnionWithValid [_$_]
+ = forValidIntTree $ \t1 ->
+ forValidIntTree $ \t2 ->
+ valid (unionWithKey (\k x y -> x+y) t1 t2)
+
+prop_UnionWith :: [(Int,Int)] -> [(Int,Int)] -> Bool
+prop_UnionWith xs ys
+ = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys))) [_$_]
+ == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))
+
+prop_DiffValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (difference t1 t2)
+
+prop_Diff :: [(Int,Int)] -> [(Int,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_IntValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (intersection t1 t2)
+
+prop_Int :: [(Int,Int)] -> [(Int,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 :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])
+-}
addfile ./lib/DData/MultiSet.hs
hunk ./lib/DData/MultiSet.hs 1
+--------------------------------------------------------------------------------
+{-| Module : MultiSet
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ An implementation of multi sets on top of the "Map" module. A multi set
+ differs from a /bag/ in the sense that it is represented as a map from elements
+ to occurrence counts instead of retaining all elements. This means that equality [_$_]
+ on elements should be defined as a /structural/ equality instead of an [_$_]
+ equivalence relation. If this is not the case, operations that observe the [_$_]
+ elements, like 'filter' and 'fold', should be used with care.
+-}
+---------------------------------------------------------------------------------}
+module MultiSet ( [_$_]
+ -- * MultiSet type
+ MultiSet -- instance Eq,Show
+ [_$_]
+ -- * Operators
+ , (\\)
+
+ -- *Query
+ , isEmpty
+ , size
+ , distinctSize
+ , member
+ , occur
+
+ , subset
+ , properSubset
+ [_$_]
+ -- * Construction
+ , empty
+ , single
+ , insert
+ , insertMany
+ , delete
+ , deleteAll
+ [_$_]
+ -- * Combine
+ , union
+ , difference
+ , intersection
+ , unions
+ [_$_]
+ -- * Filter
+ , filter
+ , partition
+
+ -- * Fold
+ , fold
+ , foldOccur
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteMinAll
+ , deleteMaxAll
+ [_$_]
+ -- * Conversion
+ , elems
+
+ -- ** List
+ , toList
+ , fromList
+
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+
+ -- ** Occurrence lists
+ , toOccurList
+ , toAscOccurList
+ , fromOccurList
+ , fromAscOccurList
+
+ -- ** Map
+ , toMap
+ , fromMap
+ , fromOccurMap
+ [_$_]
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+ ) where
+
+import Prelude hiding (map,filter)
+import qualified Prelude (map,filter)
+
+import qualified Map as M
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 \\
+
+-- | /O(n+m)/. See 'difference'.
+(\\) :: Ord a => MultiSet a -> MultiSet a -> MultiSet a
+b1 \\ b2 = difference b1 b2
+
+{--------------------------------------------------------------------
+ MultiSets are a simple wrapper around Maps, 'Map.Map'
+--------------------------------------------------------------------}
+-- | A multi set of values @a@.
+newtype MultiSet a = MultiSet (M.Map a Int)
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is the multi set empty?
+isEmpty :: MultiSet a -> Bool
+isEmpty (MultiSet m) [_$_]
+ = M.isEmpty m
+
+-- | /O(1)/. Returns the number of distinct elements in the multi set, ie. (@distinctSize mset == Set.size ('toSet' mset)@).
+distinctSize :: MultiSet a -> Int
+distinctSize (MultiSet m) [_$_]
+ = M.size m
+
+-- | /O(n)/. The number of elements in the multi set.
+size :: MultiSet a -> Int
+size b
+ = foldOccur (\x n m -> n+m) 0 b
+
+-- | /O(log n)/. Is the element in the multi set?
+member :: Ord a => a -> MultiSet a -> Bool
+member x m
+ = (occur x m > 0)
+
+-- | /O(log n)/. The number of occurrences of an element in the multi set.
+occur :: Ord a => a -> MultiSet a -> Int
+occur x (MultiSet m)
+ = case M.lookup x m of
+ Nothing -> 0
+ Just n -> n
+
+-- | /O(n+m)/. Is this a subset of the multi set? [_$_]
+subset :: Ord a => MultiSet a -> MultiSet a -> Bool
+subset (MultiSet m1) (MultiSet m2)
+ = M.subsetBy (<=) m1 m2
+
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset and not equal)
+properSubset :: Ord a => MultiSet a -> MultiSet a -> Bool
+properSubset b1 b2
+ | distinctSize b1 == distinctSize b2 = (subset b1 b2) && (b1 /= b2)
+ | distinctSize b1 < distinctSize b2 = (subset b1 b2)
+ | otherwise = False
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. Create an empty multi set.
+empty :: MultiSet a
+empty
+ = MultiSet (M.empty)
+
+-- | /O(1)/. Create a singleton multi set.
+single :: a -> MultiSet a
+single x [_$_]
+ = MultiSet (M.single x 0)
+ [_$_]
+{--------------------------------------------------------------------
+ Insertion, Deletion
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert an element in the multi set.
+insert :: Ord a => a -> MultiSet a -> MultiSet a
+insert x (MultiSet m) [_$_]
+ = MultiSet (M.insertWith (+) x 1 m)
+
+-- | /O(min(n,W))/. The expression (@insertMany x count mset@)
+-- inserts @count@ instances of @x@ in the multi set @mset@.
+insertMany :: Ord a => a -> Int -> MultiSet a -> MultiSet a
+insertMany x count (MultiSet m) [_$_]
+ = MultiSet (M.insertWith (+) x count m)
+
+-- | /O(log n)/. Delete a single element.
+delete :: Ord a => a -> MultiSet a -> MultiSet a
+delete x (MultiSet m)
+ = MultiSet (M.updateWithKey f x m)
+ where
+ f x n | n > 0 = Just (n-1)
+ | otherwise = Nothing
+
+-- | /O(log n)/. Delete all occurrences of an element.
+deleteAll :: Ord a => a -> MultiSet a -> MultiSet a
+deleteAll x (MultiSet m)
+ = MultiSet (M.delete x m)
+
+{--------------------------------------------------------------------
+ Combine
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Union of two multisets. The union adds the elements together.
+--
+-- > MultiSet\> union (fromList [1,1,2]) (fromList [1,2,2,3])
+-- > {1,1,1,2,2,2,3}
+union :: Ord a => MultiSet a -> MultiSet a -> MultiSet a
+union (MultiSet t1) (MultiSet t2)
+ = MultiSet (M.unionWith (+) t1 t2)
+
+-- | /O(n+m)/. Intersection of two multisets.
+--
+-- > MultiSet\> intersection (fromList [1,1,2]) (fromList [1,2,2,3])
+-- > {1,2}
+intersection :: Ord a => MultiSet a -> MultiSet a -> MultiSet a
+intersection (MultiSet t1) (MultiSet t2)
+ = MultiSet (M.intersectionWith min t1 t2)
+
+-- | /O(n+m)/. Difference between two multisets.
+--
+-- > MultiSet\> difference (fromList [1,1,2]) (fromList [1,2,2,3])
+-- > {1}
+difference :: Ord a => MultiSet a -> MultiSet a -> MultiSet a
+difference (MultiSet t1) (MultiSet t2)
+ = MultiSet (M.differenceWithKey f t1 t2)
+ where
+ f x n m | n-m > 0 = Just (n-m)
+ | otherwise = Nothing
+
+-- | The union of a list of multisets.
+unions :: Ord a => [MultiSet a] -> MultiSet a
+unions multisets
+ = MultiSet (M.unions [m | MultiSet m <- multisets])
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy some predicate.
+filter :: Ord a => (a -> Bool) -> MultiSet a -> MultiSet a
+filter p (MultiSet m)
+ = MultiSet (M.filterWithKey (\x n -> p x) m)
+
+-- | /O(n)/. Partition the multi set according to some predicate.
+partition :: Ord a => (a -> Bool) -> MultiSet a -> (MultiSet a,MultiSet a)
+partition p (MultiSet m)
+ = (MultiSet l,MultiSet r)
+ where
+ (l,r) = M.partitionWithKey (\x n -> p x) m
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over each element in the multi set.
+fold :: (a -> b -> b) -> b -> MultiSet a -> b
+fold f z (MultiSet m)
+ = M.foldWithKey apply z m
+ where
+ apply x n z | n > 0 = apply x (n-1) (f x z)
+ | otherwise = z
+
+-- | /O(n)/. Fold over all occurrences of an element at once.
+foldOccur :: (a -> Int -> b -> b) -> b -> MultiSet a -> b
+foldOccur f z (MultiSet m)
+ = M.foldWithKey f z m
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal element of a multi set.
+findMin :: MultiSet a -> a
+findMin (MultiSet m)
+ = fst (M.findMin m)
+
+-- | /O(log n)/. The maximal element of a multi set.
+findMax :: MultiSet a -> a
+findMax (MultiSet m)
+ = fst (M.findMax m)
+
+-- | /O(log n)/. Delete the minimal element.
+deleteMin :: MultiSet a -> MultiSet a
+deleteMin (MultiSet m)
+ = MultiSet (M.updateMin f m)
+ where
+ f n | n > 0 = Just (n-1)
+ | otherwise = Nothing
+
+-- | /O(log n)/. Delete the maximal element.
+deleteMax :: MultiSet a -> MultiSet a
+deleteMax (MultiSet m)
+ = MultiSet (M.updateMax f m)
+ where
+ f n | n > 0 = Just (n-1)
+ | otherwise = Nothing
+
+-- | /O(log n)/. Delete all occurrences of the minimal element.
+deleteMinAll :: MultiSet a -> MultiSet a
+deleteMinAll (MultiSet m)
+ = MultiSet (M.deleteMin m)
+
+-- | /O(log n)/. Delete all occurrences of the maximal element.
+deleteMaxAll :: MultiSet a -> MultiSet a
+deleteMaxAll (MultiSet m)
+ = MultiSet (M.deleteMax m)
+
+
+{--------------------------------------------------------------------
+ List variations [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. The list of elements.
+elems :: MultiSet a -> [a]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Create a list with all elements.
+toList :: MultiSet a -> [a]
+toList s
+ = toAscList s
+
+-- | /O(n)/. Create an ascending list of all elements.
+toAscList :: MultiSet a -> [a]
+toAscList (MultiSet m)
+ = [y | (x,n) <- M.toAscList m, y <- replicate n x]
+
+
+-- | /O(n*log n)/. Create a multi set from a list of elements.
+fromList :: Ord a => [a] -> MultiSet a [_$_]
+fromList xs
+ = MultiSet (M.fromListWith (+) [(x,1) | x <- xs])
+
+-- | /O(n)/. Create a multi set from an ascending list in linear time.
+fromAscList :: Eq a => [a] -> MultiSet a [_$_]
+fromAscList xs
+ = MultiSet (M.fromAscListWith (+) [(x,1) | x <- xs])
+
+-- | /O(n)/. Create a multi set from an ascending list of distinct elements in linear time.
+fromDistinctAscList :: [a] -> MultiSet a [_$_]
+fromDistinctAscList xs
+ = MultiSet (M.fromDistinctAscList [(x,1) | x <- xs])
+
+-- | /O(n)/. Create a list of element\/occurrence pairs.
+toOccurList :: MultiSet a -> [(a,Int)]
+toOccurList b
+ = toAscOccurList b
+
+-- | /O(n)/. Create an ascending list of element\/occurrence pairs.
+toAscOccurList :: MultiSet a -> [(a,Int)]
+toAscOccurList (MultiSet m)
+ = M.toAscList m
+
+-- | /O(n*log n)/. Create a multi set from a list of element\/occurrence pairs.
+fromOccurList :: Ord a => [(a,Int)] -> MultiSet a
+fromOccurList xs
+ = MultiSet (M.fromListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))
+
+-- | /O(n)/. Create a multi set from an ascending list of element\/occurrence pairs.
+fromAscOccurList :: Ord a => [(a,Int)] -> MultiSet a
+fromAscOccurList xs
+ = MultiSet (M.fromAscListWith (+) (Prelude.filter (\(x,i) -> i > 0) xs))
+
+{--------------------------------------------------------------------
+ Maps
+--------------------------------------------------------------------}
+-- | /O(1)/. Convert to a 'Map.Map' from elements to number of occurrences.
+toMap :: MultiSet a -> M.Map a Int
+toMap (MultiSet m)
+ = m
+
+-- | /O(n)/. Convert a 'Map.Map' from elements to occurrences into a multi set.
+fromMap :: Ord a => M.Map a Int -> MultiSet a
+fromMap m
+ = MultiSet (M.filter (>0) m)
+
+-- | /O(1)/. Convert a 'Map.Map' from elements to occurrences into a multi set.
+-- Assumes that the 'Map.Map' contains only elements that occur at least once.
+fromOccurMap :: M.Map a Int -> MultiSet a
+fromOccurMap m
+ = MultiSet m
+
+{--------------------------------------------------------------------
+ Eq, Ord
+--------------------------------------------------------------------}
+instance Eq a => Eq (MultiSet a) where
+ (MultiSet m1) == (MultiSet m2) = (m1==m2) [_$_]
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show a => Show (MultiSet a) where
+ showsPrec d b = showSet (toAscList b)
+
+showSet :: Show a => [a] -> ShowS
+showSet [] [_$_]
+ = showString "{}" [_$_]
+showSet (x:xs) [_$_]
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+ [_$_]
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree structure that implements the 'MultiSet'. The tree
+-- is shown as a compressed and /hanging/.
+showTree :: (Show a) => MultiSet a -> String
+showTree mset
+ = showTreeWith True False mset
+
+-- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+-- the tree that implements the multi set. The tree is shown /hanging/ when @hang@ is @True@ [_$_]
+-- and otherwise as a /rotated/ tree. When @wide@ is @True@ an extra wide version
+-- is shown.
+showTreeWith :: Show a => Bool -> Bool -> MultiSet a -> String
+showTreeWith hang wide (MultiSet m)
+ = M.showTreeWith (\x n -> show x ++ " (" ++ show n ++ ")") hang wide m
+
+
+-- | /O(n)/. Is this a valid multi set?
+valid :: Ord a => MultiSet a -> Bool
+valid (MultiSet m)
+ = M.valid m && (M.isEmpty (M.filter (<=0) m))
addfile ./lib/DData/Queue.hs
hunk ./lib/DData/Queue.hs 1
-
+--------------------------------------------------------------------------------
+{-| Module : Queue
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of queues (FIFO buffers). Based on:
+
+ * Chris Okasaki, \"/Simple and Efficient Purely Functional Queues and Deques/\",
+ Journal of Functional Programming 5(4):583-592, October 1995.
+-}
+---------------------------------------------------------------------------------}
+module Queue ( [_$_]
+ -- * Queue type
+ Queue -- instance Eq,Show
+
+ -- * Operators
+ , (<>)
+ [_$_]
+ -- * Query
+ , isEmpty
+ , length
+ , head
+ , tail
+ , front
+
+ -- * Construction
+ , empty
+ , single
+ , insert
+ , append
+ [_$_]
+ -- * Filter
+ , filter
+ , partition
+
+ -- * Fold
+ , foldL
+ , foldR
+ [_$_]
+ -- * Conversion
+ , elems
+
+ -- ** List
+ , toList
+ , fromList
+ ) where
+
+import qualified Prelude as P (length,filter)
+import Prelude hiding (length,head,tail,filter)
+import qualified List
+
+-- just for testing
+-- import QuickCheck [_$_]
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixr 5 <>
+
+-- | /O(n)/. Append two queues, see 'append'.
+(<>) :: Queue a -> Queue a -> Queue a
+s <> t
+ = append s t
+
+{--------------------------------------------------------------------
+ Queue.
+ Invariants for @(Queue xs ys zs)@:
+ * @length ys <= length xs@
+ * @length zs == length xs - length ys@
+--------------------------------------------------------------------}
+-- A queue of elements @a@.
+data Queue a = Queue [a] [a] [a]
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+
+-- | /O(1)/. Is the queue empty?
+isEmpty :: Queue a -> Bool
+isEmpty (Queue xs ys zs)
+ = null xs
+
+-- | /O(n)/. The number of elements in the queue.
+length :: Queue a -> Int
+length (Queue xs ys zs)
+ = P.length xs + P.length ys
+
+-- | /O(1)/. The element in front of the queue. Raises an error
+-- when the queue is empty.
+head :: Queue a -> a
+head (Queue xs ys zs)
+ = case xs of
+ (x:xx) -> x
+ [] -> error "Queue.head: empty queue"
+
+-- | /O(1)/. The tail of the queue.
+-- Raises an error when the queue is empty.
+tail :: Queue a -> Queue a
+tail (Queue xs ys zs)
+ = case xs of
+ (x:xx) -> queue xx ys zs
+ [] -> error "Queue.tail: empty queue"
+
+-- | /O(1)/. The head and tail of the queue.
+front :: Queue a -> Maybe (a,Queue a)
+front (Queue xs ys zs)
+ = case xs of
+ (x:xx) -> Just (x,queue xx ys zs)
+ [] -> Nothing
+
+
+{--------------------------------------------------------------------
+ Construction [_$_]
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty queue.
+empty :: Queue a
+empty [_$_]
+ = Queue [] [] []
+
+-- | /O(1)/. A queue of one element.
+single :: a -> Queue a
+single x
+ = Queue [x] [] [x]
+
+-- | /O(1)/. Insert an element at the back of a queue.
+insert :: a -> Queue a -> Queue a
+insert x (Queue xs ys zs)
+ = queue xs (x:ys) zs
+
+
+-- | /O(n)/. Append two queues.
+append :: Queue a -> Queue a -> Queue a
+append (Queue xs1 ys1 zs1) (Queue xs2 ys2 zs2)
+ = Queue (xs1++xs2) (ys1++ys2) (zs1++zs2)
+
+{--------------------------------------------------------------------
+ Filter
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter elements according to some predicate.
+filter :: (a -> Bool) -> Queue a -> Queue a
+filter pred (Queue xs ys zs)
+ = balance xs' ys'
+ where
+ xs' = P.filter pred xs
+ ys' = P.filter pred ys
+
+-- | /O(n)/. Partition the elements according to some predicate.
+partition :: (a -> Bool) -> Queue a -> (Queue a,Queue a)
+partition pred (Queue xs ys zs)
+ = (balance xs1 ys1, balance xs2 ys2)
+ where
+ (xs1,xs2) = List.partition pred xs
+ (ys1,ys2) = List.partition pred ys
+
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold over the elements from left to right (ie. head to tail).
+foldL :: (b -> a -> b) -> b -> Queue a -> b
+foldL f z (Queue xs ys zs)
+ = foldr (flip f) (foldl f z xs) ys
+
+-- | /O(n)/. Fold over the elements from right to left (ie. tail to head).
+foldR :: (a -> b -> b) -> b -> Queue a -> b
+foldR f z (Queue xs ys zs)
+ = foldr f (foldl (flip f) z ys) xs
+
+
+{--------------------------------------------------------------------
+ Conversion
+--------------------------------------------------------------------}
+-- | /O(n)/. The elements of a queue.
+elems :: Queue a -> [a]
+elems q
+ = toList q
+
+-- | /O(n)/. Convert to a list.
+toList :: Queue a -> [a]
+toList (Queue xs ys zs)
+ = xs ++ reverse ys
+
+-- | /O(n)/. Convert from a list.
+fromList :: [a] -> Queue a
+fromList xs
+ = Queue xs [] xs
+
+
+{--------------------------------------------------------------------
+ instance Eq, Show
+--------------------------------------------------------------------}
+instance Eq a => Eq (Queue a) where
+ q1 == q2 = toList q1 == toList q2
+
+instance Show a => Show (Queue a) where
+ showsPrec d q = showsPrec d (toList q)
+
+
+{--------------------------------------------------------------------
+ Smart constructor:
+ Note that @(queue xs ys zs)@ is always called with [_$_]
+ @(length zs == length xs - length ys + 1)@. and thus
+ @rotate@ is always called when @(length xs == length ys+1)@.
+--------------------------------------------------------------------}
+balance :: [a] -> [a] -> Queue a
+balance xs ys
+ = Queue qs [] qs
+ where
+ qs = xs ++ reverse ys
+
+queue :: [a] -> [a] -> [a] -> Queue a
+queue xs ys (z:zs) = Queue xs ys zs
+queue xs ys [] = Queue qs [] qs
+ where
+ qs = rotate xs ys []
+
+-- @(rotate xs ys []) == xs ++ reverse ys)@ [_$_]
+rotate :: [a] -> [a] -> [a] -> [a]
+rotate [] [y] zs = y:zs
+rotate (x:xs) (y:ys) zs = x:rotate xs ys (y:zs) [_$_]
+rotate xs ys zs = error "Queue.rotate: unbalanced queue"
+
+
+valid :: Queue a -> Bool
+valid (Queue xs ys zs)
+ = (P.length zs == P.length xs - P.length ys) && (P.length ys <= P.length xs)
+
+{-
+{--------------------------------------------------------------------
+ QuickCheck
+--------------------------------------------------------------------}
+qcheck prop
+ = check config prop
+ where
+ config = Config
+ { configMaxTest = 500
+ , configMaxFail = 10000
+ , configSize = \n -> (div n 2 + 3)
+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+ }
+
+
+{--------------------------------------------------------------------
+ Arbitrary, reasonably balanced queues
+--------------------------------------------------------------------}
+instance Arbitrary a => Arbitrary (Queue a) where
+ arbitrary = do{ qs <- arbitrary
+ ; let (ys,xs) = splitAt (P.length qs `div` 2) qs
+ ; return (Queue xs ys (xs ++ reverse ys))
+ }
+
+
+prop_Valid :: Queue Int -> Bool
+prop_Valid q
+ = valid q
+
+prop_InsertLast :: [Int] -> Property
+prop_InsertLast xs
+ = not (null xs) ==> head (foldr insert empty xs) == last xs
+
+prop_InsertValid :: [Int] -> Bool
+prop_InsertValid xs
+ = valid (foldr insert empty xs)
+
+prop_Queue :: [Int] -> Bool
+prop_Queue xs
+ = toList (foldl (flip insert) empty xs) == foldr (:) [] xs
+ [_$_]
+prop_List :: [Int] -> Bool
+prop_List xs
+ = toList (fromList xs) == xs
+
+prop_TailValid :: [Int] -> Bool
+prop_TailValid xs
+ = valid (tail (foldr insert empty (1:xs)))
+-}
addfile ./lib/DData/Scc.hs
hunk ./lib/DData/Scc.hs 1
-
+--------------------------------------------------------------------------------
+{-| Module : Scc
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ Compute the /strongly connected components/ of a directed graph.
+ The implementation is based on the following article:
+
+ * David King and John Launchbury, /Lazy Depth-First Search and Linear Graph Algorithms in Haskell/,
+ ACM Principles of Programming Languages, San Francisco, 1995.
+
+ In contrast to their description, this module doesn't use lazy state
+ threads but is instead purely functional -- using the "Map" and "Set" module.
+ This means that the complexity of 'scc' is /O(n*log n)/ instead of /O(n)/ but
+ due to the hidden constant factor, this implementation performs very well in practice.
+-}
+---------------------------------------------------------------------------------}
+module Scc ( scc ) where
+
+import qualified Map [_$_]
+import qualified Set [_$_]
+
+{-
+-- just for testing
+import Debug.QuickCheck [_$_]
+import List(nub,sort) [_$_]
+-}
+
+{--------------------------------------------------------------------
+ Graph
+--------------------------------------------------------------------}
+-- | A @Graph v@ is a directed graph with nodes @v@.
+newtype Graph v = Graph (Map.Map v [v])
+
+-- | An @Edge v@ is a pair @(x,y)@ that represents an arrow from
+-- node @x@ to node @y@.
+type Edge v = (v,v)
+type Node v = (v,[v])
+
+{--------------------------------------------------------------------
+ Conversion
+--------------------------------------------------------------------}
+nodes :: Graph v -> [Node v]
+nodes (Graph g)
+ = Map.toList g
+
+graph :: Ord v => [Node v] -> Graph v
+graph es
+ = Graph (Map.fromListWith (++) es)
+
+{--------------------------------------------------------------------
+ Graph functions
+--------------------------------------------------------------------}
+edges :: Graph v -> [Edge v]
+edges g
+ = [(v,w) | (v,vs) <- nodes g, w <- vs]
+
+vertices :: Graph v -> [v]
+vertices g
+ = [v | (v,vs) <- nodes g]
+
+successors :: Ord v => v -> Graph v -> [v]
+successors v (Graph g)
+ = Map.findWithDefault [] v g
+
+transpose :: Ord v => Graph v -> Graph v
+transpose g@(Graph m)
+ = Graph (foldr add empty (edges g))
+ where
+ empty = Map.map (const []) m
+ add (v,w) m = Map.adjust (v:) w m
+
+
+{--------------------------------------------------------------------
+ Depth first search and forests
+--------------------------------------------------------------------}
+data Tree v = Node v (Forest v) [_$_]
+type Forest v = [Tree v]
+
+dff :: Ord v => Graph v -> Forest v
+dff g
+ = dfs g (vertices g)
+
+dfs :: Ord v => Graph v -> [v] -> Forest v
+dfs g vs [_$_]
+ = prune (map (tree g) vs)
+
+tree :: Ord v => Graph v -> v -> Tree v
+tree g v [_$_]
+ = Node v (map (tree g) (successors v g))
+
+prune :: Ord v => Forest v -> Forest v
+prune fs
+ = snd (chop Set.empty fs)
+ where
+ chop ms [] = (ms,[])
+ chop ms (Node v vs:fs)
+ | visited = chop ms fs
+ | otherwise = let ms0 = Set.insert v ms
+ (ms1,vs') = chop ms0 vs
+ (ms2,fs') = chop ms1 fs
+ in (ms2,Node v vs':fs')
+ where
+ visited = Set.member v ms
+
+{--------------------------------------------------------------------
+ Orderings
+--------------------------------------------------------------------}
+preorder :: Ord v => Graph v -> [v]
+preorder g
+ = preorderF (dff g)
+
+preorderF fs
+ = concatMap preorderT fs
+
+preorderT (Node v fs)
+ = v:preorderF fs
+
+postorder :: Ord v => Graph v -> [v]
+postorder g
+ = postorderF (dff g) [_$_]
+
+postorderT t
+ = postorderF [t]
+
+postorderF ts
+ = postorderF' ts []
+ where
+ -- efficient concatenation by passing the tail around.
+ postorderF' [] tl = tl
+ postorderF' (t:ts) tl = postorderT' t (postorderF' ts tl)
+ postorderT' (Node v fs) tl = postorderF' fs (v:tl)
+
+
+{--------------------------------------------------------------------
+ Strongly connected components [_$_]
+--------------------------------------------------------------------}
+
+{- | [_$_]
+ Compute the strongly connected components of a graph. The algorithm
+ is tailored toward the needs of compiler writers that need to compute
+ recursive binding groups (for example, the original order is preserved
+ as much as possible). [_$_]
+ [_$_]
+ The expression (@scc xs@) computes the strongly connectected components
+ of graph @xs@. A graph is a list of nodes @(v,ws)@ where @v@ is the node [_$_]
+ label and @ws@ a list of nodes where @v@ points to, ie. there is an [_$_]
+ arrow\/dependency from @v@ to each node in @ws@. Here is an example
+ of @scc@:
+
+> Scc\> scc [(0,[1]),(1,[1,2,3]),(2,[1]),(3,[]),(4,[])]
+> [[3],[1,2],[0],[4]]
+
+ In an expression @(scc xs)@, the graph @xs@ should contain an entry for [_$_]
+ every node in the graph, ie:
+
+> all (`elem` nodes) targets
+> where nodes = map fst xs
+> targets = concat (map snd xs)
+
+ Furthermore, the returned components consist exactly of the original nodes:
+
+> sort (concat (scc xs)) == sort (map fst xs)
+
+ The connected components are sorted by dependency, ie. there are
+ no arrows\/dependencies from left-to-right. Furthermore, the original order
+ is preserved as much as possible. [_$_]
+-}
+scc :: Ord v => [(v,[v])] -> [[v]]
+scc nodes
+ = sccG (graph nodes)
+
+sccG :: Ord v => Graph v -> [[v]]
+sccG g
+ = map preorderT (sccF g)
+
+sccF :: Ord v => Graph v -> Forest v
+sccF g [_$_]
+ = reverse (dfs (transpose g) (topsort g))
+
+topsort g
+ = reverse (postorder g)
+
+{--------------------------------------------------------------------
+ Reachable and path
+--------------------------------------------------------------------}
+reachable v g
+ = preorderF (dfs g [v])
+
+path v w g
+ = elem w (reachable v g)
+
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show v => Show (Graph v) where
+ showsPrec d (Graph m) = shows m
+ [_$_]
+instance Show v => Show (Tree v) where
+ showsPrec d (Node v []) = shows v [_$_]
+ showsPrec d (Node v fs) = shows v . showList fs
+
+
+{--------------------------------------------------------------------
+ Quick Test
+--------------------------------------------------------------------}
+tgraph0 :: Graph Int
+tgraph0 = graph [_$_]
+ [(0,[1])
+ ,(1,[2,1,3])
+ ,(2,[1])
+ ,(3,[])
+ ]
+
+tgraph1 = graph
+ [ ('a',"jg") [_$_]
+ , ('b',"ia")
+ , ('c',"he")
+ , ('d',"")
+ , ('e',"jhd")
+ , ('f',"i")
+ , ('g',"fb")
+ , ('h',"")
+ ]
+
+{-
+{--------------------------------------------------------------------
+ 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 Graph's
+--------------------------------------------------------------------}
+instance (Ord v,Arbitrary v) => Arbitrary (Graph v) where
+ arbitrary = sized arbgraph
+
+
+arbgraph :: (Ord v,Arbitrary v) => Int -> Gen (Graph v)
+arbgraph n
+ = do nodes <- arbitrary
+ g <- mapM (targets nodes) nodes
+ return (graph g)
+ where
+ targets nodes v
+ = do sz <- choose (0,length nodes-1)
+ ts <- mapM (target nodes) [1..sz]
+ return (v,ts)
+ [_$_]
+ target nodes _
+ = do idx <- choose (0,length nodes-1)
+ return (nodes!!idx)
+
+{--------------------------------------------------------------------
+ Properties
+--------------------------------------------------------------------}
+prop_ValidGraph :: Graph Int -> Bool
+prop_ValidGraph g
+ = all (`elem` srcs) targets
+ where
+ srcs = map fst (nodes g)
+ targets = concatMap snd (nodes g)
+
+-- all scc nodes are in the original graph and the other way around
+prop_SccComplete :: Graph Int -> Bool
+prop_SccComplete g
+ = sort (concat (sccG g)) == sort (vertices g)
+
+-- all scc nodes have only backward dependencies
+prop_SccForward :: Graph Int -> Bool
+prop_SccForward g
+ = all noforwards (zip prevs ss) [_$_]
+ where
+ ss = sccG g
+ prevs = scanl1 (++) ss
+
+ noforwards (prev,xs)
+ = all (noforward prev) xs
+ [_$_]
+ noforward prev x
+ = all (`elem` prev) (successors x g)
+
+-- all strongly connected components refer to each other
+prop_SccConnected :: Graph Int -> Bool
+prop_SccConnected g
+ = all connected (sccG g)
+ where
+ connected xs
+ = all (paths xs) xs
+
+ paths xs x
+ = all (\y -> path x y g) xs
+
+-}
addfile ./lib/DData/Seq.hs
hunk ./lib/DData/Seq.hs 1
+--------------------------------------------------------------------------------
+{-| Module : Seq
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ An implementation of John Hughes's efficient catenable sequence type. A lazy sequence
+ @Seq a@ can be concatenated in /O(1)/ time. After
+ construction, the sequence in converted in /O(n)/ time into a list.
+-}
+---------------------------------------------------------------------------------}
+module Seq( -- * Type
+ Seq
+ -- * Operators
+ , (<>)
+
+ -- * Construction
+ , empty
+ , single
+ , cons
+ , append
+
+ -- * Conversion
+ , toList
+ , fromList
+ ) where
+
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixr 5 <>
+
+-- | /O(1)/. Append two sequences, see 'append'.
+(<>) :: Seq a -> Seq a -> Seq a
+s <> t
+ = append s t
+
+{--------------------------------------------------------------------
+ Type
+--------------------------------------------------------------------}
+-- | Sequences of values @a@.
+newtype Seq a = Seq ([a] -> [a])
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. Create an empty sequence.
+empty :: Seq a
+empty
+ = Seq (\ts -> ts)
+
+-- | /O(1)/. Create a sequence of one element.
+single :: a -> Seq a
+single x
+ = Seq (\ts -> x:ts)
+
+-- | /O(1)/. Put a value in front of a sequence.
+cons :: a -> Seq a -> Seq a
+cons x (Seq f)
+ = Seq (\ts -> x:f ts)
+
+-- | /O(1)/. Append two sequences.
+append :: Seq a -> Seq a -> Seq a
+append (Seq f) (Seq g)
+ = Seq (\ts -> f (g ts))
+
+
+{--------------------------------------------------------------------
+ Conversion
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert a sequence to a list.
+toList :: Seq a -> [a]
+toList (Seq f)
+ = f []
+
+-- | /O(n)/. Create a sequence from a list.
+fromList :: [a] -> Seq a
+fromList xs
+ = Seq (\ts -> xs++ts)
+
+
+
+
+
+
+
+
addfile ./lib/DData/Set.hs
hunk ./lib/DData/Set.hs 1
-
+--------------------------------------------------------------------------------
+{-| Module : Set
+ Copyright : (c) Daan Leijen 2002
+ License : BSD-style
+
+ Maintainer : daan@cs.uu.nl
+ Stability : provisional
+ Portability : portable
+
+ An efficient implementation of sets. [_$_]
+
+ 1) The 'filter' function clashes with the "Prelude". [_$_]
+ If you want to use "Set" unqualified, this function should be hidden.
+
+ > import Prelude hiding (filter)
+ > import Set
+
+ Another solution is to use qualified names. This is also the only way how
+ a "Map", "Set", and "MultiSet" can be used within one module. [_$_]
+
+ > import qualified Set
+ >
+ > ... Set.single "Paris" [_$_]
+
+ Or, if you prefer a terse coding style:
+
+ > import qualified Set as S
+ >
+ > ... S.single "Berlin" [_$_]
+ [_$_]
+ 2) The implementation of "Set" is based on /size balanced/ binary trees (or
+ trees of /bounded balance/) as described by:
+
+ * Stephen Adams, \"/Efficient sets: a balancing act/\", Journal of Functional
+ Programming 3(4):553-562, October 1993, <http://www.swiss.ai.mit.edu/~adams/BB>.
+
+ * J. Nievergelt and E.M. Reingold, \"/Binary search trees of bounded balance/\",
+ SIAM journal of computing 2(1), March 1973.
+
+ 3) Note that the implementation /left-biased/ -- the elements of a first argument
+ are always perferred to the second, for example in 'union' or 'insert'.
+ Off course, left-biasing can only be observed when equality an equivalence relation
+ instead of structural equality.
+
+ 4) Another implementation of sets based on size balanced trees
+ exists as "Data.Set" in the Ghc libraries. The good part about this library [_$_]
+ is that it is highly tuned and thorougly tested. However, it is also fairly old, [_$_]
+ it is implemented indirectly on top of "Data.FiniteMap" and only supports [_$_]
+ the basic set operations. [_$_]
+ The "Set" module overcomes some of these issues:
+ [_$_]
+ * It tries to export a more complete and consistent set of operations, like
+ 'partition', 'subset' etc. [_$_]
+
+ * It uses the efficient /hedge/ algorithm for both 'union' and 'difference'
+ (a /hedge/ algorithm is not applicable to 'intersection').
+ [_$_]
+ * It converts ordered lists in linear time ('fromAscList'). [_$_]
+
+ * It takes advantage of the module system with names like 'empty' instead of 'Data.Set.emptySet'.
+ [_$_]
+ * It is implemented directly, instead of using a seperate finite map implementation. [_$_]
+-}
+---------------------------------------------------------------------------------
+module Set ( [_$_]
+ -- * Set type
+ Set -- instance Eq,Show
+
+ -- * Operators
+ , (\\)
+
+ -- * Query
+ , isEmpty
+ , size
+ , member
+ , subset
+ , properSubset
+ [_$_]
+ -- * Construction
+ , empty
+ , single
+ , insert
+ , delete
+ [_$_]
+ -- * Combine
+ , union, unions
+ , difference
+ , intersection
+ [_$_]
+ -- * Filter
+ , filter
+ , partition
+ , split
+ , splitMember
+
+ -- * Fold
+ , fold
+
+ -- * Min\/Max
+ , findMin
+ , findMax
+ , deleteMin
+ , deleteMax
+ , deleteFindMin
+ , deleteFindMax
+
+ -- * Conversion
+
+ -- ** List
+ , elems
+ , toList
+ , fromList
+ [_$_]
+ -- ** Ordered list
+ , toAscList
+ , fromAscList
+ , fromDistinctAscList
+ [_$_]
+ -- * Debugging
+ , showTree
+ , showTreeWith
+ , valid
+ ) where
+
+import Prelude hiding (filter)
+
+{-
+-- just for testing
+import QuickCheck [_$_]
+import List (nub,sort)
+import qualified List
+-}
+
+{--------------------------------------------------------------------
+ Operators
+--------------------------------------------------------------------}
+infixl 9 \\
+
+-- | /O(n+m)/. See 'difference'.
+(\\) :: Ord a => Set a -> Set a -> Set a
+m1 \\ m2 = difference m1 m2
+
+{--------------------------------------------------------------------
+ Sets are size balanced trees
+--------------------------------------------------------------------}
+-- | A set of values @a@.
+data Set a = Tip [_$_]
+ | Bin !Size a !(Set a) !(Set a) [_$_]
+
+type Size = Int
+
+{--------------------------------------------------------------------
+ Query
+--------------------------------------------------------------------}
+-- | /O(1)/. Is this the empty set?
+isEmpty :: Set a -> Bool
+isEmpty t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> False
+
+-- | /O(1)/. The number of elements in the set.
+size :: Set a -> Int
+size t
+ = case t of
+ Tip -> 0
+ Bin sz x l r -> sz
+
+-- | /O(log n)/. Is the element in the set?
+member :: Ord a => a -> Set a -> Bool
+member x t
+ = case t of
+ Tip -> False
+ Bin sz y l r
+ -> case compare x y of
+ LT -> member x l
+ GT -> member x r
+ EQ -> True [_$_]
+
+{--------------------------------------------------------------------
+ Construction
+--------------------------------------------------------------------}
+-- | /O(1)/. The empty set.
+empty :: Set a
+empty
+ = Tip
+
+-- | /O(1)/. Create a singleton set.
+single :: a -> Set a
+single x [_$_]
+ = Bin 1 x Tip Tip
+
+{--------------------------------------------------------------------
+ Insertion, Deletion
+--------------------------------------------------------------------}
+-- | /O(log n)/. Insert an element in a set.
+insert :: Ord a => a -> Set a -> Set a
+insert x t
+ = case t of
+ Tip -> single x
+ Bin sz y l r
+ -> case compare x y of
+ LT -> balance y (insert x l) r
+ GT -> balance y l (insert x r)
+ EQ -> Bin sz x l r
+
+
+-- | /O(log n)/. Delete an element from a set.
+delete :: Ord a => a -> Set a -> Set a
+delete x t
+ = case t of
+ Tip -> Tip
+ Bin sz y l r [_$_]
+ -> case compare x y of
+ LT -> balance y (delete x l) r
+ GT -> balance y l (delete x r)
+ EQ -> glue l r
+
+{--------------------------------------------------------------------
+ Subset
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).
+properSubset :: Ord a => Set a -> Set a -> Bool
+properSubset s1 s2
+ = (size s1 < size s2) && (subset s1 s2)
+
+
+-- | /O(n+m)/. Is this a subset?
+subset :: Ord a => Set a -> Set a -> Bool
+subset t1 t2
+ = (size t1 <= size t2) && (subsetX t1 t2)
+
+subsetX Tip t = True
+subsetX t Tip = False
+subsetX (Bin _ x l r) t
+ = found && subsetX l lt && subsetX r gt
+ where
+ (found,lt,gt) = splitMember x t
+
+
+{--------------------------------------------------------------------
+ Minimal, Maximal
+--------------------------------------------------------------------}
+-- | /O(log n)/. The minimal element of a set.
+findMin :: Set a -> a
+findMin (Bin _ x Tip r) = x
+findMin (Bin _ x l r) = findMin l
+findMin Tip = error "Set.findMin: empty set has no minimal element"
+
+-- | /O(log n)/. The maximal element of a set.
+findMax :: Set a -> a
+findMax (Bin _ x l Tip) = x
+findMax (Bin _ x l r) = findMax r
+findMax Tip = error "Set.findMax: empty set has no maximal element"
+
+-- | /O(log n)/. Delete the minimal element.
+deleteMin :: Set a -> Set a
+deleteMin (Bin _ x Tip r) = r
+deleteMin (Bin _ x l r) = balance x (deleteMin l) r
+deleteMin Tip = Tip
+
+-- | /O(log n)/. Delete the maximal element.
+deleteMax :: Set a -> Set a
+deleteMax (Bin _ x l Tip) = l
+deleteMax (Bin _ x l r) = balance x l (deleteMax r)
+deleteMax Tip = Tip
+
+
+{--------------------------------------------------------------------
+ Union. [_$_]
+--------------------------------------------------------------------}
+-- | The union of a list of sets: (@unions == foldl union empty@).
+unions :: Ord a => [Set a] -> Set a
+unions ts
+ = foldlStrict union empty ts
+
+
+-- | /O(n+m)/. The union of two sets. Uses the efficient /hedge-union/ algorithm.
+union :: Ord a => Set a -> Set a -> Set a
+union Tip t2 = t2
+union t1 Tip = t1
+union t1 t2 -- hedge-union is more efficient on (bigset `union` smallset)
+ | size t1 >= size t2 = hedgeUnion (const LT) (const GT) t1 t2
+ | otherwise = hedgeUnion (const LT) (const GT) t2 t1
+
+hedgeUnion cmplo cmphi t1 Tip [_$_]
+ = t1
+hedgeUnion cmplo cmphi Tip (Bin _ x l r)
+ = join x (filterGt cmplo l) (filterLt cmphi r)
+hedgeUnion cmplo cmphi (Bin _ x l r) t2
+ = join x (hedgeUnion cmplo cmpx l (trim cmplo cmpx t2)) [_$_]
+ (hedgeUnion cmpx cmphi r (trim cmpx cmphi t2))
+ where
+ cmpx y = compare x y
+
+{--------------------------------------------------------------------
+ Difference
+--------------------------------------------------------------------}
+-- | /O(n+m)/. Difference of two sets. [_$_]
+-- The implementation uses an efficient /hedge/ algorithm comparable with /hedge-union/.
+difference :: Ord a => Set a -> Set a -> Set a
+difference Tip t2 = Tip
+difference t1 Tip = t1
+difference t1 t2 = hedgeDiff (const LT) (const GT) t1 t2
+
+hedgeDiff cmplo cmphi Tip t [_$_]
+ = Tip
+hedgeDiff cmplo cmphi (Bin _ x l r) Tip [_$_]
+ = join x (filterGt cmplo l) (filterLt cmphi r)
+hedgeDiff cmplo cmphi t (Bin _ x l r) [_$_]
+ = merge (hedgeDiff cmplo cmpx (trim cmplo cmpx t) l) [_$_]
+ (hedgeDiff cmpx cmphi (trim cmpx cmphi t) r)
+ where
+ cmpx y = compare x y
+
+{--------------------------------------------------------------------
+ Intersection
+--------------------------------------------------------------------}
+-- | /O(n+m)/. The intersection of two sets.
+intersection :: Ord a => Set a -> Set a -> Set a
+intersection Tip t = Tip
+intersection t Tip = Tip
+intersection t1 t2 -- intersection is more efficient on (bigset `intersection` smallset)
+ | size t1 >= size t2 = intersect t1 t2
+ | otherwise = intersect t2 t1
+
+intersect Tip t = Tip
+intersect t Tip = Tip
+intersect t (Bin _ x l r)
+ | found = join x tl tr
+ | otherwise = merge tl tr
+ where
+ (found,lt,gt) = splitMember x t
+ tl = intersect lt l
+ tr = intersect gt r
+
+
+{--------------------------------------------------------------------
+ Filter and partition
+--------------------------------------------------------------------}
+-- | /O(n)/. Filter all elements that satisfy the predicate.
+filter :: Ord a => (a -> Bool) -> Set a -> Set a
+filter p Tip = Tip
+filter p (Bin _ x l r)
+ | p x = join x (filter p l) (filter p r)
+ | otherwise = merge (filter p l) (filter p r)
+
+-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy
+-- the predicate and one with all elements that don't satisfy the predicate.
+-- See also 'split'.
+partition :: Ord a => (a -> Bool) -> Set a -> (Set a,Set a)
+partition p Tip = (Tip,Tip)
+partition p (Bin _ x l r)
+ | p x = (join x l1 r1,merge l2 r2)
+ | otherwise = (merge l1 r1,join x l2 r2)
+ where
+ (l1,l2) = partition p l
+ (r1,r2) = partition p r
+
+{--------------------------------------------------------------------
+ Fold
+--------------------------------------------------------------------}
+-- | /O(n)/. Fold the elements of a set.
+fold :: (a -> b -> b) -> b -> Set a -> b
+fold f z s
+ = foldR f z s
+
+-- | /O(n)/. Post-order fold.
+foldR :: (a -> b -> b) -> b -> Set a -> b
+foldR f z Tip = z
+foldR f z (Bin _ x l r) = foldR f (f x (foldR f z r)) l
+
+
+{--------------------------------------------------------------------
+ List variations [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. The elements of a set.
+elems :: Set a -> [a]
+elems s
+ = toList s
+
+{--------------------------------------------------------------------
+ Lists [_$_]
+--------------------------------------------------------------------}
+-- | /O(n)/. Convert the set to a list of elements.
+toList :: Set a -> [a]
+toList s
+ = toAscList s
+
+-- | /O(n)/. Convert the set to an ascending list of elements.
+toAscList :: Set a -> [a]
+toAscList t [_$_]
+ = foldR (:) [] t
+
+
+-- | /O(n*log n)/. Create a set from a list of elements.
+fromList :: Ord a => [a] -> Set a [_$_]
+fromList xs [_$_]
+ = foldlStrict ins empty xs
+ where
+ ins t x = insert x t
+
+{--------------------------------------------------------------------
+ Building trees from ascending/descending lists can be done in linear time.
+ [_$_]
+ Note that if [xs] is ascending that: [_$_]
+ fromAscList xs == fromList xs
+--------------------------------------------------------------------}
+-- | /O(n)/. Build a map from an ascending list in linear time.
+fromAscList :: Eq a => [a] -> Set a [_$_]
+fromAscList xs
+ = fromDistinctAscList (combineEq xs)
+ where
+ -- [combineEq xs] combines equal elements with [const] in an ordered list [xs]
+ combineEq xs
+ = case xs of
+ [] -> []
+ [x] -> [x]
+ (x:xx) -> combineEq' x xx
+
+ combineEq' z [] = [z]
+ combineEq' z (x:xs)
+ | z==x = combineEq' z xs
+ | otherwise = z:combineEq' x xs
+
+
+-- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.
+fromDistinctAscList :: [a] -> Set a [_$_]
+fromDistinctAscList xs
+ = build const (length xs) xs
+ where
+ -- 1) use continutations so that we use heap space instead of stack space.
+ -- 2) special case for n==5 to build bushier trees. [_$_]
+ build c 0 xs = c Tip xs [_$_]
+ build c 5 xs = case xs of
+ (x1:x2:x3:x4:x5:xx) [_$_]
+ -> c (bin x4 (bin x2 (single x1) (single x3)) (single x5)) xx
+ build c n xs = seq nr $ build (buildR nr c) nl xs
+ where
+ nl = n `div` 2
+ nr = n - nl - 1
+
+ buildR n c l (x:ys) = build (buildB l x c) n ys
+ buildB l x c r zs = c (bin x l r) zs
+
+{--------------------------------------------------------------------
+ Eq converts the set to a list. In a lazy setting, this [_$_]
+ actually seems one of the faster methods to compare two trees [_$_]
+ and it is certainly the simplest :-)
+--------------------------------------------------------------------}
+instance Eq a => Eq (Set a) where
+ t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+
+{--------------------------------------------------------------------
+ Show
+--------------------------------------------------------------------}
+instance Show a => Show (Set a) where
+ showsPrec d s = showSet (toAscList s)
+
+showSet :: (Show a) => [a] -> ShowS
+showSet [] [_$_]
+ = showString "{}" [_$_]
+showSet (x:xs) [_$_]
+ = showChar '{' . shows x . showTail xs
+ where
+ showTail [] = showChar '}'
+ showTail (x:xs) = showChar ',' . shows x . showTail xs
+ [_$_]
+
+{--------------------------------------------------------------------
+ Utility functions that return sub-ranges of the original
+ tree. Some functions take a comparison function as argument to
+ allow comparisons against infinite values. A function [cmplo x]
+ should be read as [compare lo x].
+
+ [trim cmplo cmphi t] A tree that is either empty or where [cmplo x == LT]
+ and [cmphi x == GT] for the value [x] of the root.
+ [filterGt cmp t] A tree where for all values [k]. [cmp k == LT]
+ [filterLt cmp t] A tree where for all values [k]. [cmp k == GT]
+
+ [split k t] Returns two trees [l] and [r] where all values
+ in [l] are <[k] and all keys in [r] are >[k].
+ [splitMember k t] Just like [split] but also returns whether [k]
+ was found in the tree.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ [trim lo hi t] trims away all subtrees that surely contain no
+ values between the range [lo] to [hi]. The returned tree is either
+ empty or the key of the root is between @lo@ and @hi@.
+--------------------------------------------------------------------}
+trim :: (a -> Ordering) -> (a -> Ordering) -> Set a -> Set a
+trim cmplo cmphi Tip = Tip
+trim cmplo cmphi t@(Bin sx x l r)
+ = case cmplo x of
+ LT -> case cmphi x of
+ GT -> t
+ le -> trim cmplo cmphi l
+ ge -> trim cmplo cmphi r
+ [_$_]
+trimMemberLo :: Ord a => a -> (a -> Ordering) -> Set a -> (Bool, Set a)
+trimMemberLo lo cmphi Tip = (False,Tip)
+trimMemberLo lo cmphi t@(Bin sx x l r)
+ = case compare lo x of
+ LT -> case cmphi x of
+ GT -> (member lo t, t)
+ le -> trimMemberLo lo cmphi l
+ GT -> trimMemberLo lo cmphi r
+ EQ -> (True,trim (compare lo) cmphi r)
+
+
+{--------------------------------------------------------------------
+ [filterGt x t] filter all values >[x] from tree [t]
+ [filterLt x t] filter all values <[x] from tree [t]
+--------------------------------------------------------------------}
+filterGt :: (a -> Ordering) -> Set a -> Set a
+filterGt cmp Tip = Tip
+filterGt cmp (Bin sx x l r)
+ = case cmp x of
+ LT -> join x (filterGt cmp l) r
+ GT -> filterGt cmp r
+ EQ -> r
+ [_$_]
+filterLt :: (a -> Ordering) -> Set a -> Set a
+filterLt cmp Tip = Tip
+filterLt cmp (Bin sx x l r)
+ = case cmp x of
+ LT -> filterLt cmp l
+ GT -> join x l (filterLt cmp r)
+ EQ -> l
+
+
+{--------------------------------------------------------------------
+ Split
+--------------------------------------------------------------------}
+-- | /O(log n)/. The expression (@split x set@) is a pair @(set1,set2)@
+-- where all elements in @set1@ are lower than @x@ and all elements in
+-- @set2@ larger than @x@.
+split :: Ord a => a -> Set a -> (Set a,Set a)
+split x Tip = (Tip,Tip)
+split x (Bin sy y l r)
+ = case compare x y of
+ LT -> let (lt,gt) = split x l in (lt,join y gt r)
+ GT -> let (lt,gt) = split x r in (join y l lt,gt)
+ EQ -> (l,r)
+
+-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
+-- element was found in the original set.
+splitMember :: Ord a => a -> Set a -> (Bool,Set a,Set a)
+splitMember x Tip = (False,Tip,Tip)
+splitMember x (Bin sy y l r)
+ = case compare x y of
+ LT -> let (found,lt,gt) = splitMember x l in (found,lt,join y gt r)
+ GT -> let (found,lt,gt) = splitMember x r in (found,join y l lt,gt)
+ EQ -> (True,l,r)
+
+{--------------------------------------------------------------------
+ Utility functions that maintain the balance properties of the tree.
+ All constructors assume that all values in [l] < [x] and all values
+ in [r] > [x], and that [l] and [r] are valid trees.
+ [_$_]
+ In order of sophistication:
+ [Bin sz x l r] The type constructor.
+ [bin x l r] Maintains the correct size, assumes that both [l]
+ and [r] are balanced with respect to each other.
+ [balance x l r] Restores the balance and size.
+ Assumes that the original tree was balanced and
+ that [l] or [r] has changed by at most one element.
+ [join x l r] Restores balance and size. [_$_]
+
+ Furthermore, we can construct a new tree from two trees. Both operations
+ assume that all values in [l] < all values in [r] and that [l] and [r]
+ are valid:
+ [glue l r] Glues [l] and [r] together. Assumes that [l] and
+ [r] are already balanced with respect to each other.
+ [merge l r] Merges two trees and restores balance.
+
+ Note: in contrast to Adam's paper, we use (<=) comparisons instead
+ of (<) comparisons in [join], [merge] and [balance]. [_$_]
+ Quickcheck (on [difference]) showed that this was necessary in order [_$_]
+ to maintain the invariants. It is quite unsatisfactory that I haven't [_$_]
+ been able to find out why this is actually the case! Fortunately, it [_$_]
+ doesn't hurt to be a bit more conservative.
+--------------------------------------------------------------------}
+
+{--------------------------------------------------------------------
+ Join [_$_]
+--------------------------------------------------------------------}
+join :: a -> Set a -> Set a -> Set a
+join x Tip r = insertMin x r
+join x l Tip = insertMax x l
+join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)
+ | delta*sizeL <= sizeR = balance z (join x l lz) rz
+ | delta*sizeR <= sizeL = balance y ly (join x ry r)
+ | otherwise = bin x l r
+
+
+-- insertMin and insertMax don't perform potentially expensive comparisons.
+insertMax,insertMin :: a -> Set a -> Set a [_$_]
+insertMax x t
+ = case t of
+ Tip -> single x
+ Bin sz y l r
+ -> balance y l (insertMax x r)
+ [_$_]
+insertMin x t
+ = case t of
+ Tip -> single x
+ Bin sz y l r
+ -> balance y (insertMin x l) r
+ [_$_]
+{--------------------------------------------------------------------
+ [merge l r]: merges two trees.
+--------------------------------------------------------------------}
+merge :: Set a -> Set a -> Set a
+merge Tip r = r
+merge l Tip = l
+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)
+ | delta*sizeL <= sizeR = balance y (merge l ly) ry
+ | delta*sizeR <= sizeL = balance x lx (merge rx r)
+ | otherwise = glue l r
+
+{--------------------------------------------------------------------
+ [glue l r]: glues two trees together.
+ Assumes that [l] and [r] are already balanced with respect to each other.
+--------------------------------------------------------------------}
+glue :: Set a -> Set a -> Set a
+glue Tip r = r
+glue l Tip = l
+glue l r [_$_]
+ | size l > size r = let (m,l') = deleteFindMax l in balance m l' r
+ | otherwise = let (m,r') = deleteFindMin r in balance m l r'
+
+
+-- | /O(log n)/. Delete and find the minimal element.
+deleteFindMin :: Set a -> (a,Set a)
+deleteFindMin t [_$_]
+ = case t of
+ Bin _ x Tip r -> (x,r)
+ Bin _ x l r -> let (xm,l') = deleteFindMin l in (xm,balance x l' r)
+ Tip -> (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)
+
+-- | /O(log n)/. Delete and find the maximal element.
+deleteFindMax :: Set a -> (a,Set a)
+deleteFindMax t
+ = case t of
+ Bin _ x l Tip -> (x,l)
+ Bin _ x l r -> let (xm,r') = deleteFindMax r in (xm,balance x l r')
+ Tip -> (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)
+
+
+{--------------------------------------------------------------------
+ [balance x l r] balances two trees with value x.
+ The sizes of the trees should balance after decreasing the
+ size of one of them. (a rotation).
+
+ [delta] is the maximal relative difference between the sizes of
+ two trees, it corresponds with the [w] in Adams' paper,
+ or equivalently, [1/delta] corresponds with the $\alpha$
+ in Nievergelt's paper. Adams shows that [delta] should
+ be larger than 3.745 in order to garantee that the
+ rotations can always restore balance. [_$_]
+
+ [ratio] is the ratio between an outer and inner sibling of the
+ heavier subtree in an unbalanced setting. It determines
+ whether a double or single rotation should be performed
+ to restore balance. It is correspondes with the inverse
+ of $\alpha$ in Adam's article.
+
+ Note that:
+ - [delta] should be larger than 4.646 with a [ratio] of 2.
+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.
+ [_$_]
+ - A lower [delta] leads to a more 'perfectly' balanced tree.
+ - A higher [delta] performs less rebalancing.
+
+ - Balancing is automatic for random data and a balancing
+ scheme is only necessary to avoid pathological worst cases.
+ Almost any choice will do in practice
+ [_$_]
+ - Allthough it seems that a rather large [delta] may perform better [_$_]
+ than smaller one, measurements have shown that the smallest [delta]
+ of 4 is actually the fastest on a wide range of operations. It
+ especially improves performance on worst-case scenarios like
+ a sequence of ordered insertions.
+
+ Note: in contrast to Adams' paper, we use a ratio of (at least) 2
+ to decide whether a single or double rotation is needed. Allthough
+ he actually proves that this ratio is needed to maintain the
+ invariants, his implementation uses a (invalid) ratio of 1. [_$_]
+ He is aware of the problem though since he has put a comment in his [_$_]
+ original source code that he doesn't care about generating a [_$_]
+ slightly inbalanced tree since it doesn't seem to matter in practice. [_$_]
+ However (since we use quickcheck :-) we will stick to strictly balanced [_$_]
+ trees.
+--------------------------------------------------------------------}
+delta,ratio :: Int
+delta = 4
+ratio = 2
+
+balance :: a -> Set a -> Set a -> Set a
+balance x l r
+ | sizeL + sizeR <= 1 = Bin sizeX x l r
+ | sizeR >= delta*sizeL = rotateL x l r
+ | sizeL >= delta*sizeR = rotateR x l r
+ | otherwise = Bin sizeX x l r
+ where
+ sizeL = size l
+ sizeR = size r
+ sizeX = sizeL + sizeR + 1
+
+-- rotate
+rotateL x l r@(Bin _ _ ly ry)
+ | size ly < ratio*size ry = singleL x l r
+ | otherwise = doubleL x l r
+
+rotateR x l@(Bin _ _ ly ry) r
+ | size ry < ratio*size ly = singleR x l r
+ | otherwise = doubleR x l r
+
+-- basic rotations
+singleL x1 t1 (Bin _ x2 t2 t3) = bin x2 (bin x1 t1 t2) t3
+singleR x1 (Bin _ x2 t1 t2) t3 = bin x2 t1 (bin x1 t2 t3)
+
+doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)
+doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)
+
+
+{--------------------------------------------------------------------
+ The bin constructor maintains the size of the tree
+--------------------------------------------------------------------}
+bin :: a -> Set a -> Set a -> Set a
+bin x l r
+ = Bin (size l + size r + 1) x l r
+
+
+{--------------------------------------------------------------------
+ Utilities
+--------------------------------------------------------------------}
+foldlStrict f z xs
+ = case xs of
+ [] -> z
+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)
+
+
+{--------------------------------------------------------------------
+ Debugging
+--------------------------------------------------------------------}
+-- | /O(n)/. Show the tree that implements the set. The tree is shown
+-- in a compressed, hanging format.
+showTree :: Show a => Set a -> String
+showTree s
+ = showTreeWith True False s
+
+
+{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+ the tree that implements the set. 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.
+
+> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]
+> 4
+> +--2
+> | +--1
+> | +--3
+> +--5
+> [_$_]
+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]
+> 4
+> |
+> +--2
+> | |
+> | +--1
+> | |
+> | +--3
+> |
+> +--5
+> [_$_]
+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]
+> +--5
+> |
+> 4
+> |
+> | +--3
+> | |
+> +--2
+> |
+> +--1
+
+-}
+showTreeWith :: Show a => Bool -> Bool -> Set a -> String
+showTreeWith hang wide t
+ | hang = (showsTreeHang wide [] t) ""
+ | otherwise = (showsTree wide [] [] t) ""
+
+showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS
+showsTree wide lbars rbars t
+ = case t of
+ Tip -> showsBars lbars . showString "|\n"
+ Bin sz x Tip Tip
+ -> showsBars lbars . shows x . showString "\n" [_$_]
+ Bin sz x l r
+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .
+ showWide wide rbars .
+ showsBars lbars . shows x . showString "\n" .
+ showWide wide lbars .
+ showsTree wide (withEmpty lbars) (withBar lbars) l
+
+showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS
+showsTreeHang wide bars t
+ = case t of
+ Tip -> showsBars bars . showString "|\n" [_$_]
+ Bin sz x Tip Tip
+ -> showsBars bars . shows x . showString "\n" [_$_]
+ Bin sz x l r
+ -> showsBars bars . shows x . showString "\n" . [_$_]
+ showWide wide bars .
+ showsTreeHang wide (withBar bars) l .
+ showWide wide bars .
+ showsTreeHang wide (withEmpty bars) r
+
+
+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
+
+{--------------------------------------------------------------------
+ Assertions
+--------------------------------------------------------------------}
+-- | /O(n)/. Test if the internal set structure is valid.
+valid :: Ord a => Set a -> Bool
+valid t
+ = balanced t && ordered t && validsize t
+
+ordered t
+ = bounded (const True) (const True) t
+ where
+ bounded lo hi t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r
+
+balanced :: Set a -> Bool
+balanced t
+ = case t of
+ Tip -> True
+ Bin sz x l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&
+ balanced l && balanced r
+
+
+validsize t
+ = (realsize t == Just (size t))
+ where
+ realsize t
+ = case t of
+ Tip -> Just 0
+ Bin sz x l r -> case (realsize l,realsize r) of
+ (Just n,Just m) | n+m+1 == sz -> Just sz
+ other -> Nothing
+
+{-
+{--------------------------------------------------------------------
+ Testing
+--------------------------------------------------------------------}
+testTree :: [Int] -> Set Int
+testTree xs = fromList 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 (Enum a) => Arbitrary (Set a) where
+ arbitrary = sized (arbtree 0 maxkey)
+ where maxkey = 10000
+
+arbtree :: (Enum a) => Int -> Int -> Int -> Gen (Set a)
+arbtree lo hi n
+ | n <= 0 = return Tip
+ | lo >= hi = return Tip
+ | otherwise = do{ i <- choose (lo,hi)
+ ; m <- choose (1,30)
+ ; let (ml,mr) | m==(1::Int)= (1,2)
+ | m==2 = (2,1)
+ | m==3 = (1,1)
+ | otherwise = (2,2)
+ ; l <- arbtree lo (i-1) (n `div` ml)
+ ; r <- arbtree (i+1) hi (n `div` mr)
+ ; return (bin (toEnum i) l r)
+ } [_$_]
+
+
+{--------------------------------------------------------------------
+ Valid tree's
+--------------------------------------------------------------------}
+forValid :: (Enum a,Show a,Testable b) => (Set a -> b) -> Property
+forValid f
+ = forAll arbitrary $ \t -> [_$_]
+-- classify (balanced t) "balanced" $
+ classify (size t == 0) "empty" $
+ classify (size t > 0 && size t <= 10) "small" $
+ classify (size t > 10 && size t <= 64) "medium" $
+ classify (size t > 64) "large" $
+ balanced t ==> f t
+
+forValidIntTree :: Testable a => (Set Int -> a) -> Property
+forValidIntTree f
+ = forValid f
+
+forValidUnitTree :: Testable a => (Set Int -> a) -> Property
+forValidUnitTree f
+ = forValid f
+
+
+prop_Valid [_$_]
+ = forValidUnitTree $ \t -> valid t
+
+{--------------------------------------------------------------------
+ Single, Insert, Delete
+--------------------------------------------------------------------}
+prop_Single :: Int -> Bool
+prop_Single x
+ = (insert x empty == single x)
+
+prop_InsertValid :: Int -> Property
+prop_InsertValid k
+ = forValidUnitTree $ \t -> valid (insert k t)
+
+prop_InsertDelete :: Int -> Set Int -> Property
+prop_InsertDelete k t
+ = not (member k t) ==> delete k (insert k t) == t
+
+prop_DeleteValid :: Int -> Property
+prop_DeleteValid k
+ = forValidUnitTree $ \t -> [_$_]
+ valid (delete k (insert k t))
+
+{--------------------------------------------------------------------
+ Balance
+--------------------------------------------------------------------}
+prop_Join :: Int -> Property [_$_]
+prop_Join x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (join x l r)
+
+prop_Merge :: Int -> Property [_$_]
+prop_Merge x
+ = forValidUnitTree $ \t ->
+ let (l,r) = split x t
+ in valid (merge l r)
+
+
+{--------------------------------------------------------------------
+ Union
+--------------------------------------------------------------------}
+prop_UnionValid :: Property
+prop_UnionValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (union t1 t2)
+
+prop_UnionInsert :: Int -> Set Int -> Bool
+prop_UnionInsert x t
+ = union t (single x) == insert x t
+
+prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool
+prop_UnionAssoc t1 t2 t3
+ = union t1 (union t2 t3) == union (union t1 t2) t3
+
+prop_UnionComm :: Set Int -> Set Int -> Bool
+prop_UnionComm t1 t2
+ = (union t1 t2 == union t2 t1)
+
+
+prop_DiffValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (difference t1 t2)
+
+prop_Diff :: [Int] -> [Int] -> Bool
+prop_Diff xs ys
+ = toAscList (difference (fromList xs) (fromList ys))
+ == List.sort ((List.\\) (nub xs) (nub ys))
+
+prop_IntValid
+ = forValidUnitTree $ \t1 ->
+ forValidUnitTree $ \t2 ->
+ valid (intersection t1 t2)
+
+prop_Int :: [Int] -> [Int] -> Bool
+prop_Int xs ys
+ = toAscList (intersection (fromList xs) (fromList ys))
+ == List.sort (nub ((List.intersect) (xs) (ys)))
+
+{--------------------------------------------------------------------
+ Lists
+--------------------------------------------------------------------}
+prop_Ordered
+ = forAll (choose (5,100)) $ \n ->
+ let xs = [0..n::Int]
+ in fromAscList xs == fromList xs
+
+prop_List :: [Int] -> Bool
+prop_List xs
+ = (sort (nub xs) == toList (fromList xs))
+-}
addfile ./src/Colors.hs
hunk ./src/Colors.hs 1
+module Colors where
+
+import Graphics.UI.WX
+
+nodeColor, labelBackgroundColor, evidenceColor, evidenceHatchColor,
+ wrongProbabilitiesColor, paneBackgroundColor, activeSelectionColor,
+ inactiveSelectionColor :: Color
+nodeColor = lightBlue
+evidenceColor = lightYellow
+evidenceHatchColor = black
+labelBackgroundColor = lightYellow
+paneBackgroundColor = white
+activeSelectionColor = black
+inactiveSelectionColor = lightGrey
+wrongProbabilitiesColor = lightRed
+
+testSelectionTestColor, testSelectionTargetColor :: Color
+testSelectionTestColor = rgb 0 255 0
+testSelectionTargetColor = rgb 255 0 0
+
+lightYellow, lightBlue, lightRed, lightGrey, systemGrey, pink :: Color
+lightYellow = rgb 236 236 169
+lightBlue = rgb 200 255 255
+lightGrey = rgb 150 150 150
+lightRed = rgb 255 200 200
+systemGrey = colorSystem Color3DFace
+pink = rgb 255 200 200
+
+
+darkGreen, darkBlue, violet, indigo, darkRed, darkMagenta, darkOrange,
+ orange, lightPink, purple, lightGreen, mediumPurple, darkViolet, gray,
+ darkGrey, darkGray, lightGray, silver, whiteSmoke, aqua, teal, maroon,
+ olive, sienna, brown, fuchsia, turquoise, orangeRed, gold,darkSlateGray :: Color
+darkGreen = rgb 0 100 0
+darkBlue = rgb 0 0 139
+violet = rgb 238 130 238
+indigo = rgb 75 0 130
+darkRed = rgb 139 0 0
+darkMagenta = rgb 139 0 139
+darkOrange = rgb 255 140 0
+orange = rgb 255 165 0
+lightPink = rgb 255 182 193
+purple = rgb 128 0 128
+lightGreen = rgb 144 238 144
+mediumPurple = rgb 147 112 219
+darkViolet = rgb 148 0 211
+
+gray = rgb 128 128 128
+darkGrey = rgb 169 169 169 -- ligher than grey?
+darkGray = rgb 169 169 169
+lightGray = rgb 211 211 211
+silver = rgb 192 192 192
+whiteSmoke = rgb 245 245 245
+
+aqua = rgb 0 255 255
+teal = rgb 0 128 128
+maroon = rgb 128 0 0
+olive = rgb 128 128 0
+sienna = rgb 160 82 45
+brown = rgb 165 42 42
+fuchsia = rgb 255 0 255
+turquoise = rgb 64 224 208
+orangeRed = rgb 255 69 0
+gold = rgb 255 215 0
+darkSlateGray = rgb 47 79 79
addfile ./src/Common.hs
hunk ./src/Common.hs 1
+module Common (module Common, module IOExts, module Colors) where
+
+import Colors
+import IOExts(trace)
+import qualified IntMap
+import Char(isSpace)
+import GHC.Float(formatRealFloat, FFFormat(FFFixed))
+import List
+
+-- | return a list of all cartesian products for a list of lists
+-- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]]
+products :: [[a]] -> [[a]]
+products [] = [[]]
+products (xs:xss) = [ x:prod | x <- xs, prod <- products xss]
+
+trees :: Show a => String -> a -> a
+trees msg a = trace ("{" ++ msg ++ ":" ++ show a ++ "}") a
+
+foreach :: Monad m => [a] -> (a -> m b) -> m [b]
+foreach = flip mapM
+
+foreach_ :: Monad m => [a] -> (a -> m b) -> m ()
+foreach_ list fun = do
+ mapM fun list
+ return ()
+
+ifJust :: Monad m => Maybe a -> (a -> m b) -> m ()
+ifJust ma f =
+ case ma of
+ Nothing -> return ()
+ Just a -> do { f a; return () }
+
+internalError :: String -> String -> String -> a
+
+internalError moduleName functionName errorString =
+ error (moduleName ++ "." ++ functionName ++ ": " ++ errorString)
+
+parseDouble :: String -> Maybe Double
+parseDouble string =
+ case reads (commasToDots . trim $ string) of
+ ((double, []):_) -> Just double
+ _ -> Nothing
+ where
+ commasToDots = map (\c -> if c == ',' then '.' else c)
+
+trim :: String -> String
+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+-- | A NumberMap maps integers to integers
+type NumberMap = IntMap.IntMap Int
+
+-- | A NumberMap can be inverted (keys become values and values become keys)
+invertMap :: NumberMap -> NumberMap
+invertMap theMap =
+ let list = IntMap.toList theMap
+ invertedList = map (\(x, y) -> (y, x)) list
+ in IntMap.fromList invertedList
+
+-- | commasAnd combines a list of strings to one string by placing
+-- commas in between and the word "and" just before the last element
+commasAnd :: [String] -> String
+commasAnd [] = ""
+commasAnd [x] = x
+commasAnd [x, y] = x ++ " and " ++ y
+commasAnd (x:xs) = x ++ ", " ++ commasAnd xs
+
+
+-- TODO: is niceFloat 2 0.0001 = "0.0" correct? (as opposed to "0.00")
+-- | niceFloat prints a floating-point value with maximum
+-- number of decimals
+niceFloat :: Int -> Double -> String
+niceFloat nrOfDigits f =
+ let s = formatRealFloat FFFixed (Just nrOfDigits) f
+ s' = reverse s -- s -- dropWhile (== '0') (reverse s)
+ s'' = if head s' == '.' then '0':s' else s'
+ in reverse s''
+
+-- | niceFloatFix prints a floating-point value with fixed
+-- number of decimals
+niceFloatFix :: Int -> Double -> String
+niceFloatFix nrOfDigits f =
+ let s = formatRealFloat FFFixed (Just nrOfDigits) f
+ in if head s == '.' then '0':s else s
+
+-- Compute the average of a list of fractionals, with average [] equal to 0.
+average :: Fractional a => [a] -> a
+average [] = 0
+average xs = (sum xs) / fromIntegral (length xs)
+
+-- | updateList changes the element at the given zero-based index in a list
+-- Example: updateList 2 "yes" ["no","maybe","often","always"] ==>
+-- ["no","maybe","yes","always"]
+updateList :: Int -> a -> [a] -> [a]
+updateList i x l = take i l ++ [x] ++ drop (i+1) l
+
+-- | groups splits a list into groups of given length. The
+-- last group might be shorter.
+-- Example: groups 3 [1..10] ==> [[1,2,3],[4,5,6],[7,8,9],[10]]
+groups :: Int -> [a] -> [[a]]
+groups _ [] = []
+groups n xs = let (col, rest) = splitAt n xs
+ in col: groups n rest
+
+swap :: (a, b) -> (b, a)
+swap (a, b) = (b, a)
+
+-- remove the extension from a file name (or path).
+removeExtension :: String -> String
+removeExtension filename =
+ case break (=='.') $ reverse filename of
+ (_ , _ {- dot -}:properName) -> reverse properName
+ (_ , []) -> filename
+
+tabDelimited :: [[String]] -> String
+tabDelimited = unlines . map (concat . intersperse "\t")
+
+singleton :: a -> [a]
+singleton x = [x]
+
+-- | a version of Prelude.lookup that fails when the element is not present in the assoc-list
+unsafeLookup :: (Show k, Eq k) => k -> [(k,v)] -> v
+unsafeLookup x assocs =
+ case lookup x assocs of
+ Just v -> v
+ Nothing -> internalError "Common" "unsafeLookup" ("element " ++ show x ++ " not in list.")
+
+-- | a version of Prelude.elemIndex that fails when the element is not present in the list
+unsafeElemIndex :: (Show a, Eq a) => a -> [a] -> Int
+unsafeElemIndex x xs =
+ case elemIndex x xs of
+ Just i -> i
+ Nothing -> internalError "Common" "unsafeElemIndex" ("element " ++ show x ++ " not in list")
+
+-- Approximately equals
+(~=) :: Double -> Double -> Bool
+(~=) d1 d2 = abs (d1 - d2) < 0.000001
+
+fst3 :: (a, b, c) -> a
+fst3 (a, _, _) = a
+
+snd3 :: (a, b, c) -> b
+snd3 (_, b, _) = b
+
+thd3 :: (a, b, c) -> c
+thd3 (_, _, c) = c
+
+safeIndex :: String -> [a] -> Int -> a
+safeIndex msg xs i
+ | i >= 0 && i < length xs = xs !! i
+ | otherwise = internalError "Common" "safeIndex" msg
+
+-- reorderList [0,2,1] "hoi" ==> "hio"
+reorderList :: Show a => [Int] -> [a] -> [a]
+reorderList order xs
+ | sort order /= [0..length xs-1] =
+ internalError "Common" "reorderList" ("order = " ++ show order ++ ", list = " ++ show xs)
+ | otherwise =
+ [ xs !! i | i <- order ]
addfile ./src/CommonIO.hs
hunk ./src/CommonIO.hs 1
+module CommonIO where
+
+import Math
+import Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey)
+import SafetyNet
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+import List(elemIndex)
+import System.Directory
+import System.IO
+
+ignoreResult :: IO a -> IO ()
+ignoreResult action = do { action; return () }
+
+-- | Writes file to disk. If writing fails, an error
+-- dialog is shown and False is returned
+safeWriteFile :: Window a -> String -> String -> IO Bool
+safeWriteFile parentWindow fileName contents =
+ do{ let tmpName = fileName ++ ".tmp"
+
+ ; -- try to write to .tmp file
+ ; writeOkay <-
+ catch
+ (do { writeFile tmpName contents
+ ; return True
+ })
+ (\ioExc ->
+ do{ errorDialog parentWindow "Save failed"
+ ( "Saving " ++ fileName ++ " failed.\n\n"
+ ++ "Technical reason: " ++ show ioExc ++ "\n\n"
+ ++ "Tip: do you have write permissions and enough disk space?"
+ )
+ ; return False
+ }
+ )
+ ; if not writeOkay then
+ return False
+ else
+ do{ -- remove old file if it exists and then rename .tmp to the real name
+ ; catch (do { exists <- doesFileExist fileName
+ ; when exists $ removeFile fileName
+ ; renameFile tmpName fileName
+ ; return True
+ })
+ (\ioExc ->
+ do{ errorDialog parentWindow "Save failed"
+ ( "The file has been saved to " ++ show tmpName ++ "\nbut "
+ ++ "renaming it to " ++ show fileName ++ " failed.\n\n"
+ ++ "Technical reason: " ++ show ioExc
+ )
+ ; return False
+ }
+ )
+ }}
+
+strictReadFile :: String -> IO String
+strictReadFile fname =
+ do{ contents <- readFile fname
+ ; seq (length contents) $ return contents -- force reading of entire file
+ }
+
+myTextDialog :: Window a -> String -> String -> Bool -> IO (Maybe String)
+myTextDialog parentWindow dialogTitle initial selectAll =
+ do{ d <- dialog parentWindow [text := dialogTitle]
+ ; textInput <- textEntry d [ alignment := AlignLeft, text := initial]
+ ; ok <- button d [text := "Ok"]
+ ; can <- button d [text := "Cancel", identity := wxID_CANCEL]
+ ; buttonSetDefault ok
+ ; set d [layout := column 10 [ hfill $ widget textInput
+ , floatBottomRight $ row 5 [widget ok, widget can]
+ ]
+ ]
+ ; when (not selectAll) $ do set d [ visible := True ]
+ textCtrlSetInsertionPointEnd textInput
+ ; showModal d $ \stop ->
+ do set ok [on command := safetyNet parentWindow $
+ do theText <- get textInput text
+ stop (Just theText)]
+ set can [on command := safetyNet parentWindow $ stop Nothing]
+ }
+
+-- Dialog for selecting a multiple Strings (0 or more)
+-- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings
+multiSelectionDialog :: Window a -> String -> [String] -> [String]
+ -> IO (Maybe [String])
+multiSelectionDialog parentWindow dialogTitle strings initialSelection =
+ do{ d <- dialog parentWindow
+ [ text := dialogTitle
+ , resizeable := True
+ ]
+ ; p <- panel d []
+ ; theListBox <- multiListBox p
+ [ items := strings
+ , selections :=
+ [ case maybeIndex of
+ Nothing -> internalError "CommonIO" "multiSelectionDialog"
+ ( "initial selection " ++ show s
+ ++ " can not be found in " ++ show strings )
+ Just i -> i
+ | s <- initialSelection
+ , let maybeIndex = elemIndex s strings
+ ]
+ ]
+ ; selectAll <- button p
+ [ text := "Select all"
+ , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ]
+ ]
+ ; selectNone <- button p
+ [ text := "Select none"
+ , on command := safetyNet parentWindow $ set theListBox [ selections := [] ]
+ ]
+ ; ok <- button p [text := "Ok"]
+ ; can <- button p [text := "Cancel", identity := wxID_CANCEL]
+ ; buttonSetDefault ok
+ ; set d [ layout := container p $
+ column 10 [ vfill $ widget theListBox
+ , row 5 [widget selectAll, widget selectNone, widget ok, widget can]
+ ]
+ , clientSize := sz 300 400
+ ]
+ ; showModal d $ \stop ->
+ do set ok [on command := safetyNet parentWindow $
+ do indices <- get theListBox selections
+ stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))]
+ set can [on command := safetyNet parentWindow $
+ stop Nothing]
+ }
+
+-- Dialog for selecting a single String
+-- Returns Nothing if Cancel was pressed, otherwise it returns the selected string
+singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String)
+ -> IO (Maybe String)
+singleSelectionDialog _ _ [] _ =
+ internalError "CommonIO" "singleSelectionDialog" "no strings"
+singleSelectionDialog parentWindow dialogTitle strings initialSelection =
+ do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ]
+ ; p <- panel d []
+ ; theListBox <- singleListBox p [ items := strings, selection := 0]
+ ; ifJust initialSelection $ \selString ->
+ case elemIndex selString strings of
+ Nothing -> internalError "CommonIO" "singleSelectionDialog"
+ ( "initial selection " ++ show selString
+ ++ " can not be found in " ++ show strings )
+ Just i -> set theListBox [ selection := i ]
+ ; ok <- button p [text := "Ok"]
+ ; can <- button p [text := "Cancel", identity := wxID_CANCEL]
+ ; buttonSetDefault ok
+ ; set d [ layout := container p $
+ column 10 [ vfill $ widget theListBox
+ , row 5 [widget ok, widget can]
+ ]
+ , clientSize := sz 300 400
+ ]
+ ; showModal d $ \stop ->
+ do set ok [on command := safetyNet parentWindow $
+ do index <- get theListBox selection
+ stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))]
+ set can [on command := safetyNet parentWindow $
+ stop Nothing]
+ }
+
+-- | Fill a grid from a list of lists of texts. Each list inside the
+-- big list represents a row. Also set the given number or rows and
+-- columns to be header: grey background and not editable.
+-- This function assumes that the normal spreadsheet-like grid header row
+-- and column have been made invisible.
+fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO ()
+fillGridFromList _ _ _ [] = return ()
+fillGridFromList theGrid nrHeaderRows nrHeaderCols list =
+ do{ nrOfCols <- gridGetNumberCols theGrid
+ ; nrOfRows <- gridGetNumberRows theGrid
+ ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $
+ internalError "Common" "fillGridFromList" "grid is not big enough"
+ ; sequence_ . concat $
+ [ [ do{ gridSetCellValue theGrid rowNr colNr txt
+ ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols
+ ; gridSetCellBackgroundColour theGrid rowNr colNr
+ (if isHeaderCell then systemGrey else white)
+ ; gridSetReadOnly theGrid rowNr colNr isHeaderCell
+ }
+ | (txt, colNr) <- zip theRow [0..]
+ ]
+ | (theRow, rowNr) <- zip list [0..]
+ ]
+ }
+
+-- | Export some data (a list of lists of strings) to a tab delimited
+-- file. The user is asked to choose a location
+exportToTabFile :: Window a -> String -> String -> [[String]] -> IO ()
+exportToTabFile parentWindow description fileName theData =
+ do { mFilename <- fileSaveDialog
+ parentWindow
+ False -- remember current directory
+ True -- overwrite prompt
+ ("Export " ++ description)
+ [("Tab delimited files",["*.txt"])]
+ "" -- directory
+ fileName
+ ; ifJust mFilename $ \filename ->
+ ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData))
+ }
+
+getScreenPPI :: IO Size
+getScreenPPI =
+ do{ dc <- screenDCCreate
+ ; s <- dcGetPPI dc
+ ; screenDCDelete dc
+ ; return s
+ }
+
+screenToLogicalPoint :: Size -> Point -> DoublePoint
+screenToLogicalPoint ppi p =
+ DoublePoint (screenToLogicalX ppi (pointX p))
+ (screenToLogicalY ppi (pointY p))
+
+logicalToScreenPoint :: Size -> DoublePoint -> Point
+logicalToScreenPoint ppi doublePoint =
+ pt (logicalToScreenX ppi (doublePointX doublePoint))
+ (logicalToScreenY ppi (doublePointY doublePoint))
+
+screenToLogicalX :: Size -> Int -> Double
+screenToLogicalX ppi x =
+ fromIntegral x / (fromIntegral (sizeW ppi) / 2.54)
+
+logicalToScreenX :: Size -> Double -> Int
+logicalToScreenX ppi x =
+ truncate (x * fromIntegral (sizeW ppi) / 2.54)
+
+screenToLogicalY :: Size -> Int -> Double
+screenToLogicalY ppi y =
+ fromIntegral y / (fromIntegral (sizeH ppi) / 2.54)
+
+logicalToScreenY :: Size -> Double -> Int
+logicalToScreenY ppi y =
+ truncate (y * fromIntegral (sizeH ppi) / 2.54)
+
+-- Create a grid of which the standard labels (A,B,C... for columns
+-- and 1,2,3... for rows) are invisible
+mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ())
+mkNoLabelGrid thePanel nrOfRows nrOfCols =
+ do{ theGrid <- gridCreate thePanel idAny rectNull 0
+ ; gridCreateGrid theGrid nrOfRows nrOfCols 0
+ ; gridSetColLabelSize theGrid 0
+ ; gridSetRowLabelSize theGrid 0
+ ; return theGrid
+ }
+
+resizeGrid :: Grid () -> Int -> Int -> IO ()
+resizeGrid theGrid nrOfRows nrOfCols =
+ do{ oldNrOfRows <- gridGetNumberRows theGrid
+ ; oldNrOfCols <- gridGetNumberCols theGrid
+ ; when (nrOfRows > oldNrOfRows) . ignoreResult $
+ gridAppendRows theGrid (nrOfRows - oldNrOfRows) False
+ ; when (nrOfRows < oldNrOfRows) . ignoreResult $
+ gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False
+ ; when (nrOfCols > oldNrOfCols) . ignoreResult $
+ gridAppendCols theGrid (nrOfCols - oldNrOfCols) False
+ ; when (nrOfCols < oldNrOfCols) . ignoreResult $
+ gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False
+ }
+
+-- | Get the position of a frame, if the frame is minimized or maximized
+-- it is restored to its normal size first. Otherwise, you get
+-- (-32000, -32000) for a minimized window :-)
+safeGetPosition :: Frame a -> IO (Int, Int)
+safeGetPosition f =
+ do{ isMax <- frameIsMaximized f
+ ; isMin <- frameIsIconized f
+ ; when (isMax || isMin) $ frameRestore f
+ ; p <- get f position
+ ; return (pointX p, pointY p)
+ }
+
+-- Show a dialog with a grid and a save button
+gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]]
+ -> IO () -> IO ()
+gridDialogWithSave parentWindow title maybeNote matrixContents saveAction =
+ do{
+ -- Create dialog and panel
+ ; theDialog <- dialog parentWindow
+ [ text := title
+ , resizeable := True
+ ]
+ ; p <- panel theDialog []
+
+ -- Create and fill grid
+ ; theGrid <- mkNoLabelGrid p height width
+ ; gridEnableEditing theGrid False
+ ; fillGridFromList theGrid 0 0 matrixContents
+ ; gridAutoSizeColumns theGrid False
+
+ -- File menu
+ ; saveButton <- button p
+ [ text := "Save as..."
+ , on command := safetyNet parentWindow $ saveAction
+ ]
+
+ -- Dialog layout
+ ; set theDialog
+ [ layout := minsize (sz 600 400) $ column 5
+ ( case maybeNote of
+ Just note -> [ hfill $ label note ]
+ Nothing -> []
+ ++ [ container p $
+ column 5 [ fill $ widget theGrid
+ , row 0 [ widget saveButton, glue ]
+ ]
+ ]
+ )
+ , visible := True
+ ]
+ }
+ where
+ width = maximum . map length $ matrixContents
+ height = length matrixContents
+
+
+-- | Using bootstrapUI, a record containing all widgets and variables can be created
+-- at the end of the create function, but still referred to before creation
+-- NOTE: widgets should not be referred to in a strict way because this will
+-- cause a loop
+bootstrapUI :: (uistate -> IO uistate) -> IO ()
+bootstrapUI fIO =
+ do { fixIO fIO
+ ; return ()
+ }
addfile ./src/Constants.hs
hunk ./src/Constants.hs 1
+module Constants where
+
+import Graphics.UI.WX
+
+kSELECTED_WIDTH :: Int
+kSELECTED_WIDTH = 3
+
+kEDGE_CLICK_RANGE, kNODE_RADIUS, kARROW_SIZE:: Double
+kEDGE_CLICK_RANGE = 0.2
+kNODE_RADIUS = 0.5
+kARROW_SIZE = 0.3
+
+kSELECTED_OPTIONS :: [Prop (DC ())]
+kSELECTED_OPTIONS = [ penWidth := kSELECTED_WIDTH ]
addfile ./src/ContextMenu.hs
hunk ./src/ContextMenu.hs 1
+module ContextMenu
+ ( canvas, edge, node ) where
+
+import State
+import Network
+import qualified Node
+import Document
+import NetworkControl
+import SafetyNet
+import CommonIO
+import qualified PersistentDocument as PD
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore(windowGetMousePosition)
+
+-- | Context menu for empty area of canvas
+canvas :: Frame () -> State -> IO ()
+canvas theFrame state =
+ do{ contextMenu <- menuPane []
+ ; menuItem contextMenu
+ [ text := "Add node (shift-click)"
+ , on command := safetyNet theFrame $ addNodeItem theFrame state
+ ]
+
+ ; pointWithinWindow <- windowGetMousePosition theFrame
+ ; menuPopup contextMenu pointWithinWindow theFrame
+ ; objectDelete contextMenu
+ }
+
+addNodeItem :: Frame () -> State -> IO ()
+addNodeItem theFrame state =
+ do{ mousePoint <- windowGetMousePosition theFrame
+ ; ppi <- getScreenPPI
+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint
+ ; createNode doubleMousePoint state
+ }
+
+-- | Context menu for an edge
+edge :: Frame () -> State -> IO ()
+edge theFrame state =
+ do{ contextMenu <- menuPane []
+ ; menuItem contextMenu
+ [ text := "Delete edge (Del)"
+ , on command := safetyNet theFrame $ deleteSelection state
+ ]
+ ; pointWithinWindow <- windowGetMousePosition theFrame
+ ; menuPopup contextMenu pointWithinWindow theFrame
+ ; objectDelete contextMenu
+ }
+
+-- | Context menu for a node
+node :: Int -> Frame () -> State -> IO ()
+node nodeNr theFrame state =
+ do{ contextMenu <- menuPane []
+
+ ; pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ theNode = getNode nodeNr network
+ labelAbove = Node.getNameAbove theNode
+
+ ; aboveItem <- menuRadioItem contextMenu
+ [ text := "Label above (up arrow)"
+ , on command := safetyNet theFrame $ changeNamePosition True state
+ ]
+ ; belowItem <- menuRadioItem contextMenu
+ [ text := "Label below (down arrow)"
+ , on command := safetyNet theFrame $ changeNamePosition False state
+ ]
+ ; set (if labelAbove then aboveItem else belowItem) [ checked := True ]
+ ; menuItem contextMenu
+ [ text := "Rename (F2)"
+ , on command := safetyNet theFrame $ renameNode theFrame state
+ ]
+
+ ; menuLine contextMenu
+
+ ; menuItem contextMenu
+ [ text := "Delete (Del)"
+ , on command := safetyNet theFrame $ deleteSelection state
+ ]
+
+ ; pointWithinWindow <- windowGetMousePosition theFrame
+ ; menuPopup contextMenu pointWithinWindow theFrame
+ ; objectDelete contextMenu
+
+ }
addfile ./src/Document.hs
hunk ./src/Document.hs 1
+{-| Module : Document
+ Maintainer : afie@cs.uu.nl
+
+ This module contains functions to create documents
+ and to get and set components of the Document datatype.
+-}
+
+module Document
+ ( Document
+ , Selection(..)
+ , empty
+ , getNetwork, setNetwork, unsafeSetNetwork
+ , getSelection, setSelection
+
+ , updateNetwork, updateNetworkEx
+ ) where
+
+import qualified Network
+
+{--------------------------------------------------
+ -- TYPES
+ --------------------------------------------------}
+
+data Document = Document
+ { docNetwork :: Network.Network String
+ , docSelection :: Selection
+ } deriving Show
+
+data Selection
+ = NoSelection
+ | NodeSelection Int
+ | EdgeSelection Int
+ deriving (Show, Read, Eq)
+
+{--------------------------------------------------
+ -- CREATION
+ --------------------------------------------------}
+
+
+-- | An empty document
+empty :: Document
+empty =
+ Document
+ { docNetwork = Network.empty
+ , docSelection = NoSelection
+ }
+
+{--------------------------------------------------
+ -- GETTERS
+ --------------------------------------------------}
+
+getNetwork :: Document -> Network.Network String
+getSelection :: Document -> Selection
+
+getNetwork doc = docNetwork doc
+getSelection doc = docSelection doc
+
+{--------------------------------------------------
+ -- SETTERS
+ --------------------------------------------------}
+
+-- | setNetwork clears the selection because the node may not exist
+-- in the new network
+setNetwork :: Network.Network String -> Document -> Document
+setNetwork theNetwork doc =
+ doc { docNetwork = theNetwork
+ , docSelection = NoSelection
+ }
+
+setSelection :: Selection -> Document -> Document
+setSelection theSelection doc = doc { docSelection = theSelection }
+
+updateNetwork :: (Network.Network String -> Network.Network String) -> Document -> Document
+updateNetwork networkFun doc
+ = unsafeSetNetwork (networkFun (getNetwork doc))
+ $ doc
+
+updateNetworkEx :: (Network.Network String -> (b, Network.Network String)) -> Document -> (b, Document)
+updateNetworkEx networkFun doc =
+ let (result, newNetwork) = networkFun (getNetwork doc)
+ in ( result
+ , unsafeSetNetwork newNetwork doc
+ )
+
+-- | Doesn't clear the selection
+unsafeSetNetwork :: Network.Network String -> Document -> Document
+unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork }
addfile ./src/GUIEvents.hs
hunk ./src/GUIEvents.hs 1
+module GUIEvents where
+
+import NetworkView(clickedNode, clickedEdge)
+import NetworkControl
+import State
+import Common
+import CommonIO
+import Document
+import qualified ContextMenu
+import qualified PersistentDocument as PD
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore
+
+mouseDown :: Bool -> Point -> Frame () -> State -> IO ()
+mouseDown leftButton mousePoint theFrame state =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; ppi <- getScreenPPI
+ ; let network = getNetwork doc
+ doubleMousePoint = screenToLogicalPoint ppi mousePoint
+ ; case clickedNode doubleMousePoint doc of
+ Nothing ->
+ case clickedEdge doubleMousePoint network of
+ Nothing ->
+ when (not leftButton) $ ContextMenu.canvas theFrame state
+ Just edgeNr ->
+ if leftButton then
+ selectEdge edgeNr state
+ else
+ do{ selectEdge edgeNr state
+ ; ContextMenu.edge theFrame state
+ }
+ Just nodeNr ->
+ if leftButton then
+ pickupNode nodeNr doubleMousePoint state
+ else
+ do{ selectNode nodeNr state
+ ; ContextMenu.node nodeNr theFrame state
+ }
+ }
+
+leftMouseDownWithShift :: Point -> State -> IO ()
+leftMouseDownWithShift mousePoint state =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; ppi <- getScreenPPI
+ ; let network = getNetwork doc
+ doubleMousePoint = screenToLogicalPoint ppi mousePoint
+ ; case clickedNode doubleMousePoint doc of
+ Nothing ->
+ case clickedEdge doubleMousePoint network of
+ Nothing ->
+ createNode doubleMousePoint state -- shift click in empty area = create new node
+ Just i ->
+ selectEdge i state -- shift click on edge = select
+ Just j -> do -- shift click on node = create edge (if possible)
+ case getSelection doc of
+ NodeSelection i | i /= j ->
+ createEdge i j state
+ _ -> selectNode j state
+ }
+
+leftMouseDrag :: Point -> ScrolledWindow () -> State -> IO ()
+leftMouseDrag mousePoint canvas state =
+ do{ dragging <- getDragging state
+ ; ppi <- getScreenPPI
+ ; ifJust dragging $ \_ ->
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint
+ ; case getSelection doc of
+ NodeSelection nodeNr ->
+ dragNode nodeNr doubleMousePoint canvas state
+ _ -> return ()
+ }
+ }
+
+leftMouseUp :: Point -> State -> IO ()
+leftMouseUp mousePoint state =
+ do{ dragging <- getDragging state
+ ; ppi <- getScreenPPI
+ ; ifJust dragging $ \(hasMoved, offset) ->
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint
+ ; case getSelection doc of
+ NodeSelection nodeNr ->
+ dropNode hasMoved nodeNr offset doubleMousePoint state
+ _ -> return ()
+ }
+ }
+
+deleteKey :: State -> IO ()
+deleteKey state =
+ deleteSelection state
+
+backspaceKey :: State -> IO ()
+backspaceKey state =
+ deleteSelection state
+
+f2Key :: Frame () -> State -> IO ()
+f2Key theFrame state =
+ renameNode theFrame state
+
+upKey :: State -> IO ()
+upKey state =
+ changeNamePosition True state
+
+downKey :: State -> IO ()
+downKey state =
+ changeNamePosition False state
addfile ./src/Main.hs
hunk ./src/Main.hs 1
+module Main (main, gain) where
+
+import NetworkUI
+import Graphics.UI.WX
+import State
+
+main :: IO ()
+main = start $
+ do{ state <- State.empty
+ ; NetworkUI.create state
+ }
+
+gain :: IO ()
+gain = main -- :-)
addfile ./src/Math.hs
hunk ./src/Math.hs 1
+module Math
+ ( DoublePoint(..), Vector
+ , intPointToDoublePoint
+ , doublePointToIntPoint
+ , translatePolar
+ , distancePointPoint
+ , distanceSegmentPoint
+ , subtractDoublePoint
+ , subtractDoublePointVector
+ , vectorLength
+ , vectorAngle
+ , origin
+ ) where
+
+import Graphics.UI.WX(Point, point, pointX, pointY)
+
+data DoublePoint = DoublePoint
+ { doublePointX :: !Double
+ , doublePointY :: !Double
+ }
+ deriving (Show, Eq, Read)
+
+data Vector = Vector !Double !Double
+
+origin :: DoublePoint
+origin = DoublePoint 0 0
+
+-- | Compute distance between two points
+distancePointPoint :: DoublePoint -> DoublePoint -> Double
+distancePointPoint (DoublePoint x0 y0) (DoublePoint x1 y1) =
+ sqrt (square (x0 - x1) + square (y0 - y1))
+
+square :: Double -> Double
+square d = d*d
+
+-- | Compute distance from a segment (as opposed to a line) to a point
+-- Formulas taken from
+-- <http://geometryalgorithms.com/Archive/algorithm_0102/algorithm_0102.htm>
+distanceSegmentPoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double
+distanceSegmentPoint p0 p1 p =
+ let v = p1 `subtractDoublePointVector` p0
+ w = p `subtractDoublePointVector` p0
+ c1 = dotProduct w v
+ c2 = dotProduct v v
+ in if c1 <= 0 then distancePointPoint p p0
+ else if c2 <= c1 then distancePointPoint p p1
+ else distanceLinePoint p0 p1 p
+
+-- | Compute distance from a line to a point
+distanceLinePoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double
+distanceLinePoint (DoublePoint x0 y0) (DoublePoint x1 y1) (DoublePoint x y) =
+ abs ( ( (y0 - y1) * x + (x1 - x0) * y + (x0 * y1 - x1 * y0) ) /
+ sqrt (square (x1 - x0) + square (y1 - y0))
+ )
+
+subtractDoublePointVector :: DoublePoint -> DoublePoint -> Vector
+subtractDoublePointVector (DoublePoint x0 y0) (DoublePoint x1 y1) =
+ Vector (x0 - x1) (y0 - y1)
+
+subtractDoublePoint :: DoublePoint -> DoublePoint -> DoublePoint
+subtractDoublePoint (DoublePoint x0 y0) (DoublePoint x1 y1) =
+ DoublePoint (x0 - x1) (y0 - y1)
+
+dotProduct :: Vector -> Vector -> Double
+dotProduct (Vector v1 v2) (Vector w1 w2) = v1 * w1 + v2 * w2
+
+translatePolar :: Double -> Double -> DoublePoint -> DoublePoint
+translatePolar angle distance (DoublePoint x y) =
+ DoublePoint (x + cos angle * distance) (y + sin angle * distance)
+
+doublePointToIntPoint :: DoublePoint -> Point
+doublePointToIntPoint (DoublePoint x y) = point (round x) (round y)
+
+intPointToDoublePoint :: Point -> DoublePoint
+intPointToDoublePoint pt =
+ DoublePoint (fromIntegral (pointX pt)) (fromIntegral (pointY pt))
+
+vectorAngle :: Vector -> Double
+vectorAngle (Vector v1 v2) = atan2 v2 v1
+
+vectorLength :: Vector -> Double
+vectorLength (Vector v1 v2) = sqrt (square v1 + square v2)
addfile ./src/Network.hs
hunk ./src/Network.hs 1
+module Network
+ (
+ -- * Types
+ Network, Edge(..)
+ , NodeNr, EdgeNr, ZeroProb
+
+ -- * Creating and printing a network
+ , Network.empty
+ , dumpNetwork
+
+ , getNodeNrs
+ , getNodeAssocs, setNodeAssocs
+ , getEdgeAssocs, setEdgeAssocs
+ , getCanvasSize, setCanvasSize
+
+ , getNode
+ , getEdge
+ , getNodes
+ , getEdges
+ , getChildren
+ , getParents
+ , getParentMap, ParentMap
+
+ , nodeExists, edgeExists
+ , findEdge, findNodeNrsByName
+
+ , updateNode
+
+ , mapNodeNetwork
+
+ , addNode, addNodes, removeNode, addNodeEx
+ , addEdge, addEdges, removeEdge,
+ , removeAllEdges
+ ) where
+
+import Common
+import Math
+import qualified Node
+
+import IntMap hiding (map)
+
+data Network a = Network
+ { networkNodes :: !(IntMap (Node.Node a)) -- ^ maps node numbers to nodes
+ , networkEdges :: !(IntMap Edge) -- ^ maps edge numbers to edges
+ , networkCanvasSize :: (Double, Double)
+ } deriving Show
+
+data Edge = Edge
+ { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts
+ , edgeTo :: !NodeNr -- ^ the number of the node the edge points to
+ } deriving (Show, Read, Eq)
+
+type NodeNr = Int
+type EdgeNr = Int
+
+-- | Create an empty network
+empty :: Network a
+empty = Network
+ { networkNodes = IntMap.empty
+ , networkEdges = IntMap.empty
+ , networkCanvasSize = (15, 9)
+ }
+
+-- | Initial value of elements of probability table
+-- also used when tables are resized or cleared
+class ZeroProb a where
+ zeroProb :: a
+
+instance ZeroProb String where
+ zeroProb = "-"
+
+instance ZeroProb Int where
+ zeroProb = (-1)
+
+instance ZeroProb Double where
+ zeroProb = (-1.0)
+
+-- | Map a function over the nodes, possibly changes the type
+-- of the Network (i.e. the kind of values stored in the
+-- probability tables)
+mapNodeNetwork :: (Node.Node a -> Node.Node b) -> Network a -> Network b
+mapNodeNetwork nodeFun network =
+ let numberedNodes = getNodeAssocs network
+ newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ]
+ in Network
+ { networkNodes = IntMap.fromList newNodes
+ , networkEdges = networkEdges network
+ , networkCanvasSize = networkCanvasSize network
+ }
+
+-- | Get the next unused node number
+getUnusedNodeNr :: Network a -> NodeNr
+getUnusedNodeNr network | null used = 1
+ | otherwise = maximum used + 1
+ where
+ used = keys (networkNodes network)
+
+-- | Get the next unused edge number
+getUnusedEdgeNr :: Network a -> EdgeNr
+getUnusedEdgeNr network | null used = 1
+ | otherwise = maximum used + 1
+ where
+ used = keys (networkEdges network)
+
+-- | Get the node numbers of the parents of a given node
+getParents :: Network a -> NodeNr -> [NodeNr]
+getParents network child =
+ [ parent
+ | edge <- getEdges network
+ , edgeTo edge == child
+ , let parent = edgeFrom edge
+ ]
+
+type ParentMap = IntMap.IntMap [NodeNr]
+
+-- | getParents is quite expensive (see above) and so
+-- we store the parent relationship in an IntMap
+getParentMap :: Network a -> ParentMap
+getParentMap network =
+ IntMap.fromList
+ [ (nodeNr, getParents network nodeNr)
+ | nodeNr <- getNodeNrs network
+ ]
+
+-- | Get the node numbers of the children of a given node
+getChildren :: Network a -> NodeNr -> [NodeNr]
+getChildren network parent =
+ [ child
+ | edge <- getEdges network
+ , edgeFrom edge == parent
+ , let child = edgeTo edge
+ ]
+
+
+-- | Get node with given index, raises exception if node number does not exist
+getNode :: NodeNr -> Network a -> Node.Node a
+getNode nodeNr network
+ | member nodeNr nodesMap = nodesMap ! nodeNr
+ | otherwise = internalError "Network" "getNode" "illegal node number"
+ where
+ nodesMap = networkNodes network
+
+-- | Get edge with given index, raises exception if edge number does not exist
+getEdge :: EdgeNr -> Network a -> Edge
+getEdge edgeNr network = networkEdges network ! edgeNr
+
+-- | Get all of the nodes in the network
+getNodes :: Network a -> [Node.Node a]
+getNodes network = elems (networkNodes network)
+
+-- | Get all of the edges in the network
+getEdges :: Network a -> [Edge]
+getEdges network = elems (networkEdges network)
+
+-- | Get all of the node numbers in the network
+getNodeNrs :: Network a -> [NodeNr]
+getNodeNrs network = keys (networkNodes network)
+
+getCanvasSize :: Network a -> (Double, Double)
+getCanvasSize network = networkCanvasSize network
+
+-- | Find the number of an edge given start and end node number
+findEdge :: NodeNr -> NodeNr -> Network a -> Maybe EdgeNr
+findEdge fromNodeNr toNodeNr network =
+ let hits = IntMap.filter
+ (sameFromAndTo (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr }))
+ (networkEdges network)
+ in case IntMap.keys hits of
+ [key] -> Just key
+ _ -> Nothing
+
+-- | Find node numbers given a node name
+findNodeNrsByName :: String -> Network a -> [NodeNr]
+findNodeNrsByName theNodeName network =
+ let nodes = getNodeAssocs network in
+ [ nodeNr
+ | (nodeNr, node) <- nodes
+ , Node.getName node == theNodeName
+ ]
+
+-- | Get a list of pairs where each pair contains a node number and the corresponding node
+getNodeAssocs :: Network a -> [(NodeNr, Node.Node a)]
+getNodeAssocs network = assocs (networkNodes network)
+
+setNodeAssocs :: [(NodeNr, Node.Node a)] -> Network a -> Network a
+setNodeAssocs nodeAssocs network =
+ network { networkNodes = IntMap.fromList nodeAssocs }
+
+-- | Get a list of pairs where each pair contains a edge number and the corresponding edge
+getEdgeAssocs :: Network a -> [(EdgeNr, Edge)]
+getEdgeAssocs network = assocs (networkEdges network)
+
+setEdgeAssocs :: [(EdgeNr, Edge)] -> Network a -> Network a
+setEdgeAssocs edgeAssocs network =
+ network { networkEdges = IntMap.fromList edgeAssocs }
+
+-- | Create a string that describes the network
+dumpNetwork :: Network String -> String
+dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network)
+
+-- | Test for existence of a node number
+nodeExists :: NodeNr -> Network a -> Bool
+nodeExists nodeNr network =
+ member nodeNr (networkNodes network)
+
+-- | Test for existence of an edge number
+edgeExists :: EdgeNr -> Network a -> Bool
+edgeExists edgeNr network =
+ member edgeNr (networkEdges network)
+
+{-----------------------------------
+ Functions that change the network
+ -----------------------------------}
+
+-- | Add a node to the network
+addNode :: ZeroProb a
+ => Network a -- ^ the network to add the node to
+ -> (NodeNr, Network a) -- ^ the number of the new node and
+ -- the extended network
+addNode network =
+ addNodeEx ("Node " ++ show nodeNr)
+ (DoublePoint 0.0 0.0)
+ network
+ where
+ nodeNr = getUnusedNodeNr network
+
+addNodes :: ZeroProb a => Int -> Network a -> ([NodeNr], Network a)
+addNodes 0 network = ([], network)
+addNodes n network1 =
+ let (nodeNr, network2) = addNode network1
+ (nodeNrs, network3) = addNodes (n-1) network2
+ in (nodeNr:nodeNrs, network3)
+
+addNodeEx :: ZeroProb a => String -> DoublePoint -> Network a
+ -> (NodeNr, Network a)
+addNodeEx name position network =
+ ( nodeNr
+ , network { networkNodes = insert nodeNr node (networkNodes network) }
+ )
+ where
+ nodeNr = getUnusedNodeNr network
+ node = Node.create name position True
+
+-- | Add an edge to the network. The probability table of the target node is updated:
+-- a dimension is added and all values are zeroed.
+addEdge :: ZeroProb a => NodeNr -> NodeNr -> Network a -> Network a
+addEdge fromNodeNr toNodeNr network
+ | any (sameFromAndTo edge) edgesList || -- prohibit double edges
+ any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction
+ network
+ | otherwise =
+ let edgeNr = getUnusedEdgeNr network
+ networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }
+ in networkPlusEdge
+ where
+ edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr }
+ edgesList = elems (networkEdges network)
+
+addEdges :: ZeroProb a => [(NodeNr,NodeNr)] -> Network a -> Network a
+addEdges edgeTuples network =
+ foldr (\(fromNr, toNr) net -> addEdge fromNr toNr net) network edgeTuples
+
+-- | Remove node with given index, raises exception if node number does not exist.
+-- This function also removes all edges that start or end in this node.
+removeNode :: ZeroProb a => NodeNr -> Network a -> Network a
+removeNode nodeNr network =
+ let involvedEdges = [ i
+ | (i, edge) <- getEdgeAssocs network
+ , edgeFrom edge == nodeNr || edgeTo edge == nodeNr
+ ]
+ networkWithoutEdges = foldr removeEdge network involvedEdges
+ networkWithoutNode = networkWithoutEdges { networkNodes = delete nodeNr (networkNodes networkWithoutEdges) }
+ in networkWithoutNode
+
+-- | Remove an edge from the network. The probability table of the target node is updated:
+-- the corresponding dimension is removed and all values are zeroed.
+-- An exception is raised if edge number does not exist.
+removeEdge :: ZeroProb a => EdgeNr -> Network a -> Network a
+removeEdge edgeNr network =
+ network { networkEdges = delete edgeNr (networkEdges network) }
+
+-- | Remove all edges from the network. The probability tables of all node are zeroed.
+removeAllEdges :: ZeroProb a => Network a -> Network a
+removeAllEdges network =
+ let networkWithoutEdges = network { networkEdges = IntMap.empty }
+ in networkWithoutEdges
+
+setCanvasSize :: (Double, Double) -> Network a -> Network a
+setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize }
+
+{-----------------------------------
+ Local functions
+ -----------------------------------}
+
+sameFromAndTo :: Edge -> Edge -> Bool
+sameFromAndTo edge1 edge2 =
+ edgeFrom edge1 == edgeFrom edge2 && edgeTo edge1 == edgeTo edge2
+
+reverseEdge :: Edge -> Edge
+reverseEdge edge =
+ edge { edgeFrom = edgeTo edge, edgeTo = edgeFrom edge }
+
+-- | Update node with given number by applying the function to it
+-- Dangerous (wrt network consistency, do not export)
+updateNode :: NodeNr -> (Node.Node a -> Node.Node a) -> Network a -> Network a
+updateNode nodeNr nodeFunction network =
+ let node = getNode nodeNr network in
+ network { networkNodes = insert nodeNr (nodeFunction node) (networkNodes network) }
addfile ./src/NetworkControl.hs
hunk ./src/NetworkControl.hs 1
-
+module NetworkControl
+ ( createNode, selectNode
+ , createEdge, selectEdge
+ , pickupNode, dragNode, dropNode
+ , deleteSelection
+ , changeNamePosition
+ , renameNode
+ ) where
+ [_$_]
+import State
+import StateUtil
+import Network(getNode, updateNode, addEdge, removeEdge, removeNode, addNode)
+import qualified Node
+import Document
+import Common
+import CommonIO
+import Math [_$_]
+import qualified PersistentDocument as PD [_$_]
+
+import Graphics.UI.WX hiding (Selection)
+import Graphics.UI.WXCore
+
+changeNamePosition :: Bool -> State -> IO ()
+changeNamePosition above state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; case getSelection doc of
+ NodeSelection nodeNr -> [_$_]
+ do{ PD.updateDocument "move label"
+ (updateNetwork [_$_]
+ (updateNode nodeNr [_$_]
+ (Node.setNameAbove above))) pDoc
+ ; repaintAll state
+ }
+ _ -> return ()
+ }
+
+deleteSelection :: State -> IO ()
+deleteSelection state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; case getSelection doc of
+ NodeSelection nodeNr -> [_$_]
+ do{ PD.updateDocument "delete node"
+ ( setSelection NoSelection [_$_]
+ . updateNetwork (removeNode nodeNr)
+ ) pDoc
+ ; repaintAll state
+ }
+ EdgeSelection edgeNr -> [_$_]
+ do{ PD.updateDocument "delete edge"
+ ( setSelection NoSelection
+ . updateNetwork (removeEdge edgeNr)
+ ) pDoc
+ ; repaintAll state
+ }
+ _ -> return ()
+ }
+ [_$_]
+createNode :: DoublePoint -> State -> IO ()
+createNode mousePoint state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc1 <- PD.getDocument pDoc
+ ; let (nodeNr, doc2) = updateNetworkEx addNode doc1
+ doc3 = updateNetwork (updateNode nodeNr [_$_]
+ (Node.setPosition mousePoint)) doc2
+ doc4 = setSelection (NodeSelection nodeNr) doc3
+ ; PD.setDocument "add node" doc4 pDoc
+ ; repaintAll state
+ }
+
+selectEdge :: Int -> State -> IO ()
+selectEdge edgeNr state = [_$_]
+ do{ pDoc <- getDocument state
+ ; PD.superficialUpdateDocument (setSelection (EdgeSelection edgeNr)) pDoc
+ ; repaintAll state
+ }
+
+createEdge :: Int -> Int -> State -> IO ()
+createEdge fromNodeNr toNodeNr state = [_$_]
+ do{ pDoc <- getDocument state
+ ; PD.updateDocument "add edge"
+ ( setSelection (NodeSelection fromNodeNr)
+ . updateNetwork (addEdge fromNodeNr toNodeNr)
+ ) pDoc
+ ; repaintAll state
+ } [_$_]
+ [_$_]
+selectNode :: Int -> State -> IO ()
+selectNode nodeNr state = [_$_]
+ do{ pDoc <- getDocument state
+ ; PD.superficialUpdateDocument (setSelection (NodeSelection nodeNr)) pDoc
+ ; repaintAll state
+ }
+
+pickupNode :: Int -> DoublePoint -> State -> IO ()
+pickupNode nodeNr mousePoint state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ nodePos = Node.getPosition (getNode nodeNr network)
+ ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state
+ ; selectNode nodeNr state
+ }
+
+dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State -> IO ()
+dragNode nodeNr mousePoint canvas state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; Just (hasMoved, offset) <- getDragging state
+ ; let newPosition = mousePoint `subtractDoublePoint` offset
+ oldPosition = Node.getPosition (getNode nodeNr (getNetwork doc))
+ ; when (newPosition /= oldPosition) $
+ do{ -- The first time the node is moved we have to remember
+ -- the document in the undo history
+ ; (if not hasMoved then PD.updateDocument "move node" [_$_]
+ else PD.superficialUpdateDocument)
+ (updateNetwork (updateNode nodeNr [_$_]
+ (Node.setPosition newPosition))) [_$_]
+ pDoc
+ ; Graphics.UI.WX.repaint canvas
+ ; setDragging (Just (True, offset)) state [_$_]
+ -- yes, the node has really moved [_$_]
+ }
+ }
+
+dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State -> IO ()
+dropNode hasMoved nodeNr offset mousePoint state = [_$_]
+ do{ when hasMoved $
+ do{ let newPosition = mousePoint `subtractDoublePoint` offset
+ ; pDoc <- getDocument state
+ ; PD.superficialUpdateDocument
+ (updateNetwork (updateNode nodeNr [_$_]
+ (Node.setPosition newPosition))) pDoc
+ }
+ ; canvas <- getCanvas state
+ ; Graphics.UI.WX.repaint canvas
+ ; setDragging Nothing state
+ }
+
+renameNode :: Frame () -> State -> IO ()
+renameNode theFrame state = [_$_]
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ ; case getSelection doc of
+ NodeSelection nodeNr ->
+ do{ let oldName = Node.getName (getNode nodeNr network)
+ ; result <- myTextDialog theFrame "Rename node" oldName True
+ ; ifJust result $ \newName ->
+ do{ PD.updateDocument "rename node"
+ (updateNetwork [_$_]
+ (updateNode nodeNr (Node.setName newName))) pDoc
+ ; repaintAll state
+ }
+ }
+ _ -> return ()
+ }
+ [_$_]
+ [_$_]
addfile ./src/NetworkFile.hs
hunk ./src/NetworkFile.hs 1
+module NetworkFile where
+
+import Network
+import Node
+import Math
+import Common
+
+import Text.XML.HaXml.Types
+import Text.XML.HaXml.Escape
+import Text.XML.HaXml.Parse
+import Text.PrettyPrint.HughesPJ
+import qualified Text.XML.HaXml.Pretty as Pretty
+import Char
+import Maybe
+import Monad(when)
+import List(nub)
+
+-- | Print the network data structure to a text
+toString :: Network String -> String
+toString = toStringXML
+
+-- | Parses a string to the network data structure
+-- Returns either an error message (Left) or the network,
+-- a list of warnings (Right) and a boolean indicating whether
+-- the file was an old Dazzle file
+fromString :: String -> Either String (Network String, [String], Bool)
+
+-- xml file format
+fromString xml =
+ case fromStringXML xml of
+ Left s -> Left s
+ Right (networkComponents@(nodeAssocs, edgeAssocs, canvasSize), warnings) ->
+ case runMM (networkValid networkComponents) of
+ Left s -> Left s
+ Right _ ->
+ let network =
+ ( setNodeAssocs nodeAssocs
+ . setEdgeAssocs edgeAssocs
+ . setCanvasSize canvasSize
+ $ Network.empty
+ )
+ in Right (network, warnings, False)
+
+toStringShow :: Network String -> String
+toStringShow network =
+ show ( getNodeAssocs network
+ , getEdgeAssocs network
+ , getCanvasSize network
+ )
+
+fromStringShow :: String -> Either String (Network String)
+fromStringShow txt =
+ case reads txt of
+ ((tuple,[]):_) ->
+ let (nodeAssocs, edgeAssocs, canvasSize) = tuple
+ in Right ( setNodeAssocs nodeAssocs
+ . setEdgeAssocs edgeAssocs
+ . setCanvasSize canvasSize
+ $ Network.empty
+ )
+ _ -> Left "File is not a Blobs network"
+
+---------------------------------------------------------
+-- Convert our data type to an XML tree and print it
+---------------------------------------------------------
+
+toStringXML :: Network String -> String
+toStringXML network = render . Pretty.document $
+ Document (Prolog Nothing Nothing) emptyST
+ (Elem "Network" []
+ [ simpleString "Width" (show width)
+ , simpleString "Height" (show height)
+ , makeTag "Nodes" (nodesToXML nodeAssocs)
+ , makeTag "Edges" (edgesToXML edgeAssocs)
+ ]
+ )
+ where
+ nodeAssocs = getNodeAssocs network
+ edgeAssocs = getEdgeAssocs network
+ (width, height) = getCanvasSize network
+
+nodesToXML :: [(Int, Node String)] -> [Content]
+nodesToXML ns =
+ [ tagWithId "Node" ('N':show nodeNr)
+ [ simpleString "LabelAbove" (show (getNameAbove node))
+ , simpleString "X" (show x)
+ , simpleString "Y" (show y)
+ , escapeString "Name" (getName node)
+ ]
+ | (nodeNr, node) <- ns
+ , let position = getPosition node
+ x = doublePointX position
+ y = doublePointY position
+ ]
+
+edgesToXML :: [(Int, Edge)] -> [Content]
+edgesToXML es =
+ [ tagWithId "Edge" ('E':show edgeNr)
+ [ simpleString "From" (show (edgeFrom edge))
+ , simpleString "To" (show (edgeTo edge))
+ ]
+ | (edgeNr, edge) <- es
+ ]
+
+---- UTILITY FUNCTIONS
+
+-- Abbreviations
+makeTag :: String -> [Content] -> Content
+makeTag name children = CElem (Elem name [] children)
+
+tagWithId :: String -> String -> [Content] -> Content
+tagWithId name identity children =
+ CElem (Elem name [("id", AttValue [Left identity])] children)
+
+-- | A simple string contains no spaces or unsafe characters
+simpleString :: String -> String -> Content
+simpleString tag value =
+ CElem $ Elem tag [] [ CString False value ]
+
+-- | The string value may contain spaces and unsafe characters
+escapeString :: String -> String -> Content
+escapeString key value = CElem . (if isSafe value then id else escape) $
+ Elem key [] [ CString (any isSpace value) value ]
+ where
+ isSafe cs = all isSafeChar cs
+ isSafeChar c = isAlpha c || isDigit c || c `elem` "- ."
+
+ escape :: Element -> Element
+ escape = xmlEscape stdXmlEscaper
+
+comment :: String -> Content
+comment s = CMisc $ Comment (commentEscape s)
+
+-- Replace occurences of "-->" with "==>" in a string so that the string
+-- becomes safe for an XML comment
+commentEscape :: String -> String
+commentEscape [] = []
+commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs
+commentEscape (x:xs) = x : commentEscape xs
+
+---------------------------------------------------------
+-- "Parsing" the XML tree into our data type
+---------------------------------------------------------
+
+-- Error monad combined with an output monad for warnings
+data MessageMonad a = MM (Either String (a, [String]))
+
+-- m a -> (a -> m b) -> m b
+instance Monad MessageMonad where
+ return x = MM (Right (x, []))
+ (MM ma) >>= f = MM $ case ma of
+ Left err -> Left err
+ Right (x, ws1) ->
+ case runMM (f x) of
+ Left err -> Left err
+ Right (y, ws2) -> Right (y, ws1 ++ ws2)
+
+issueWarning :: String -> MessageMonad ()
+issueWarning s = MM (Right ((), [s]))
+
+issueError :: String -> MessageMonad a
+issueError s = MM (Left s)
+
+runMM :: MessageMonad a -> Either String (a, [String])
+runMM (MM x) = x
+
+-- End of monad
+
+type NetworkComponents =
+ ( [(NodeNr, Node String)]
+ , [(EdgeNr, Edge)]
+ , (Double, Double)
+ )
+
+-- Does not return a network because we first have to check for validity
+-- (and duplicate node number would be lost if we would build a network)
+fromStringXML :: String -> Either String (NetworkComponents, [String])
+fromStringXML s =
+ case xmlParse' "filename" s of
+ Left err -> Left err -- parse error
+ Right document -> runMM (docToNet document)
+
+docToNet :: Document -> MessageMonad NetworkComponents
+docToNet (Document prolog symbolTable element) =
+ do{ case prolog of
+ Prolog Nothing Nothing -> return ()
+ _ -> issueWarning "Ignoring non-empty prolog"
+ ; case symbolTable of
+ [] -> return ()
+ _ -> issueWarning "Ignoring non-empty symbol table"
+ ; networkTag element
+ }
+
+networkTag :: Element -> MessageMonad NetworkComponents
+networkTag (Elem "Network" attrs contents) =
+ do{ warnIfAttributes attrs "Network"
+
+ ; width <- getDoubleInsideTag "Width" contents "Network"
+ ; height <- getDoubleInsideTag "Height" contents "Network"
+
+ ; nodesElt <- findUniqueChildWithTag "Nodes" contents "Network"
+ ; nodeAssocs <- nodesTag nodesElt
+
+ ; edgesElt <- findUniqueChildWithTag "Edges" contents "Network"
+ ; edgeAssocs <- edgesTag edgesElt
+
+ ; warnAboutSuperfluousContents ["Width", "Height", "Nodes", "Edges"] contents "Network"
+
+ ; return (nodeAssocs, edgeAssocs, (width, height))
+ }
+networkTag _ =
+ issueError "Expecting \"Network\" tag as outermost tag"
+
+nodesTag :: Element -> MessageMonad [(NodeNr, Node String)]
+nodesTag (Elem _ attrs contents) =
+ do{ warnIfAttributes attrs "Nodes"
+ ; let nodeElts = findChildrenWithTag "Node" contents
+ ; nodeAssocs <- mapM nodeTag nodeElts
+ ; warnAboutSuperfluousContents ["Node"] contents "Nodes"
+ ; return nodeAssocs
+ }
+
+nodeTag :: Element -> MessageMonad (NodeNr, Node String)
+nodeTag (Elem _ attrs contents) =
+ do{ identity <- getIdAttribute attrs "Node"
+ ; when (null identity || head identity /= 'N' || not (all isDigit (tail identity))) $
+ do { issueError $ "Node identity (" ++ identity ++
+ ") should be N followed by a number" }
+ ; let nr = read (tail identity) :: Int
+
+ ; labelAbove <- getBoolInsideTag "LabelAbove" contents "Node"
+ ; x <- getDoubleInsideTag "X" contents "Node"
+ ; y <- getDoubleInsideTag "Y" contents "Node"
+ ; name <- getStringInsideTag "Name" contents "Node"
+
+ ; warnAboutSuperfluousContents
+ ["LabelAbove", "X", "Y", "Name" ]
+ contents "Node"
+
+ ; return ( nr
+ , Node.create name (DoublePoint x y) labelAbove
+ )
+ }
+
+edgesTag :: Element -> MessageMonad [(EdgeNr, Edge)]
+edgesTag (Elem _ attrs contents) =
+ do{ warnIfAttributes attrs "Edges"
+ ; let edgeElts = findChildrenWithTag "Edge" contents
+ ; edgeAssocs <- mapM edgeTag edgeElts
+ ; warnAboutSuperfluousContents ["Edge"] contents "Edges"
+ ; return edgeAssocs
+ }
+
+edgeTag :: Element -> MessageMonad (EdgeNr, Edge)
+edgeTag (Elem _ attrs contents) =
+ do{ identity <- getIdAttribute attrs "Edge"
+ ; when (null identity || head identity /= 'E' || not (all isDigit (tail identity))) $
+ do { issueError $ "Edge identity (" ++ identity ++
+ ") should be E followed by a number" }
+ ; let nr = read (tail identity) :: Int
+
+ ; fromNr <- getIntInsideTag "From" contents "Edge"
+ ; toNr <- getIntInsideTag "To" contents "Edge"
+
+ ; warnAboutSuperfluousContents ["From", "To"] contents "Edge"
+
+ ; return (nr, Edge { edgeFrom = fromNr, edgeTo = toNr })
+ }
+
+
+---- UTILITY FUNCTIONS
+
+getIdAttribute :: [Attribute] -> String -> MessageMonad String
+getIdAttribute attrs parent =
+ do{ let ids = [ value | (name, value) <- attrs, name == "id" ]
+ ; when (length ids /= 1) $
+ do{ issueError $
+ if length ids == 0 then
+ "Missing attribute \"id\" at tag " ++ show parent
+ else
+ "More than one attribute \"id\" at tag " ++ show parent
+ }
+ ; let idAttValue = head ids
+ ; identity <- case idAttValue of
+ AttValue [Left s] -> return s
+ _ -> issueError $ "Expecting string as value of \"id\" attribute at tag " ++ show parent
+ ; when (length attrs > 1) $
+ do{ issueWarning $ "Ignoring attributes other than \"id\" at tag " ++ show parent }
+ ; return identity
+ }
+
+warnAboutSuperfluousContents :: [String] -> [Content] -> String -> MessageMonad ()
+warnAboutSuperfluousContents tags contents parent =
+ when (not (null
+ [ content
+ | content <- contents
+ , case content of
+ CElem (Elem tag _ _) -> tag `notElem` tags
+ CMisc (Comment _) -> False -- do not warn about comments
+ _ -> True
+ ])) $
+ do{ issueWarning $ "Ignoring superfluous children inside tag " ++ show parent ++
+ " (expecting only " ++ commasAnd (map show tags) ++ ")"
+ }
+
+-- | Give a warning if the list of attributes is not empty
+-- For most tags we don't want attributes
+warnIfAttributes :: [Attribute] -> String -> MessageMonad ()
+warnIfAttributes attrs tagName =
+ when (not (null attrs)) $
+ do{ issueWarning $ "Ignoring unexpected attributes at " ++
+ show tagName ++ " tag"
+ }
+
+-- | Get the integer value of the string inside the child with the given tag
+getIntInsideTag :: String -> [Content] -> String -> MessageMonad Int
+getIntInsideTag tagName contents parent =
+ do{ txt <- getStringInsideTag tagName contents parent
+ ; case reads txt of
+ ((number, []):_) -> return number
+ _ -> issueError $ "Expecting string inside " ++ show tagName ++
+ " to be an integer value. String = " ++ txt
+ }
+
+-- | Get the boolean value of the string inside the child with the given tag
+getBoolInsideTag :: String -> [Content] -> String -> MessageMonad Bool
+getBoolInsideTag tagName contents parent =
+ do{ txt <- getStringInsideTag tagName contents parent
+ ; case txt of
+ "True" -> return True
+ "False" -> return False
+ _ -> issueError $ "Expecting string inside " ++ show tagName ++
+ " to be a boolean value (True or False). String = " ++ txt
+ }
+
+-- | Get the double value of the string inside the child with the given tag
+getDoubleInsideTag :: String -> [Content] -> String -> MessageMonad Double
+getDoubleInsideTag tagName contents parent =
+ do{ txt <- getStringInsideTag tagName contents parent
+ ; case parseDouble txt of
+ Nothing -> issueError $ "Expecting string inside " ++ show tagName ++
+ " to be a floating-point number. String = " ++ txt
+ Just x -> return x
+ }
+
+-- | Finds the child with the correct tag and returns the string inside it
+getStringInsideTag :: String -> [Content] -> String -> MessageMonad String
+getStringInsideTag tagName contents parent =
+ do{ elt <- findUniqueChildWithTag tagName contents parent
+ ; let (Elem _ attrs children) = xmlUnEscape stdXmlEscaper elt
+ ; warnIfAttributes attrs tagName
+ ; getString children tagName
+ }
+
+-- | Finds all children with the correct tag and returns the strings inside them
+getStringsInsideTags :: String -> [Content] -> MessageMonad [String]
+getStringsInsideTags tagName contents =
+ do{ let elts = findChildrenWithTag tagName contents
+ unescapedElts = map (xmlUnEscape stdXmlEscaper) elts
+ ; foreach unescapedElts $ \(Elem _ attrs subContents) ->
+ do{ warnIfAttributes attrs tagName
+ ; getString subContents tagName
+ }
+ }
+
+-- Expects the list of children to have length one and contain a string
+-- Returns this string and otherwise issues and error
+getString :: [Content] -> String -> MessageMonad String
+getString [CString _ txt] _ = return txt
+getString _ parent =
+ issueError $ "Expecting a string inside tag " ++ show parent
+
+instance Show Content where
+ show c = case c of
+ CElem (Elem tag _ _) -> "element with tag " ++ show tag
+ CString _ s -> "string \"" ++ s ++ "\""
+ CRef _ -> "reference"
+ CMisc (Comment _) -> "comment"
+ CMisc _ -> "processing instruction"
+
+-- | Look up a tag and make sure there is exactly one. Otherwise,
+-- an error is issued
+findUniqueChildWithTag :: String -> [Content] -> String -> MessageMonad Element
+findUniqueChildWithTag name contents parent =
+ do{ let matches = findChildrenWithTag name contents
+ ; when (length matches /= 1) $
+ issueError (
+ if (length matches == 0) then
+ "Missing tag " ++ show name ++ " inside tag " ++ show parent
+ else
+ "More than one tag " ++ show name ++ " inside tag " ++ show parent
+ )
+ ; return (head matches)
+ }
+
+-- | Looks up a tag with given name in a list of Contents
+-- It returns the elements with the correct tag
+-- (there might be 0 or more than 1)
+findChildrenWithTag :: String -> [Content] -> [Element]
+findChildrenWithTag name contents =
+ [ case content of
+ CElem elt -> elt
+ _ -> internalError "NetworkFile" "findChildrenWithTag" "should have been filtered out"
+ | content <- contents
+ , case content of
+ CElem (Elem tag _ _) -> tag == name
+ _ -> False
+ ]
+
+---------------------------------------------------------
+-- Check whether the network read from file is valid
+---------------------------------------------------------
+
+networkValid :: NetworkComponents -> MessageMonad ()
+networkValid (nodeAssocs, edgeAssocs, _)
+ | containsDuplicates nodeNrs =
+ issueError "Node numbers should be unique"
+ | containsDuplicates edgeNrs =
+ issueError "Edge numbers should be unique"
+ | otherwise =
+ do{ mapM (checkEdge nodeNrs) edgeAssocs
+ ; -- determine whether there are multiple edges between any two nodes
+ ; let multipleEdges = duplicates (map sortEdge edges)
+ ; when (not (null multipleEdges)) $
+ issueError $ "There are multiple edges between the following node pairs: " ++
+ commasAnd [ "(" ++ show f ++ ", "++ show t ++ ")"
+ | Edge f t <- multipleEdges
+ ]
+ ; return ()
+ }
+ where
+ (nodeNrs, _ ) = unzip nodeAssocs
+ (edgeNrs, edges) = unzip edgeAssocs
+
+-- Check whether edges refer to existing node numbers and whether
+-- there are no edges that start and end in the same node
+checkEdge :: [NodeNr] -> (EdgeNr, Edge) -> MessageMonad ()
+checkEdge nodeNrs (edgeNr, Edge fromNr toNr)
+ | fromNr == toNr =
+ issueError $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same"
+ | fromNr `notElem` nodeNrs = nonExistingNode fromNr
+ | toNr `notElem` nodeNrs = nonExistingNode toNr
+ | otherwise = return ()
+ where
+ nonExistingNode nodeNr =
+ issueError $ "Edge " ++ show edgeNr ++ ": refers to non-existing node " ++ show nodeNr
+
+containsDuplicates :: Eq a => [a] -> Bool
+containsDuplicates xs = length (nub xs) /= length xs
+
+-- Funny function that possibly flips an edge so that the from node number
+-- is the lowest number
+sortEdge :: Edge -> Edge
+sortEdge (Edge f t) | f < t = Edge f t
+ | otherwise = Edge t f
+
+-- Returns elements that appear more than once in a list
+duplicates :: Eq a => [a] -> [a]
+duplicates [] = []
+duplicates (x:xs)
+ | x `elem` xs = x : duplicates (filter (/= x) xs)
+ | otherwise = duplicates xs
addfile ./src/NetworkUI.hs
hunk ./src/NetworkUI.hs 1
+module NetworkUI
+ ( create
+ , getConfig, Config
+ ) where
+
+import NetworkView
+import GUIEvents
+import SafetyNet
+import State
+import StateUtil
+import Network
+import NetworkView
+import NetworkFile
+import Document
+import Common
+import CommonIO
+import qualified PersistentDocument as PD
+import qualified PDDefaults as PD
+
+import Graphics.UI.WX hiding (Child, upKey, downKey)
+import Graphics.UI.WXCore
+import Maybe
+
+data Config = NFC
+ { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height
+ , nfcFileName :: Maybe String
+ , nfcSelection :: Document.Selection
+ }
+ deriving (Read, Show)
+
+getConfig :: State -> IO Config
+getConfig state =
+ do{ theFrame <- getNetworkFrame state
+ ; (x, y) <- safeGetPosition theFrame
+ ; winSize <- get theFrame clientSize
+ ; pDoc <- getDocument state
+ ; maybeFileName <- PD.getFileName pDoc
+ ; doc <- PD.getDocument pDoc
+ ; return (NFC
+ { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize)
+ , nfcFileName = maybeFileName
+ , nfcSelection = getSelection doc
+ })
+ }
+
+create :: State ->IO ()
+create state =
+ do{ theFrame <- frame [ text := "Diagram editor" ]
+ ; setNetworkFrame theFrame state
+
+ -- Create page setup dialog and save in state
+ ; pageSetupData <- pageSetupDialogDataCreate
+ ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData
+ ; objectDelete pageSetupData
+ ; setPageSetupDialog initialPageSetupDialog state
+
+ -- Drawing area
+ ; let (width, height) = getCanvasSize Network.empty
+ ; ppi <- getScreenPPI
+ ; canvas <- scrolledWindow theFrame
+ [ virtualSize := sz (logicalToScreenX ppi width) (logicalToScreenY ppi height)
+ , scrollRate := sz 10 10
+ , bgcolor := paneBackgroundColor
+ , fullRepaintOnResize := False
+ ]
+ ; State.setCanvas canvas state
+
+ -- Dummy persistent document to pass around
+ ; pDoc <- getDocument state
+
+ -- Attach handlers to drawing area
+ ; set canvas
+ [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc
+ , on mouse := \p -> safetyNet theFrame (do mouseEvent p canvas theFrame state) --; focusOn canvas)
+ , on keyboard := \k -> safetyNet theFrame (do keyboardEvent theFrame state k) --; focusOn canvas)
+ ]
+
+ -- File menu
+ ; fileMenu <- menuPane [ text := "&File" ]
+ ; menuItem fileMenu
+ [ text := "New\tCtrl+N"
+ , on command := safetyNet theFrame $ newItem state
+ ]
+ ; menuItem fileMenu
+ [ text := "Open...\tCtrl+O"
+ , on command := safetyNet theFrame $ openItem theFrame state
+ ]
+ ; saveItem <- menuItem fileMenu
+ [ text := "Save\tCtrl+S"
+ , on command := safetyNet theFrame $ PD.save pDoc
+ ]
+ ; menuItem fileMenu
+ [ text := "Save as..."
+ , on command := safetyNet theFrame $ PD.saveAs pDoc
+ ]
+
+ ; menuLine fileMenu
+
+ ; menuItem fileMenu
+ [ text := "Page setup..."
+ , on command := safetyNet theFrame $
+ do{ psd <- getPageSetupDialog state
+ ; dialogShowModal psd
+ ; return ()
+ }
+ ]
+
+ ; menuItem fileMenu
+ [ text := "Print..."
+ , on command := safetyNet theFrame $
+ let printFun _ printInfo _ dc _ =
+ do { dcSetUserScale dc
+ (fromIntegral (sizeW (printerPPI printInfo))
+ / fromIntegral (sizeW (screenPPI printInfo)))
+ (fromIntegral (sizeH (printerPPI printInfo))
+ / fromIntegral (sizeH (screenPPI printInfo)))
+ ; paintHandler state dc
+ }
+ pageFun _ _ _ = (1, 1)
+ in
+ do{ psd <- getPageSetupDialog state
+ ; printDialog psd "Blobs print" pageFun printFun
+ }
+ ]
+
+ ; menuItem fileMenu
+ [ text := "Print preview"
+ , on command := safetyNet theFrame $
+ let printFun _ _ _ dc _ = paintHandler state dc
+ pageFun _ _ _ = (1, 1)
+ in
+ do{ psd <- getPageSetupDialog state
+ ; printPreview psd "Blobs preview" pageFun printFun
+ }
+ ]
+
+ ; menuLine fileMenu
+
+ ; menuItem fileMenu
+ [ text := "E&xit"
+ , on command := close theFrame
+ ]
+
+ -- Edit menu
+ ; editMenu <- menuPane [ text := "&Edit" ]
+ ; undoItem <- menuItem editMenu
+ [ on command := safetyNet theFrame $ do { PD.undo pDoc; repaintAll state } ]
+ ; redoItem <- menuItem editMenu
+ [ on command := safetyNet theFrame $ do { PD.redo pDoc; repaintAll state } ]
+
+ ; PD.initialise pDoc (PD.PD
+ { PD.document = Document.empty
+ , PD.history = []
+ , PD.future = []
+ , PD.limit = Nothing
+ , PD.fileName = Nothing
+ , PD.dirty = False
+ , PD.saveToDisk = saveToDisk theFrame
+ , PD.updateUndo = PD.defaultUpdateUndo undoItem
+ , PD.updateRedo = PD.defaultUpdateRedo redoItem
+ , PD.updateSave = PD.defaultUpdateSave saveItem
+ , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame "Blobs"
+ , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame "Blobs"
+ , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions
+ })
+
+ -- Layout the main window
+ ; set theFrame
+ [ menuBar := [ fileMenu, editMenu ]
+ , layout := minsize (sz 250 150) $ fill $ widget canvas
+ , on closing := safetyNet theFrame $ exit state
+ ]
+
+ ; set theFrame
+ [ position := pt 20 20
+ , clientSize := sz 200 200
+ ]
+ }
+
+paintHandler :: State -> DC () -> IO ()
+paintHandler state dc =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; drawCanvas doc dc
+ }
+
+extensions :: [(String, [String])]
+extensions = [ ("Blobs files (.blb)", ["*.blb"]) ]
+
+mouseEvent :: EventMouse -> ScrolledWindow () -> Frame () -> State -> IO ()
+mouseEvent eventMouse canvas theFrame state = case eventMouse of
+ MouseLeftDown mousePoint mods
+ | shiftDown mods -> leftMouseDownWithShift mousePoint state
+ | otherwise -> mouseDown True mousePoint theFrame state
+ MouseRightDown mousePoint _ ->
+ mouseDown False mousePoint theFrame state
+ MouseLeftDrag mousePoint _ ->
+ leftMouseDrag mousePoint canvas state
+ MouseLeftUp mousePoint _ ->
+ leftMouseUp mousePoint state
+ _ ->
+ return ()
+
+keyboardEvent :: Frame () -> State -> EventKey -> IO ()
+keyboardEvent theFrame state (EventKey theKey _ _) =
+ case theKey of
+ KeyDelete -> deleteKey state
+ KeyBack -> backspaceKey state
+ KeyF2 -> f2Key theFrame state
+ KeyUp -> upKey state
+ KeyDown -> downKey state
+ _ -> propagateEvent
+
+closeDocAndThen :: State -> IO () -> IO ()
+closeDocAndThen state action =
+ do{ pDoc <- getDocument state
+ ; continue <- PD.isClosingOkay pDoc
+ ; when continue $ action
+ }
+
+newItem :: State -> IO ()
+newItem state =
+ closeDocAndThen state $
+ do{ pDoc <- getDocument state
+ ; PD.resetDocument Nothing Document.empty pDoc
+ ; repaintAll state
+ }
+
+openItem :: Frame () -> State -> IO ()
+openItem theFrame state =
+ do{ mbfname <- fileOpenDialog
+ theFrame
+ False -- change current directory
+ True -- allowReadOnly
+ "Open File"
+ extensions
+ "" "" -- no default directory or filename
+ ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame)
+ }
+
+-- Third argument: Nothing means exceptions are ignored (used in Configuration)
+-- Just f means exceptions are shown in a dialog on top of frame f
+openNetworkFile :: String -> State -> Maybe (Frame ()) -> IO ()
+openNetworkFile fname state exceptionsFrame =
+ closeDocAndThen state $
+ flip catch
+ (\exc -> case exceptionsFrame of
+ Nothing -> return ()
+ Just f -> errorDialog f "Open network"
+ ( "Error while opening '" ++ fname ++ "'. \n\n"
+ ++ "Reason: " ++ show exc)
+ ) $
+ do{ contents <- strictReadFile fname
+ ; let errorOrNetwork = NetworkFile.fromString contents
+ ; case errorOrNetwork of {
+ Left err -> ioError (userError err);
+ Right (network, warnings, oldFormat) ->
+ do{ -- "Open" document
+ ; let newDoc = setNetwork network Document.empty
+ ; pDoc <- getDocument state
+ ; PD.resetDocument (if null warnings then Just fname else Nothing) newDoc pDoc
+ ; applyCanvasSize state
+ ; when (not (null warnings)) $
+ case exceptionsFrame of
+ Nothing -> return ()
+ Just f ->
+ do{ errorDialog f "File read warnings"
+ ( "Warnings while reading file " ++ show fname ++ ":\n\n"
+ ++ unlines ( map ("* " ++) (take 10 warnings)
+ ++ if length warnings > 10 then ["..."] else []
+ )
+ ++ unlines
+ [ ""
+ , "Most likely you are reading a file that is created by a newer version of Blobs. If you save this file with"
+ , "this version of Blobs information may be lost. For safety the file name is set to \"untitled\" so that you do"
+ , "not accidentaly overwrite the file"
+ ]
+ )
+ ; PD.setFileName pDoc Nothing
+ }
+ ; when oldFormat $
+ do{ case exceptionsFrame of
+ Nothing -> return ()
+ Just f ->
+ errorDialog f "File read warning" $
+ unlines
+ [ "The file you opened has the old Blobs file format which will become obsolete in newer versions of Blobs."
+ , "When you save this network, the new file format will be used. To encourage you to do so the network has"
+ , "been marked as \"modified\"."
+ ]
+ ; PD.setDirty pDoc True
+ }
+ ; -- Redraw
+ ; repaintAll state
+ }}}
+
+-- | Get the canvas size from the network and change the size of
+-- the widget accordingly
+applyCanvasSize :: State -> IO ()
+applyCanvasSize state =
+ do{ pDoc <- getDocument state
+ ; doc <- PD.getDocument pDoc
+ ; let network = getNetwork doc
+ (width, height) = getCanvasSize network
+ ; canvas <- getCanvas state
+ ; ppi <- getScreenPPI
+ ; set canvas [ virtualSize := sz (logicalToScreenX ppi width)
+ (logicalToScreenY ppi height) ]
+ }
+
+saveToDisk :: Frame () -> String -> Document.Document -> IO Bool
+saveToDisk theFrame fileName doc =
+ safeWriteFile theFrame fileName (NetworkFile.toString (getNetwork doc))
+
+exit :: State -> IO ()
+exit state =
+ closeDocAndThen state $ propagateEvent
addfile ./src/NetworkView.hs
hunk ./src/NetworkView.hs 1
+module NetworkView
+ ( drawCanvas
+ , clickedNode
+ , clickedEdge
+ ) where
+
+import Constants
+import CommonIO
+import qualified Node
+import Network
+import Document
+import Colors
+import Common
+
+import Math
+import Graphics.UI.WX hiding (Vector)
+import Graphics.UI.WXCore hiding (Document, screenPPI)
+import Graphics.UI.WXCore.Draw
+import Maybe
+
+import Prelude hiding (catch)
+import Exception
+
+drawCanvas :: Document -> DC () -> IO ()
+drawCanvas doc dc =
+ do{
+
+ -- Scale if the DC we are drawing to has a different PPI from the screen
+ -- Printing, nudge, nudge
+ ; dcPPI <- dcGetPPI dc
+ ; screenPPI <- getScreenPPI
+ ; when (dcPPI /= screenPPI) $
+ dcSetUserScale dc
+ (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI ))
+ (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI ))
+
+ -- Set font
+ ; set dc [ fontFamily := FontDefault, fontSize := 10 ]
+
+ ; catch (reallyDrawCanvas doc screenPPI dc)
+ (\e -> drawText dc ("Exception while drawing: " ++ show e) (pt 50 50) [])
+ }
+
+reallyDrawCanvas :: Document -> Size -> DC () -> IO ()
+reallyDrawCanvas doc ppi dc =
+ do{
+ -- draw edges, highlight the selected one (if any)
+ ; mapM (\edge -> drawEdge edge []) (getEdges network)
+ ; case theSelection of
+ EdgeSelection edgeNr -> do
+ drawEdge (getEdge edgeNr network) kSELECTED_OPTIONS
+ _ -> return ()
+
+ -- draw nodes, highlight the selected one (if any)
+ ; mapM (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network)
+ ; case theSelection of
+ NodeSelection nodeNr ->
+ drawNode nodeNr ( kSELECTED_OPTIONS ++ [ penColor := activeSelectionColor ])
+ _ -> return ()
+
+ -- canvas size rectangle
+ ; let (width, height) = Network.getCanvasSize (getNetwork doc)
+ ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent]
+ }
+ where
+ network = getNetwork doc
+ theSelection = getSelection doc
+
+ drawNode :: Int -> [Prop (DC ())] -> IO ()
+ drawNode nodeNr options =
+ do{
+ -- draw node
+ ; logicalCircle ppi dc center kNODE_RADIUS
+ (options ++ solidFill nodeColor)
+
+ -- draw label background
+ ; (textWidth, textHeight) <- logicalGetTextExtent ppi dc nodeName
+ ; let textY = if Node.getNameAbove node
+ then y - kNODE_RADIUS - kARROW_SIZE - textHeight
+ else y + kNODE_RADIUS + kARROW_SIZE
+ textX = x - textWidth / 2
+ horizontalMargin = 0.2 -- centimeters
+ verticalMargin = 0.01 -- centimeters
+ ; logicalRect ppi dc
+ (textX - horizontalMargin) textY
+ (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin)
+ (solidFill labelBackgroundColor)
+
+ -- draw label text
+ ; logicalText ppi dc (DoublePoint textX textY) nodeName []
+ }
+ where
+ node = getNode nodeNr network
+ center@(DoublePoint { doublePointX = x, doublePointY = y }) =
+ Node.getPosition node
+ nodeName = Node.getName node
+
+ drawEdge :: Edge -> [Prop (DC ())] -> IO ()
+ drawEdge
+ (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr })
+ options =
+ do{ logicalLine ppi dc pt1 pt2 options
+ ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill black)
+ }
+ where
+ fromNode = getNode fromNodeNr network
+ toNode = getNode toNodeNr network
+
+ fromPoint = Node.getPosition fromNode
+ toPoint = Node.getPosition toNode
+
+ edgeVector = toPoint `subtractDoublePointVector` fromPoint
+ totalLen = vectorLength edgeVector
+ angle = vectorAngle edgeVector
+
+ pt1 = translatePolar angle kNODE_RADIUS fromPoint
+ pt2 = translatePolar angle (totalLen - kNODE_RADIUS) fromPoint
+
+ tr1 = translatePolar (angle + pi + pi / 6) kARROW_SIZE pt2
+ tr2 = translatePolar (angle + pi - pi / 6) kARROW_SIZE pt2
+
+solidFill :: Color -> [Prop (DC ())]
+solidFill colour = [ brushKind := BrushSolid, brushColor := colour ]
+
+-- | Finds which node of the network is clicked by the mouse, if any
+clickedNode :: DoublePoint -> Document -> Maybe Int
+clickedNode clickedPoint doc =
+ let network = getNetwork doc
+ nodeAssocs = case getSelection doc of
+ NodeSelection nodeNr -> [(nodeNr, getNode nodeNr network)]
+ _ -> []
+ ++ reverse (getNodeAssocs network)
+ in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of
+ [] -> Nothing
+ ((i, _):_) -> Just i
+
+nodeContains :: Node.Node a -> DoublePoint -> Bool
+nodeContains node clickedPoint =
+ distancePointPoint (Node.getPosition node) clickedPoint
+ < kNODE_RADIUS
+
+-- | Finds which edge of the network is clicked by the mouse, if any
+clickedEdge :: DoublePoint -> Network a -> Maybe Int
+clickedEdge clickedPoint network =
+ let assocs = getEdgeAssocs network
+ in case filter (\(_, edge) -> edgeContains edge clickedPoint network) assocs of
+ [] -> Nothing
+ ((i, _):_) -> Just i
+
+edgeContains :: Edge -> DoublePoint -> Network a -> Bool
+edgeContains
+ (Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr })
+ clickedPoint network =
+ let p0 = Node.getPosition (getNode fromNodeNr network)
+ p1 = Node.getPosition (getNode toNodeNr network)
+ p = clickedPoint
+ in distanceSegmentPoint p0 p1 p < kEDGE_CLICK_RANGE
+
+-- Drawing operations in logical coordinates
+
+logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO ()
+logicalCircle ppi dc center radius options =
+ circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options
+
+logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO ()
+logicalRect ppi dc x y width height options =
+ drawRect dc
+ (rect
+ (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y))
+ (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height)))
+ options
+
+logicalText :: Size -> DC () -> DoublePoint -> String -> [Prop (DC ())] -> IO ()
+logicalText ppi dc pos txt options =
+ drawText dc txt (logicalToScreenPoint ppi pos) options
+
+logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO ()
+logicalLine ppi dc fromPoint toPoint options =
+ line dc (logicalToScreenPoint ppi fromPoint)
+ (logicalToScreenPoint ppi toPoint) options
+
+logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO ()
+logicalPoly ppi dc points options =
+ polygon dc (map (logicalToScreenPoint ppi) points) options
+
+logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double)
+logicalGetTextExtent ppi dc txt =
+ do{ textSize <- getTextExtent dc txt
+ ; return
+ ( screenToLogicalX ppi (sizeW textSize)
+ , screenToLogicalY ppi (sizeH textSize)
+ )
+ }
addfile ./src/Node.hs
hunk ./src/Node.hs 1
+module Node
+ ( Node
+ , create
+ , getNameAbove, setNameAbove
+ , getName, setName
+ , getPosition, setPosition
+ ) where
+
+import Math
+
+data Node a = Node
+ { nodePoint :: DoublePoint -- ^ the position of the node on screen
+ , nodeName :: !String
+ , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False)
+ } deriving (Show, Read)
+
+create :: String -> DoublePoint -> Bool -> Node a
+create name position nameAbove =
+ Node
+ { nodeName = name
+ , nodePoint = position
+ , nodeNameAbove = nameAbove
+ }
+
+getNameAbove :: Node a -> Bool
+getNameAbove node = nodeNameAbove node
+
+getName :: Node a -> String
+getName node = nodeName node
+
+getPosition :: Node a -> DoublePoint
+getPosition node = nodePoint node
+
+setPosition :: DoublePoint -> Node a -> Node a
+setPosition position node = node { nodePoint = position }
+
+setName :: String -> Node a -> Node a
+setName name node = node { nodeName = name }
+
+-- | Set whether the name should appear above (True) or below (False) the node
+setNameAbove :: Bool -> Node a -> Node a
+setNameAbove above node = node { nodeNameAbove = above }
addfile ./src/PDDefaults.hs
hunk ./src/PDDefaults.hs 1
+{-| Module : PDDefaults
+ Author : Arjan van IJzendoorn
+ License : do whatever you like with this
+
+ Maintainer : afie@cs.uu.nl
+
+ Some defaults for the field of the persistent document
+ record. For example, the default undo update function
+ changes the text of a menu item to reflect what will be
+ undo and disables it if there is nothing to be undone.
+ You might want more than the defaults if you have a
+ more advanced GUI. Let's say you also have a button
+ in a toolbar to undo, then you might want to gray out
+ that button, too, if there is nothing to be undone.
+-}
+
+module PDDefaults where
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore(wxID_CANCEL)
+
+type Extensions = [(String, [String])]
+
+-- Update the menu item "Undo" to show which
+-- action will be undone. If there is nothing
+-- to undo the corresponding menu item is disabled
+defaultUpdateUndo :: MenuItem () -> Bool -> String -> IO ()
+defaultUpdateUndo undoItem enable message = [_$_]
+ set undoItem
+ [ text := "Undo " ++ message ++ "\tCtrl+Z"
+ , enabled := enable
+ ]
+ [_$_]
+defaultUpdateRedo :: MenuItem () -> Bool -> String -> IO ()
+defaultUpdateRedo redoItem enable message = [_$_]
+ set redoItem
+ [ text := "Redo " ++ message ++ "\tCtrl+Y"
+ , enabled := enable
+ ]
+
+-- Enable the save item only if the document is dirty
+defaultUpdateSave :: MenuItem () -> Bool -> IO ()
+defaultUpdateSave saveItem enable = [_$_]
+ set saveItem [ enabled := enable ]
+
+-- Update the title bar: program name - document name followed by "(modified)" if
+-- the document is dirty
+defaultUpdateTitlebar :: Frame () -> String -> Maybe String -> Bool -> IO ()
+defaultUpdateTitlebar theFrame programName theFileName modified = [_$_]
+ let newTitle = programName
+ ++ " - " [_$_]
+ ++ (case theFileName of Nothing -> "untitled"; Just name -> name) [_$_]
+ ++ (if modified then " (modified)" else "")
+ in set theFrame [ text := newTitle ]
+
+-- | defaultSaveChangesDialog shows a dialog with three buttons with corresponding
+-- return values: Don't Save -> Just False, Save -> Just True
+-- Cancel -> Nothing
+defaultSaveChangesDialog :: Frame () -> String -> IO (Maybe Bool)
+defaultSaveChangesDialog parentWindow theProgramName = [_$_]
+ do{ d <- dialog parentWindow [text := theProgramName]
+ ; p <- panel d []
+ ; msg <- staticText p [text := "Do you want to save the changes?"]
+ ; dontsaveB <- button p [text := "Don't Save"]
+ ; saveB <- button p [text := "Save"] [_$_]
+ ; cancelB <- button p [text := "Cancel", identity := wxID_CANCEL ] [_$_]
+ ; set d [layout := margin 10 $ container p $ [_$_]
+ column 10 [ hfill $ widget msg
+ , row 50 [ floatBottomLeft $ widget dontsaveB [_$_]
+ , floatBottomRight $ row 5 [ widget saveB, widget cancelB]
+ ]
+ ]
+ ] [_$_]
+ ; set p [ defaultButton := saveB ] [_$_]
+ ; showModal d $ \stop -> [_$_]
+ do set dontsaveB [on command := stop (Just False) ]
+ set saveB [on command := stop (Just True) ]
+ set cancelB [on command := stop Nothing ]
+ }
+
+defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String)
+defaultSaveAsDialog theFrame extensions theFileName =
+ fileSaveDialog
+ theFrame
+ False -- remember current directory
+ True -- overwrite prompt
+ "Save file"
+ extensions
+ "" -- directory
+ (case theFileName of Nothing -> ""; Just name -> name) -- initial file name
+
addfile ./src/PersistentDocument.hs
hunk ./src/PersistentDocument.hs 1
+{-| Module : PersistentDocument
+ Author : Arjan van IJzendoorn
+ License : do whatever you like with this
+
+ Maintainer : afie@cs.uu.nl
+
+ The persistent document abstraction takes care of dealing
+ with a document you want to open from and save to disk and
+ that supports undo. This functionality can be used by editors
+ of arbitrary documents and saves you a lot of quite subtle
+ coding. You only need to initialise a record with things like
+ your document, the file name and call-back functions. After
+ this, the framework takes care of the hard work. The framework
+ is highly parametrisable but there are defaults for many
+ parameters.
+
+ The features in detail:
+ - unlimited undo & redo buffers (or limited, if you choose to)
+ - undo and redo items show what will be undone / redone
+ (e.g. "Undo delete node")
+ - undo and redo items are disabled if there is nothing to undo or redo
+ - maintains a dirty bit that tells you whether the document has
+ changed with respect to the version on disk
+ - the save menu item can be disabled if the document is not dirty
+ - the title bar can be updated to show the program name, the file name
+ and whether the document is dirty (shown as "modified")
+ - when trying to close the document, the user is asked whether he/she
+ wants to save the changes (if needed)
+ - handles interaction between saving a document and the dirty bits
+ of the document and of the documents in the history and future
+ - properly handles Cancel or failure at any stage, e.g. the user
+ closes a dirty document with no file name, "Do you want to save
+ the changes" dialog is shown, user selects "Save", a Save as
+ dialog is opened, user selects a location that happens to be
+ read-only, saving fails and the closing of the document is
+ cancelled.
+-}
+
+module PersistentDocument
+ ( PersistentDocument, PDRecord(..)
+
+ , PersistentDocument.dummy
+ , initialise
+ , resetDocument
+
+ , setDocument, updateDocument
+ , superficialSetDocument, superficialUpdateDocument
+
+ , getDocument
+ , getFileName, setFileName
+ , setDirty
+
+ , undo, redo
+ , save, saveAs, isClosingOkay
+ ) where
+
+import IOExts(IORef, newIORef, writeIORef, readIORef)
+import Monad(when)
+
+-- | A persistent document is a mutable variable. This way functions
+-- operating on a document do not have to return the new value but
+-- simply update it.
+type PersistentDocument a = IORef (PDRecord a)
+
+-- | The persistent document record maintains all information needed
+-- for undo, redo and file management
+data PDRecord a = PD
+ { document :: a
+
+ -- UNDO & REDO
+ , history :: [(String, Bool, a)]
+ -- ^ A history item contains a message (what will be undone),
+ -- the dirty bit and a copy of the document
+ , future :: [(String, Bool, a)]
+ -- ^ See history
+ , limit :: Maybe Int
+ -- ^ Maximum number of items of undo history. Or no limit
+ -- in the case of Nothing
+
+ -- FILE MANAGEMENT
+ , fileName :: Maybe String
+ -- ^ Nothing means no file name yet (untitled)
+ , dirty :: Bool
+ -- ^ Has the document changed since saving?
+
+ -- CALL-BACK FUNCTIONS
+ , updateUndo :: Bool -> String -> IO ()
+ -- ^ This callback is called when the undo status changes. First parameter
+ -- means enable (True) or disable (False). Second parameter is the message
+ -- of the first item in the history
+ , updateRedo :: Bool -> String -> IO ()
+ -- ^ See updateUndo
+ , updateSave :: Bool -> IO ()
+ -- ^ This call-back is called when the save status changes. The boolean
+ -- indicates whether save is enabled (dirty document) or disabled (not dirty)
+ , updateTitleBar :: Maybe String -> Bool -> IO ()
+ -- ^ This call-back is called when the title bar information changes:
+ -- file name and modified or not.
+ , saveToDisk :: String -> a -> IO Bool
+ -- ^ This callback should actually save the document to disk. It should
+ -- return False if saving fails (no permission, disk full...)
+ , saveChangesDialog :: IO (Maybe Bool)
+ -- ^ This call-back is called when the user should be prompted whether
+ -- he/she wants to save the changes or not. Results:
+ -- Don't Save -> Just False, Save -> Just True, Cancel -> Nothing
+ , saveAsDialog :: Maybe String -> IO (Maybe String)
+ -- ^ This call-back is called when the user should specify a
+ -- location and a name for the file. The parameter is the current
+ -- file name of the document
+ }
+
+-- | A dummy persistent document is needed because you need something to pass
+-- to the command handlers of menu items BEFORE you can initialse the
+-- persistent document with those menu items
+dummy :: IO (PersistentDocument a)
+dummy = newIORef (error $ "PersistentDocument.empty: call initialise before using "
+ ++ "the persistent document")
+
+-- | Initialise the persistent document with menu items (undo, redo, save),
+-- information needed for open & save dialogs, for saving and for updating the
+-- title bar
+initialise :: PersistentDocument a -> PDRecord a -> IO ()
+initialise pDocRef pDoc =
+ do{ writeIORef pDocRef pDoc
+ ; updateGUI pDocRef
+ }
+
+-- | Clear the document and start with a given document with given file name
+-- This function is typically called when you open a new document from disk
+-- or start a fresh document that should replace the current document
+resetDocument :: Maybe String -> a -> PersistentDocument a -> IO ()
+resetDocument theFileName doc pDocRef =
+ do{ updateIORef pDocRef (\pDoc -> pDoc
+ { document = doc
+ , history = []
+ , future = []
+ , fileName = theFileName
+ , dirty = False
+ })
+ ; updateGUI pDocRef
+ }
+
+-- | Get the actual document stored within the persistent document
+getDocument :: PersistentDocument a -> IO a
+getDocument pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; return (document pDoc)
+ }
+
+-- | Get the file name stored within the persistent document
+getFileName :: PersistentDocument a -> IO (Maybe String)
+getFileName pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; return (fileName pDoc)
+ }
+
+-- | Get the file name stored within the persistent document
+setFileName :: PersistentDocument a -> Maybe String -> IO ()
+setFileName pDocRef maybeName =
+ do{ pDoc <- readIORef pDocRef
+ ; writeIORef pDocRef (pDoc { fileName = maybeName })
+ ; updateGUI pDocRef
+ }
+
+setDirty :: PersistentDocument a -> Bool -> IO ()
+setDirty pDocRef newDirtyBit =
+ do{ pDoc <- readIORef pDocRef
+ ; writeIORef pDocRef (pDoc { dirty = newDirtyBit })
+ ; updateGUI pDocRef
+ }
+
+-- | Replace the document inside the persistent document. The current
+-- document is remembered in the history list along with the given
+-- message. The future list is cleared.
+setDocument :: String -> a -> PersistentDocument a -> IO ()
+setDocument message newDoc pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; let applyLimit = case limit pDoc of
+ Nothing -> id
+ Just nr -> take nr
+ newPDoc =
+ pDoc
+ { document = newDoc
+ , history = applyLimit $ (message,dirty pDoc,document pDoc):history pDoc
+ , future = []
+ , dirty = True
+ }
+ ; writeIORef pDocRef newPDoc
+ ; updateGUI pDocRef
+ }
+
+
+-- | Get document, apply function, set document
+updateDocument :: String -> (a -> a) -> PersistentDocument a -> IO ()
+updateDocument message fun pDocRef =
+ do{ doc <- getDocument pDocRef
+ ; setDocument message (fun doc) pDocRef
+ }
+
+-- | Replace the document without remembering the old document in
+-- the history. Superficial updates are useful if something as
+-- volatile as a selection is part of your document. If the selection
+-- changes you don't want to be able to undo it or to mark
+-- the document as dirty
+superficialSetDocument :: a -> PersistentDocument a -> IO ()
+superficialSetDocument newDoc pDocRef =
+ updateIORef pDocRef (\pDoc -> pDoc { document = newDoc })
+
+-- | Get document, apply function, superficial set document
+superficialUpdateDocument :: (a -> a) -> PersistentDocument a -> IO ()
+superficialUpdateDocument fun pDocRef =
+ do{ doc <- getDocument pDocRef
+ ; superficialSetDocument (fun doc) pDocRef
+ }
+
+-- | Check whether closing the document is okay. If the document
+-- is dirty, the user is asked whether he/she wants to save the
+-- changes. Returns False if this process is cancelled or fails
+-- at any point.
+isClosingOkay :: PersistentDocument a -> IO Bool
+isClosingOkay pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; if not (dirty pDoc) then return True else
+ do{ result <- saveChangesDialog pDoc
+ ; case result of
+ Nothing -> return False
+ Just True ->
+ do{ hasBeenSaved <- save pDocRef
+ ; return hasBeenSaved
+ }
+ Just False -> return True
+ }}
+
+-- | Save should be called when "Save" is selected from the file menu.
+-- If there is no file name yet, this function acts as if "Save as"
+-- was called. It returns False if saving is cancelled or fails.
+save :: PersistentDocument a -> IO Bool
+save pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; case fileName pDoc of
+ Nothing -> saveAs pDocRef
+ Just name -> performSave name pDocRef
+ }
+
+-- | saveAs should be called when "Save As" is selected from the file menu.
+-- A dialog is shown where the user can select a location to save document.
+-- This function returns False if saving is cancelled or fails.
+saveAs :: PersistentDocument a -> IO Bool
+saveAs pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; mbfname <- saveAsDialog pDoc (fileName pDoc)
+ ; case mbfname of
+ Just fname -> performSave fname pDocRef
+ Nothing -> return False
+ }
+
+
+-- | The current document is stored in the future list
+-- and the first element of the history list is taken
+-- as the new document
+undo :: PersistentDocument a -> IO ()
+undo pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; when (not (null (history pDoc))) $
+ do{ let (msg, newDirty, newDoc) = head (history pDoc)
+ newPDoc = pDoc
+ { document = newDoc
+ , dirty = newDirty
+ , history = tail (history pDoc)
+ , future = (msg, dirty pDoc, document pDoc) : future pDoc
+ }
+ ; writeIORef pDocRef newPDoc
+ ; updateGUI pDocRef
+ }}
+
+-- | The current document is stored in the history list
+-- and the first element of the future list is taken
+-- as the new document
+redo :: PersistentDocument a -> IO ()
+redo pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; when (not (null (future pDoc))) $
+ do{ let (msg, newDirty, newDoc) = head (future pDoc)
+ newPDoc = pDoc
+ { document = newDoc
+ , dirty = newDirty
+ , future = tail (future pDoc)
+ , history = (msg, dirty pDoc, document pDoc) : history pDoc
+ }
+ ; writeIORef pDocRef newPDoc
+ ; updateGUI pDocRef
+ }}
+
+-- FUNCTIONS THAT ARE NOT EXPORTED
+
+updateIORef :: IORef a -> (a -> a) -> IO ()
+updateIORef var fun = do { x <- readIORef var; writeIORef var (fun x) }
+
+-- Perform the actual save to disk. If this fails False is returned
+-- otherwise the file name is set and the dirty bit is cleared. The
+-- dirty bits of history and future documents are set.
+performSave :: String -> PersistentDocument a -> IO Bool
+performSave name pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; hasBeenSaved <- (saveToDisk pDoc) name (document pDoc)
+ ; if not hasBeenSaved then return False else
+ do{ writeIORef pDocRef (pDoc { fileName = Just name })
+ ; updateDirtyBitsOnSave pDocRef
+ ; updateGUI pDocRef
+ ; return True
+ }}
+
+-- updateDirtyBitsOnSave clears the dirty bit for the
+-- current document and sets the dirty bits of all
+-- documents in history and future lists
+updateDirtyBitsOnSave :: PersistentDocument a -> IO ()
+updateDirtyBitsOnSave pDocRef =
+ updateIORef pDocRef (\pDoc -> pDoc
+ { history = map makeDirty (history pDoc)
+ , future = map makeDirty (future pDoc)
+ , dirty = False
+ })
+ where
+ makeDirty (msg, _, doc) = (msg, True, doc)
+
+-- Shorthand to call all call-backs that update the GUI
+updateGUI :: PersistentDocument a -> IO ()
+updateGUI pDocRef =
+ do{ pDoc <- readIORef pDocRef
+ ; case history pDoc of
+ [] -> updateUndo pDoc False ""
+ ((msg, _, _):_) -> updateUndo pDoc True msg
+ ; case future pDoc of
+ [] -> updateRedo pDoc False ""
+ ((msg, _, _):_) -> updateRedo pDoc True msg
+ ; updateSave pDoc (dirty pDoc)
+ ; updateTitleBar pDoc (fileName pDoc) (dirty pDoc)
+ }
addfile ./src/SafetyNet.hs
hunk ./src/SafetyNet.hs 1
+module SafetyNet where
+
+import Graphics.UI.WX hiding (window)
+import Prelude hiding (catch)
+import Exception
+
+safetyNet :: Window a -> IO b -> IO ()
+safetyNet window computation =
+ do{ catch
+ (do { computation; return () })
+ (handler window)
+ ; return ()
+ }
+
+handler :: Window a -> Exception -> IO ()
+handler window exception =
+ do{ putStrLn $ "SafetyNet exception: " ++ show exception
+ ; errorDialog window "Exception"
+ ( "An exception occurred; please report the following text exactly to the makers: \n\n"
+ ++ show exception ++ "\n\n"
+ ++ "Please save the network under a different name and quit Blobs"
+ )
+ }
addfile ./src/State.hs
hunk ./src/State.hs 1
+module State
+ ( State
+ , State.empty
+ , ToolWindow(..)
+
+ , getDocument
+ , getDragging, setDragging
+ , getCanvas, setCanvas
+ , getNetworkFrame, setNetworkFrame
+ , getPageSetupDialog, setPageSetupDialog
+ ) where
+
+import Document
+import Math
+import qualified PersistentDocument as PD
+
+import Graphics.UI.WX
+import Graphics.UI.WXCore hiding (Document, ToolWindow)
+
+type State = Var StateRecord
+
+data StateRecord = St
+ { stDocument :: PD.PersistentDocument Document
+ , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node)
+ , stNetworkFrame :: Frame ()
+ , stCanvas :: ScrolledWindow ()
+ , stPageSetupDialog :: PageSetupDialog ()
+ }
+
+data ToolWindow = TW
+ { twRepaint :: IO ()
+ , twFrame :: Frame ()
+ }
+
+empty :: IO State
+empty =
+ do{ dummy <- PD.dummy
+
+ ; varCreate (St
+ { stDocument = dummy
+ , stNetworkFrame = error "State.empty: network frame has not been set"
+ , stDragging = Nothing
+ , stCanvas = error "State.empty: canvas has not been set"
+ , stPageSetupDialog = error "State.empty: page setup dialog has not been set"
+ })
+ }
+
+-- Getters
+
+getDocument :: State -> IO (PD.PersistentDocument Document)
+getDocument = getFromState stDocument
+
+getDragging :: State -> IO (Maybe (Bool, DoublePoint))
+getDragging = getFromState stDragging
+
+getNetworkFrame :: State -> IO (Frame ())
+getNetworkFrame = getFromState stNetworkFrame
+
+getCanvas :: State -> IO (ScrolledWindow ())
+getCanvas = getFromState stCanvas
+
+getPageSetupDialog :: State -> IO (PageSetupDialog ())
+getPageSetupDialog = getFromState stPageSetupDialog
+
+-- Setters
+
+setDragging :: Maybe (Bool, DoublePoint) -> State -> IO ()
+setDragging theDragging stateRef =
+ varUpdate_ stateRef (\state -> state { stDragging = theDragging })
+
+setNetworkFrame :: Frame () -> State -> IO ()
+setNetworkFrame networkFrame stateRef =
+ varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame })
+
+setCanvas :: ScrolledWindow () -> State -> IO ()
+setCanvas canvas stateRef =
+ varUpdate_ stateRef (\state -> state { stCanvas = canvas })
+
+setPageSetupDialog :: PageSetupDialog () -> State -> IO ()
+setPageSetupDialog thePageSetupDialog stateRef =
+ varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog })
+
+-- Utility functions
+
+getFromState :: (StateRecord -> a) -> State -> IO a
+getFromState selector stateRef = do
+ state <- varGet stateRef
+ return (selector state)
+
+varUpdate_ :: Var a -> (a -> a) -> IO ()
+varUpdate_ var fun = do { varUpdate var fun; return () }
addfile ./src/StateUtil.hs
hunk ./src/StateUtil.hs 1
+module StateUtil
+ ( repaintAll
+ , getNetworkName
+ ) where
+
+import State
+import Common
+import qualified PersistentDocument as PD
+
+import Maybe
+import Graphics.UI.WX
+
+repaintAll :: State -> IO ()
+repaintAll state =
+ do{ canvas <- getCanvas state
+ ; Graphics.UI.WX.repaint canvas
+ }
+
+getNetworkName :: State -> IO String
+getNetworkName state =
+ do { pDoc <- getDocument state
+ ; mFilename <- PD.getFileName pDoc
+ ; case mFilename of
+ Just filename -> return $ removeExtension filename
+ Nothing -> return "Untitled"
+ }
addfile ./src/XTC.hs
hunk ./src/XTC.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+{-
+ | Module : XTC
+ Maintainer : martijn@cs.uu.nl
+ [_$_]
+ eXtended & Typed Controls for wxHaskell
+ [_$_]
+ [_$_]
+ TODO: - how to handle duplicates (up to presentation) in item lists
+ - check (!!) error that occured in Dazzle
+ - implement tSelecting and other events
+ - Check: instance selection etc. <Control> () or <Control> a
+ - Maybe it should be () to prevent subclassing (which may cause a problem
+ with the client data field
+ - Items w String??
+ - value of selection when nothing selected? add Maybe?
+ - WxObject vs Object?
+-}
+
+module XTC ( Labeled( toLabel ),
+ , TValued( tValue ),
+ , TItems( tItems ),
+ , TSelection( tSelection ),
+ , TSelections( tSelections ),
+ , RadioView, mkRadioView, mkRadioViewEx
+ , ListView, mkListView, mkListViewEx
+ , MultiListView, mkMultiListView, mkMultiListViewEx
+ , ChoiceView, mkChoiceView, mkChoiceViewEx
+ , ComboView, mkComboView, mkComboViewEx
+ , ValueEntry, mkValueEntry, mkValueEntryEx
+ , change -- TODO wx should take care of this
+-- , ObservableVar, mkObservableVar -- temporarily disabled due to name clash
+ , xtc -- for testing, exported to avoid a warning in Dazzle
+ ) where
+
+import Graphics.UI.WX hiding (window, label)
+import qualified Graphics.UI.WX
+import Graphics.UI.WXCore hiding (label, Event)
+import List
+import Maybe
+
+class Labeled x where
+ toLabel :: x -> String
+
+instance Labeled String where
+ toLabel str = str
+
+class Selection w => TSelection x w | w -> x where
+ tSelection :: Attr w x
+
+class Selections w => TSelections x w | w -> x where
+ tSelections :: Attr w [x]
+
+class Items w String => TItems x w | w -> x where
+ tItems :: Attr w [x]
+
+
+-- RadioView
+
+data CRadioView x b
+
+type RadioView x b = RadioBox (CRadioView x b)
+
+-- TODO: instance of tItems?
+instance Labeled x => TSelection x (RadioView x ()) where
+ tSelection
+ = newAttr "tSelection" viewGetTSelection viewSetTSelection
+
+mkRadioView :: Labeled x => Window a -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ())
+mkRadioView window orientation viewItems props = [_$_]
+ mkRadioViewEx window toLabel orientation viewItems props
+
+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)
+
+-- ListView
+
+data CListView a b
+
+type ListView a b = SingleListBox (CListView a b)
+
+instance TSelection x (ListView x ()) where
+ tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
+
+instance TItems x (ListView x ()) where
+ tItems = newAttr "tItems" viewGetTItems viewSetTItems
+
+mkListView :: Labeled x => Window a -> [Prop (ListView x ())] -> IO (ListView x ())
+mkListView window props = mkListViewEx window toLabel props
+ [_$_]
+mkListViewEx :: Window a -> (x -> String) -> [Prop (ListView x ())] -> IO (ListView x ())
+mkListViewEx window present props = mkViewEx singleListBox window present props
+
+
+-- MultiListView
+
+data CMultiListView a b
+
+type MultiListView a b = MultiListBox (CMultiListView a b)
+
+instance Labeled x => TSelections x (MultiListView x ()) where
+ tSelections = newAttr "tSelections" multiListViewGetTSelections multiListViewSetTSelections
+
+instance Labeled x => TItems x (MultiListView x ()) where
+ tItems = newAttr "tItems" viewGetTItems viewSetTItems
+
+mkMultiListView :: Labeled x => Window a -> [Prop (MultiListView x ())] -> IO (MultiListView x ())
+mkMultiListView window props = mkMultiListViewEx window toLabel props
+
+mkMultiListViewEx :: Window a -> (x -> String) -> [Prop (MultiListView x ())] -> IO (MultiListView x ())
+mkMultiListViewEx window present props = mkViewEx multiListBox window present props
+
+multiListViewSetTSelections :: MultiListView x () -> [x] -> IO ()
+multiListViewSetTSelections (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 ]
+ }
+
+multiListViewGetTSelections :: MultiListView x () -> IO [x]
+multiListViewGetTSelections multiListView =
+ do { Just ((model, _) :: (Var [x], x -> String)) <-
+ unsafeObjectGetClientData multiListView
+ ; selectedIndices <- get multiListView selections
+ ; viewItems <- get model value
+ ; return (map (safeIndex "XTC.multiListViewGetTSelections" viewItems)
+ selectedIndices)
+ }
+
+
+-- ChoiceView
+
+data CChoiceView a b
+
+type ChoiceView a b = Choice (CChoiceView a b)
+
+instance Selecting (ChoiceView x ()) where
+ select = newEvent "select" choiceGetOnCommand choiceOnCommand
+-- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of
+-- "Selecting (Choice a)". TODO: let/make Daan fix this
+
+instance Selection (ChoiceView x ()) where
+ selection = newAttr "selection" choiceGetSelection choiceSetSelection
+-- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of
+-- "Selection (Choice a)".
+
+instance TSelection x (ChoiceView x ()) where
+ tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
+
+instance TItems x (ChoiceView x ()) where
+ tItems = newAttr "tItems" viewGetTItems viewSetTItems
+
+mkChoiceView :: Labeled x => Window a -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ())
+mkChoiceView window (props :: [Prop (ChoiceView x ())]) =
+ mkViewEx choice window (toLabel :: x -> String) props
+
+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
+
+
+-- ComboView
+
+data CComboView a b
+
+type ComboView a b = ComboBox (CComboView a b)
+
+
+instance TSelection x (ComboView x ()) where
+ tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection
+
+instance TItems x (ComboView x ()) where
+ tItems = newAttr "tItems" viewGetTItems viewSetTItems
+
+mkComboView :: Labeled x => Window a -> [Prop (ComboView x ())] -> IO (ComboView x ())
+mkComboView window (props :: [Prop (ComboView x ())]) =
+ mkViewEx comboBox window (toLabel :: x -> String) props
+
+mkComboViewEx :: Window a -> (x -> String) -> Style -> [Prop (ComboView x ())] -> IO (ComboView x ())
+mkComboViewEx window present stl props = [_$_]
+ mkViewEx (\win -> comboBoxEx win stl) window present props
+
+
+
+-- generic mk function that puts a model and a present function in the client data
+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 set/getTSelection for RadioView, ListView, and ChoiceView
+
+viewGetTSelection :: TSelection x (WxObject a) => WxObject a -> IO x
+viewGetTSelection view =
+ do { Just ((model, _) :: (Var [x], x -> String)) <-
+ unsafeObjectGetClientData view
+ ; selectedIndex <- get view selection
+ ; viewItems <- get model value
+ ; return (safeIndex "XTC.viewGetTSelection" viewItems selectedIndex)
+ }
+
+-- if non unique, set to first viewItem with same label
+-- selection is set to 0 if object is not found, maybe -1 is better?
+viewSetTSelection :: TSelection x (WxObject a) => WxObject a -> x -> IO ()
+viewSetTSelection view selectionItem =
+ do { Just ((model, present) :: (Var [x], x -> String)) <-
+ unsafeObjectGetClientData view
+ ; viewItems <- get model value
+ ; let label = present selectionItem
+ ; let index = 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 -> 0
+
+viewGetTItems :: TItems x (WxObject a) => WxObject a -> IO [x]
+viewGetTItems view =
+ do { Just ((model, _) :: (Var [x], x -> String)) <-
+ unsafeObjectGetClientData view
+ ; viewItems <- get model value
+ ; return viewItems
+ }
+
+viewSetTItems :: TItems x (WxObject a) => WxObject a -> [x] -> IO ()
+viewSetTItems view viewItems =
+ do { Just ((model, present) :: (Var [x], x -> String)) <-
+ unsafeObjectGetClientData view
+ ; set model [ value := viewItems ]
+ ; set view [ items := map present viewItems ]
+ }
+
+
+
+
+
+
+-- ValueEntry
+
+class Parseable x where
+ parse :: String -> Maybe x
+
+instance Parseable String where
+ parse = Just
+
+{- When a type is instance of Read, a simple Parseable instance can be declared with readParse
+ e.g. for Int: instance Parseable Int where parse = readParse
+
+TODO: can we make this some kind of default?
+-}
+readParse :: Read x => String -> Maybe x [_$_]
+readParse str = case reads str of
+ [(x, "")] -> Just x
+ _ -> Nothing
+
+class TValued x w | w -> x where
+ tValue :: Attr w (Maybe x)
+
+data CValueEntry x b
+
+type ValueEntry x b = TextCtrl (CValueEntry x b)
+
+instance TValued x (ValueEntry x ()) where
+ tValue
+ = newAttr "tValue" valueEntryGetTValue valueEntrySetTValue
+
+mkValueEntry :: (Show x, Read x) => Window b -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ())
+mkValueEntry window props = mkValueEntryEx window show readParse props
+ [_$_]
+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 tValue
+ ; set valueEntry [ bgcolor := case mVal of -- TODO: add property for error color?
+ Nothing -> lightgrey
+ _ -> white
+ ]
+ ; repaint valueEntry
+ } -- drawing a squiggly doesn't work because font metrics are not available
+
+valueEntryGetTValue :: ValueEntry x () -> IO (Maybe x)
+valueEntryGetTValue valueEntry =
+ do { Just ((_, parse) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry
+ ; valueStr <- get valueEntry text
+ ; return $ parse valueStr
+ }
+
+valueEntrySetTValue :: ValueEntry x () -> Maybe x -> IO ()
+valueEntrySetTValue valueEntry mValue =
+ do { Just ((present, _) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry
+ ; case mValue of
+ Nothing -> return ()
+ Just theValue -> set valueEntry [ text := present theValue ]
+ }
+
+
+class Observable w where
+ change :: Event w (IO ())
+ [_$_]
+instance Observable (TextCtrl a) where
+ change = newEvent "change" (controlGetOnText) (controlOnText)
+
+
+
+-- ObservableVar
+
+-- add variable as WxObject
+{-
+type Observer x = (WxObject (), x -> IO ())
+
+data ObservableVar x = ObservableVar (Var [Observer x]) (Var x)
+
+instance Valued ObservableVar where
+ value
+ = newAttr "value" observableVarGetValue observableVarSetValue
+
+mkObservableVar :: x -> IO (ObservableVar x)
+mkObservableVar x =
+ do { observersV <- variable [ value := [] ]
+ ; var <- variable [ value := x ]
+ ; return $ ObservableVar observersV var
+ }
+ [_$_]
+observableVarGetValue :: ObservableVar x -> IO x
+observableVarGetValue (ObservableVar _ var) = get var value
+
+observableVarSetValue :: ObservableVar x -> x -> IO ()
+observableVarSetValue (ObservableVar observersV var) x =
+ do { myObservers <- get observersV value
+ ; set var [ value := x ]
+ ; sequence_ [ obs x | (_, obs) <- myObservers ]
+ }
+
+class Observable x w | w -> x where
+ observers :: Attr w [Observer x]
+
+instance Observable x (ObservableVar x) where
+ observers
+ = newAttr "observers" observableVarGetObservers observableVarSetObservers
+
+observableVarGetObservers :: ObservableVar x -> IO [Observer x]
+observableVarGetObservers (ObservableVar observersV _) = get observersV value [_$_]
+
+observableVarSetObservers :: ObservableVar x -> [Observer x] -> IO ()
+observableVarSetObservers (ObservableVar observersV var) myObservers = -- return ()
+ do { set observersV [ value := myObservers ]
+ ; x <- get var value
+ ; sequence_ [ obs x | (_, obs) <- myObservers ]
+ }
+
+
+-- all WxObjects get the event 'change'
+
+class Observing w where
+ change :: ObservableVar x -> Event w (x -> IO ())
+ [_$_]
+instance Observing (WxObject a) where
+ change observableVar
+ = newEvent "change" (getOnObserve observableVar) (setOnObserve observableVar)
+
+setOnObserve :: ObservableVar x -> Object a -> (x -> IO ()) -> IO ()
+setOnObserve (ObservableVar observersV var) obj observer = [_$_]
+ do { oldObservers <- get observersV value
+ ; let otherObservers = filter ((/= objectCast obj) . fst) oldObservers
+ ; set observersV [ value := (objectCast obj, observer) : otherObservers ]
+ ; x <- get var value
+ ; observer x
+ }
+
+getOnObserve :: ObservableVar x -> Object a -> IO (x -> IO ())
+getOnObserve (ObservableVar observersV _) obj =
+ do { myObservers <- get observersV value
+ ; case lookup (objectCast obj) myObservers of
+ Just obs -> return obs
+ Nothing -> do { internalError "XTC" "getOnObserve" "object is not an observer" [_$_]
+ ; return $ \_ -> return ()
+ }
+ } [_$_]
+-}
+
+
+-- Utility functions
+
+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)
+
+
+-- Test function
+
+xtc :: IO ()
+xtc = start $
+ do { -- counterV <- mkObservableVar 1
+ ; f <- frame []
+ [_$_]
+ [_$_]
+ ; listV <- mkListView f [ tItems := ["sdfsdf", "fdssd"]
+ , enabled := True
+ ]
+ [_$_]
+ ; choiceV <- mkChoiceView f [ tItems := ["sdfsdf", "fdssd"]
+ , enabled := True
+ ]
+ ; comboV <- mkComboView f [ tItems := ["sdfsdf", "fdssd"]
+ , enabled := True
+ ]
+ ; t <- textEntry f []
+ ; ve <- mkValueEntry f [ tValue := Just True ]
+ -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ] [_$_]
+ [_$_]
+ ; bUp <- button f [ text := "increase", on command := do { s1 <- get comboV tSelection
+ ; s2 <- get listV text
+ ; print (s1,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 ]
+ -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ] [_$_]
+ -- , hfloatCenter $ widget bChangeHandler
+ , widget listV
+ , widget choiceV
+ , widget comboV
+ , widget ve
+ ]
+ ]
+ [_$_]
+ }
addfile ./startghci.bat
hunk ./startghci.bat 1
+ghci -ffi -package wx -package HaXml -package lang -Wall -fglasgow-exts -ilib\DData:src src\Main.hs
+@rem voor GHC 6.4: -ignore-package network-1.0
+
}