"Committed_by_peb"

4 files changed, 512 insertions, 0 deletions

diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs
new file mode 100644
index 000000000..261fdb980
--- /dev/null
+++ b/src/GF/Data/Assoc.hs
@@ -0,0 +1,131 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Assoc
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : Stable
+-- Portability : Haskell 98
+--
+-- > CVS $Date: 2005/03/21 14:17:39 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Association lists, or finite maps,
+-- including sets as maps with result type @()@.
+-- function names stolen from module @Array@.
+-- /O(log n)/ key lookup
+-----------------------------------------------------------------------------
+
+module GF.Data.Assoc ( Assoc,
+	       Set,
+	       listAssoc,
+	       listSet,
+	       accumAssoc,
+	       aAssocs,
+	       aElems,
+	       assocMap,
+	       lookupAssoc,
+	       lookupWith,
+	       (?),
+	       (?=)
+	     ) where
+
+import GF.Data.SortedList 
+
+infixl 9 ?, ?=
+
+-- | a set is a finite map with empty values
+type Set a = Assoc a ()
+
+-- | creating a finite map from a sorted key-value list 
+listAssoc   :: Ord a => SList (a, b) -> Assoc a b
+
+-- | creating a set from a sorted list
+listSet     :: Ord a => SList a -> Set a
+
+-- | building a finite map from a list of keys and 'b's, 
+-- and a function that combines a sorted list of 'b's into a value
+accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b
+
+-- | all key-value pairs from an association list
+aAssocs :: Ord a => Assoc a b -> SList (a, b)
+
+-- | all keys from an association list
+aElems  :: Ord a => Assoc a b -> SList a
+
+-- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b'
+
+-- | mapping values to other values.
+-- the mapping function can take the key as information
+assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
+
+-- | monadic lookup function,
+-- returning failure if the key does not exist
+lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
+
+-- | if the key does not exist, 
+-- the first argument is returned
+lookupWith :: Ord a => b -> Assoc a b -> a -> b
+
+-- | if the values are monadic, we can return the value type
+(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b
+
+-- | checking wheter the map contains a given key 
+(?=) :: Ord a => Assoc a b -> a -> Bool
+
+
+------------------------------------------------------------
+
+data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b)
+		 deriving (Eq, Show)
+
+listAssoc as = assoc
+  where (assoc, [])     = sl2bst (length as) as
+	sl2bst 0 xs     = (ANil, xs)
+	sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs)
+	sl2bst n xs     = (ANode left (fst x) (snd x) right, zs)
+          where llen    = (n-1) `div` 2
+                rlen    = n - 1 - llen
+                (left, x:ys) = sl2bst llen xs
+                (right, zs)  = sl2bst rlen ys
+
+listSet as = listAssoc (zip as (repeat ()))
+
+accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort
+    where mapSnd f (a, b) = (a, f b)
+
+aAssocs as = prs as []
+    where prs ANil = id
+	  prs (ANode left a b right) = prs left . ((a,b) :) . prs right
+
+aElems = map fst . aAssocs
+
+
+instance Ord a => Functor (Assoc a) where
+    fmap f = assocMap (const f)
+
+assocMap f ANil = ANil
+assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right)
+
+
+lookupAssoc ANil _ = fail "key not found"
+lookupAssoc (ANode left a b right) a' = case compare a a' of
+					  GT -> lookupAssoc left  a'
+					  LT -> lookupAssoc right a'
+					  EQ -> return b
+
+lookupWith z ANil _ = z
+lookupWith z (ANode left a b right) a' = case compare a a' of
+					   GT -> lookupWith z left  a'
+					   LT -> lookupWith z right a'
+					   EQ -> b
+
+(?) = lookupWith (fail "key not found")
+
+(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc 
+
+
+
+
+
+
+
diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs
new file mode 100644
index 000000000..5abc9863d
--- /dev/null
+++ b/src/GF/Data/BacktrackM.hs
@@ -0,0 +1,123 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : BacktrackM
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/03/21 14:17:39 $
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Backtracking state monad, with r/o environment
+-----------------------------------------------------------------------------
+
+
+module GF.Data.BacktrackM ( -- * the backtracking state monad
+		    BacktrackM,
+		    -- * controlling the monad
+		    failure,
+		    (|||),
+		    -- * handling the state & environment
+		    readEnv,
+		    readState,
+		    writeState,
+		    -- * monad specific utilities
+		    member,
+		    -- * running the monad
+		    runBM,
+		    solutions,
+		    finalStates
+		  ) where
+
+import Monad
+
+------------------------------------------------------------
+-- type declarations
+
+-- * controlling the monad
+
+failure :: BacktrackM e s a
+(|||)   :: BacktrackM e s a -> BacktrackM e s a -> BacktrackM e s a
+
+instance MonadPlus (BacktrackM e s) where
+    mzero = failure
+    mplus = (|||)
+
+-- * handling the state & environment
+
+readEnv    :: BacktrackM e s e
+readState  :: BacktrackM e s s
+writeState :: s -> BacktrackM e s ()
+
+-- * monad specific utilities
+
+member :: [a] -> BacktrackM e s a
+member = msum . map return 
+
+-- * running the monad
+
+runBM       :: BacktrackM e s a  -> e -> s -> [(s, a)]
+
+solutions   :: BacktrackM e s a  -> e -> s -> [a]
+solutions   bm e s = map snd $ runBM bm e s 
+
+finalStates :: BacktrackM e s () -> e -> s -> [s]
+finalStates bm e s = map fst $ runBM bm e s
+
+
+{-
+----------------------------------------------------------------------
+-- implementation as lists of successes
+
+newtype BacktrackM e s a = BM (e -> s -> [(s, a)])
+
+runBM       (BM m) = m
+
+readEnv      = BM (\e s -> [(s, e)])
+readState    = BM (\e s -> [(s, s)])
+writeState s = BM (\e _ -> [(s, ())])
+
+failure       = BM (\e s -> [])
+BM m ||| BM n = BM (\e s -> m e s ++ n e s)
+
+instance Monad (BacktrackM e s) where
+    return a   = BM (\e s -> [(s, a)])
+    BM m >>= k = BM (\e s -> concat [ n e s' | (s', a) <- m e s, let BM n = k a ])
+    fail _     = failure
+-}
+
+----------------------------------------------------------------------
+-- Combining endomorphisms and continuations
+-- a la Ralf Hinze
+
+newtype Backtr a = B (forall b . (a -> b -> b) -> b -> b)
+
+instance Monad Backtr where
+    return a  = B (\c f -> c a f)
+    B m >>= k = B (\c f -> m (\a -> unBacktr (k a) c) f)
+        where unBacktr (B m) = m
+
+failureB     = B (\c f -> f)
+B m |||| B n = B (\c f -> m c (n c f))
+
+runB (B m) = m (:) []
+
+-- BacktrackM = state monad transformer over the backtracking monad
+
+newtype BacktrackM e s a = BM (e -> s -> Backtr (s, a))
+
+runBM (BM m) e s = runB (m e s)
+
+readEnv      = BM (\e s -> return (s, e))
+readState    = BM (\e s -> return (s, s))
+writeState s = BM (\e _ -> return (s, ()))
+
+failure = BM (\e s -> failureB)
+BM m ||| BM n = BM (\e s -> m e s |||| n e s)
+
+instance Monad (BacktrackM e s) where
+    return a   = BM (\e s -> return (s, a))
+    BM m >>= k = BM (\e s -> do (s', a) <- m e s 
+		                unBM (k a) e s')
+	where unBM (BM m) = m
diff --git a/src/GF/Data/RedBlackSet.hs b/src/GF/Data/RedBlackSet.hs
new file mode 100644
index 000000000..8a1b8a743
--- /dev/null
+++ b/src/GF/Data/RedBlackSet.hs
@@ -0,0 +1,150 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : RedBlackSet
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : Stable
+-- Portability : Haskell 98
+--
+-- > CVS $Date: 2005/03/21 14:17:39 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Modified version of Okasaki's red-black trees
+-- incorporating sets and set-valued maps
+----------------------------------------------------------------------
+
+module GF.Data.RedBlackSet ( -- * Red-black sets
+		     RedBlackSet,
+		     rbEmpty,
+		     rbList,
+		     rbElem,
+		     rbLookup,
+		     rbInsert,
+		     rbMap,
+		     rbOrdMap,
+		     -- * Red-black finite maps
+		     RedBlackMap,
+		     rbmEmpty,
+		     rbmList,
+		     rbmElem,
+		     rbmLookup,
+		     rbmInsert,
+		     rbmOrdMap
+		   ) where
+
+--------------------------------------------------------------------------------
+-- sets
+
+data Color = R | B   deriving (Eq, Show)
+data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a)
+		     deriving (Eq, Show)
+
+rbBalance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
+rbBalance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
+rbBalance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
+rbBalance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
+rbBalance color a x b = T color a x b
+
+rbBlack (T _ a x b) = T B a x b
+
+-- | the empty set
+rbEmpty :: RedBlackSet a
+rbEmpty = E
+
+-- | the elements of a set as a sorted list
+rbList :: RedBlackSet a -> [a]
+rbList tree = rbl tree []
+  where rbl E = id
+	rbl (T _ left a right) = rbl right . (a:) . rbl left
+
+-- | checking for containment
+rbElem :: Ord a => a -> RedBlackSet a -> Bool
+rbElem _ E = False
+rbElem a (T _ left a' right)
+    = case compare a a' of
+        LT -> rbElem a left
+	GT -> rbElem a right
+	EQ -> True
+
+-- | looking up a key in a set of keys and values
+rbLookup :: Ord k => k -> RedBlackSet (k, a) -> Maybe a
+rbLookup _ E = Nothing
+rbLookup a (T _ left (a',b) right)
+    = case compare a a' of
+        LT -> rbLookup a left
+	GT -> rbLookup a right
+	EQ -> Just b
+
+-- | inserting a new element.
+-- returns 'Nothing' if the element is already contained
+rbInsert :: Ord a => a -> RedBlackSet a -> Maybe (RedBlackSet a)
+rbInsert value tree = fmap rbBlack (rbins tree)
+  where rbins E = Just (T R E value E)
+	rbins (T color left value' right)
+	    = case compare value value' of
+                LT -> do left' <- rbins left
+			 return (rbBalance color left' value' right)
+		GT -> do right' <- rbins right
+			 return (rbBalance color left value' right')
+		EQ -> Nothing
+
+-- | mapping each value of a key-value set 
+rbMap :: (a -> b) -> RedBlackSet (k, a) -> RedBlackSet (k, b)
+rbMap f E = E
+rbMap f (T color left (key, value) right) 
+    = T color (rbMap f left) (key, f value) (rbMap f right)
+
+-- | mapping each element to another type.
+-- /observe/ that the mapping function needs to preserve 
+-- the order between objects
+rbOrdMap :: (a -> b) -> RedBlackSet a -> RedBlackSet b
+rbOrdMap f E = E
+rbOrdMap f (T color left value right) 
+    = T color (rbOrdMap f left) (f value) (rbOrdMap f right)
+
+----------------------------------------------------------------------
+-- finite maps
+
+type RedBlackMap k a = RedBlackSet (k, RedBlackSet a)
+
+-- | the empty map
+rbmEmpty :: RedBlackMap k a
+rbmEmpty = E
+
+-- | converting a map to a key-value list, sorted on the keys,
+-- and for each key, a sorted list of values
+rbmList :: RedBlackMap k a -> [(k, [a])]
+rbmList tree = [ (k, rbList sub) | (k, sub) <- rbList tree ]
+
+-- | checking whether a key-value pair is contained in the map
+rbmElem :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Bool
+rbmElem key value = maybe False (rbElem value) . rbLookup key 
+
+-- | looking up a key, returning a (sorted) list of all matching values
+rbmLookup :: Ord k => k -> RedBlackMap k a -> [a]
+rbmLookup key = maybe [] rbList . rbLookup key 
+
+-- | inserting a key-value pair.
+-- returns 'Nothing' if the pair is already contained in the map
+rbmInsert :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Maybe (RedBlackMap k a)
+rbmInsert key value tree = fmap rbBlack (rbins tree)
+  where rbins E = Just (T R E (key, T B E value E) E)
+	rbins (T color left item@(key', vtree) right)
+	    = case compare key key' of
+                LT -> do left' <- rbins left
+			 return (rbBalance color left' item right)
+		GT -> do right' <- rbins right
+			 return (rbBalance color left item right')
+		EQ -> do vtree' <- rbInsert value vtree
+			 return (T color left (key', vtree') right)
+
+-- | mapping each value to another type.
+-- /observe/ that the mapping function needs to preserve
+-- order between objects
+rbmOrdMap :: (a -> b) -> RedBlackMap k a -> RedBlackMap k b
+rbmOrdMap f E = E
+rbmOrdMap f (T color left (key, tree) right) 
+    = T color (rbmOrdMap f left) (key, rbOrdMap f tree) (rbmOrdMap f right)
+
+
+
diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs
new file mode 100644
index 000000000..0b340b533
--- /dev/null
+++ b/src/GF/Data/SortedList.hs
@@ -0,0 +1,108 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : SortedList
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : stable
+-- Portability : portable
+--
+-- > CVS $Date: 2005/03/21 14:17:39 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Sets as sorted lists
+--
+--    * /O(n)/   union, difference and intersection 
+--
+--    * /O(n log n)/ creating a set from a list (=sorting)
+--
+--    * /O(n^2)/ fixed point iteration
+-----------------------------------------------------------------------------
+
+module GF.Data.SortedList ( SList, 
+		    nubsort, union, 
+		    (<++>), (<\\>), (<**>), 
+		    limit,
+		    hasCommonElements, subset, 
+		    groupPairs, groupUnion
+		  ) where
+
+import List (groupBy)
+
+-- | The list must be sorted and contain no duplicates.
+type SList a = [a]
+
+-- | Group a set of key-value pairs into
+-- a set of unique keys with sets of values
+groupPairs :: Ord a => SList (a, b) -> SList (a, SList b)
+groupPairs = map mapFst . groupBy eqFst
+    where mapFst as = (fst (head as), map snd as)
+	  eqFst a b = fst a == fst b
+
+-- | Group a set of key-(sets-of-values) pairs into
+-- a set of unique keys with sets of values
+groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SList (a, SList b)
+groupUnion = map unionSnd . groupPairs
+    where unionSnd (a, bs) = (a, union bs)
+
+-- | True is the two sets has common elements
+hasCommonElements :: Ord a => SList a -> SList a -> Bool
+hasCommonElements as bs = not (null (as <**> bs))
+
+-- | True if the first argument is a subset of the second argument
+subset :: Ord a => SList a -> SList a -> Bool
+xs `subset` ys = null (xs <\\> ys)
+
+-- | Create a set from any list.
+-- This function can also be used as an alternative to @nub@ in @List.hs@
+nubsort :: Ord a => [a] -> SList a
+nubsort = union . map return
+
+-- | The union of a list of sets
+union :: Ord a => [SList a] -> SList a
+union []   = []
+union [as] = as
+union abs  = let (as, bs) = split abs in union as <++> union bs
+	      where split (a:b:abs) = let (as, bs) = split abs in (a:as, b:bs)
+		    split as        = (as, [])
+
+-- | The union of two sets
+(<++>) :: Ord a => SList a -> SList a -> SList a 
+[] <++> bs = bs
+as <++> [] = as
+as@(a:as') <++> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <++> bs)
+			       GT -> b : (as  <++> bs')
+			       EQ -> a : (as' <++> bs')
+
+-- | The difference of two sets
+(<\\>) :: Ord a => SList a -> SList a -> SList a 
+[] <\\> bs = []
+as <\\> [] = as
+as@(a:as') <\\> bs@(b:bs') = case compare a b of
+			       LT -> a : (as' <\\> bs)
+			       GT ->     (as  <\\> bs')
+			       EQ ->     (as' <\\> bs')
+
+-- | The intersection of two sets
+(<**>) :: Ord a => SList a -> SList a -> SList a
+[] <**> bs = []
+as <**> [] = []
+as@(a:as') <**> bs@(b:bs') = case compare a b of
+			       LT ->     (as' <**> bs)
+			       GT ->     (as  <**> bs')
+			       EQ -> a : (as' <**> bs')
+
+-- | A fixed point iteration 
+limit :: Ord a => (a -> SList a)  -- ^ The iterator function
+      -> SList a                  -- ^ The initial set
+      -> SList a                  -- ^ The result of the iteration
+limit more start = limit' start start
+    where limit' chart agenda | null new' = chart
+			      | otherwise = limit' (chart <++> new') new'
+	      where new = union (map more agenda)
+		    new'= new <\\> chart
+
+
+
+
+