"Committed_by_peb"

5 files changed, 305 insertions, 57 deletions

diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs
index 555f5fec1..ba03884fd 100644
--- a/src/GF/Data/BacktrackM.hs
+++ b/src/GF/Data/BacktrackM.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/29 11:17:54 $
+-- > CVS $Date: 2005/04/11 13:52:49 $
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Backtracking state monad, with r\/o environment
 -----------------------------------------------------------------------------
@@ -19,7 +19,6 @@ module GF.Data.BacktrackM ( -- * the backtracking state monad
 		    failure,
 		    (|||),
 		    -- * handling the state & environment
-		    readEnv,
 		    readState,
 		    writeState,
 		    -- * monad specific utilities
@@ -37,53 +36,51 @@ import Monad
 
 -- * controlling the monad
 
-failure :: BacktrackM e s a
-(|||)   :: BacktrackM e s a -> BacktrackM e s a -> BacktrackM e s a
+failure :: BacktrackM s a
+(|||)   :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
 
-instance MonadPlus (BacktrackM e s) where
+instance MonadPlus (BacktrackM s) where
     mzero = failure
     mplus = (|||)
 
 -- * handling the state & environment
 
-readEnv    :: BacktrackM e s e
-readState  :: BacktrackM e s s
-writeState :: s -> BacktrackM e s ()
+readState  :: BacktrackM s s
+writeState :: s -> BacktrackM s ()
 
--- * monad specific utilities
+-- * specific functions on the backtracking monad
 
-member :: [a] -> BacktrackM e s a
+member :: [a] -> BacktrackM s a
 member = msum . map return 
 
 -- * running the monad
 
-runBM       :: BacktrackM e s a  -> e -> s -> [(s, a)]
+runBM       :: BacktrackM s a  -> s -> [(s, a)]
 
-solutions   :: BacktrackM e s a  -> e -> s -> [a]
-solutions   bm e s = map snd $ runBM bm e s 
+solutions   :: BacktrackM s a  -> s -> [a]
+solutions   bm = map snd . runBM bm 
 
-finalStates :: BacktrackM e s () -> e -> s -> [s]
-finalStates bm e s = map fst $ runBM bm e s
+finalStates :: BacktrackM s () -> s -> [s]
+finalStates bm = map fst . runBM bm
 
 
 {-
 ----------------------------------------------------------------------
 -- implementation as lists of successes
 
-newtype BacktrackM e s a = BM (e -> s -> [(s, a)])
+newtype BacktrackM s a = BM (s -> [(s, a)])
 
 runBM       (BM m) = m
 
-readEnv      = BM (\e s -> [(s, e)])
-readState    = BM (\e s -> [(s, s)])
-writeState s = BM (\e _ -> [(s, ())])
+readState    = BM (\s -> [(s, s)])
+writeState s = BM (\_ -> [(s, ())])
 
-failure       = BM (\e s -> [])
-BM m ||| BM n = BM (\e s -> m e s ++ n e s)
+failure       = BM (\s -> [])
+BM m ||| BM n = BM (\s -> m s ++ n 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 ])
+instance Monad (BacktrackM s) where
+    return a   = BM (\s -> [(s, a)])
+    BM m >>= k = BM (\s -> concat [ n s' | (s', a) <- m s, let BM n = k a ])
     fail _     = failure
 -}
 
@@ -105,19 +102,17 @@ runB (B m) = m (:) []
 
 -- BacktrackM = state monad transformer over the backtracking monad
 
-newtype BacktrackM e s a = BM (e -> s -> Backtr (s, a))
+newtype BacktrackM s a = BM (s -> Backtr (s, a))
 
-runBM (BM m) e s = runB (m e s)
+runBM (BM m) s = runB (m s)
 
-readEnv      = BM (\e s -> return (s, e))
-readState    = BM (\e s -> return (s, s))
-writeState s = BM (\e _ -> return (s, ()))
+readState    = BM (\s -> return (s, s))
+writeState s = BM (\_ -> return (s, ()))
 
-failure = BM (\e s -> failureB)
-BM m ||| BM n = BM (\e s -> m e s |||| n e s)
+failure = BM (\s -> failureB)
+BM m ||| BM n = BM (\s -> m s |||| n 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')
+instance Monad (BacktrackM s) where
+    return a   = BM (\s -> return (s, a))
+    BM m >>= k = BM (\s -> do (s', a) <- m s ; unBM (k a) s')
 	where unBM (BM m) = m
diff --git a/src/GF/Data/GeneralDeduction.hs b/src/GF/Data/GeneralDeduction.hs
new file mode 100644
index 000000000..75511ee7a
--- /dev/null
+++ b/src/GF/Data/GeneralDeduction.hs
@@ -0,0 +1,117 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:51 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Simple implementation of deductive chart parsing
+-----------------------------------------------------------------------------
+
+module GF.NewParsing.GeneralChart 
+    (-- * Type definition
+     ParseChart,
+     -- * Main functions
+     chartLookup,
+     buildChart, buildChartM,
+     -- * Probably not needed
+     emptyChart,
+     chartMember,
+     chartInsert, chartInsertM,
+     chartList,
+     addToChart, addToChartM
+    ) where
+
+-- import Trace 
+
+import GF.Data.RedBlackSet
+import Monad (foldM)
+
+----------------------------------------------------------------------
+-- main functions
+
+chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item]
+chartList   :: (Ord item, Ord key) => ParseChart item key -> [item]
+buildChart  :: (Ord item, Ord key) => 
+	       (item -> key)                           -- ^ key lookup function
+	    -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions 
+						       -- from triggering items to lists of items
+	    -> [item]                                  -- ^ initial chart
+	    -> ParseChart item key                     -- ^ final chart
+buildChartM :: (Ord item, Ord key) => 
+	       (item -> [key])                         -- ^ many-valued key lookup function
+	    -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions 
+						       -- from triggering items to lists of items
+	    -> [item]                                  -- ^ initial chart
+	    -> ParseChart item key                     -- ^ final chart
+
+buildChart keyof rules axioms     = addItems axioms emptyChart
+    where addItems []             = id
+	  addItems (item:items)   = addItems items . addItem item
+          -- addItem item | trace ("+ "++show item++"\n") False = undefined
+          addItem item            = addToChart item (keyof item) 
+				    (\chart -> foldr (consequence item) chart rules)
+          consequence item rule chart = addItems (rule chart item) chart
+
+buildChartM keysof rules axioms   = addItems axioms emptyChart
+    where addItems []             = id
+	  addItems (item:items)   = addItems items . addItem item
+          -- addItem item | trace ("+ "++show item++"\n") False = undefined
+          addItem item            = addToChartM item (keysof item) 
+				    (\chart -> foldr (consequence item) chart rules)
+          consequence item rule chart = addItems (rule chart item) chart
+
+-- probably not needed
+
+emptyChart   :: (Ord item, Ord key) => ParseChart item key
+chartMember  :: (Ord item, Ord key) => ParseChart item key
+	     -> item -> key -> Bool
+chartInsert  :: (Ord item, Ord key) => ParseChart item key
+	     -> item -> key -> Maybe (ParseChart item key)
+chartInsertM :: (Ord item, Ord key) => ParseChart item key
+	     -> item -> [key] -> Maybe (ParseChart item key)
+
+addToChart  :: (Ord item, Ord key) => item -> key 
+	    -> (ParseChart item key -> ParseChart item key) 
+	    ->  ParseChart item key -> ParseChart item key
+addToChart item keys after chart = maybe chart after (chartInsert chart item keys)
+
+addToChartM :: (Ord item, Ord key) => item -> [key] 
+	    -> (ParseChart item key -> ParseChart item key) 
+	    ->  ParseChart item key -> ParseChart item key
+addToChartM item keys after chart = maybe chart after (chartInsertM chart item keys)
+
+
+--------------------------------------------------------------------------------
+-- key charts as red/black trees
+
+newtype ParseChart    item key = KC (RedBlackMap key item)
+    deriving Show
+
+emptyChart                     = KC rbmEmpty
+chartMember (KC tree) item key = rbmElem key item tree
+chartLookup (KC tree)      key = rbmLookup key tree
+chartList   (KC tree)          = concatMap snd (rbmList tree)
+chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree)
+
+chartInsertM (KC tree) item keys = fmap KC (foldM insertItem tree keys)
+    where insertItem tree key    = rbmInsert key item tree
+
+--------------------------------------------------------------------------------}
+
+
+{--------------------------------------------------------------------------------
+-- key charts as unsorted association lists -- OBSOLETE!
+
+newtype Chart          item key = SC [(key, item)]
+
+emptyChart = SC []
+chartMember (SC chart) item key = (key,item) `elem` chart
+chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart))
+chartLookup (SC chart)      key = [ item | (key',item) <- chart, key == key' ]
+chartList   (SC chart)          = map snd chart
+--------------------------------------------------------------------------------}
+
diff --git a/src/GF/Data/IncrementalDeduction.hs b/src/GF/Data/IncrementalDeduction.hs
new file mode 100644
index 000000000..072a1334f
--- /dev/null
+++ b/src/GF/Data/IncrementalDeduction.hs
@@ -0,0 +1,64 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:51 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Implementation of /incremental/ deductive parsing,
+-- i.e. parsing one word at the time.
+-----------------------------------------------------------------------------
+
+module GF.NewParsing.IncrementalChart
+    (-- * Type definitions
+     IncrementalChart,
+     -- * Functions
+     chartLookup,
+     buildChart,
+     chartList
+    ) where
+
+import Array
+import GF.Data.SortedList
+import GF.Data.Assoc
+
+----------------------------------------------------------------------
+-- main functions 
+
+chartLookup :: (Ord item, Ord key) =>
+	       IncrementalChart item key
+	    -> Int -> key -> SList item
+
+buildChart :: (Ord item, Ord key) => 
+	      (item -> key)               -- ^ key lookup function
+	   -> (Int -> item -> SList item) -- ^ all inference rules for position k, collected
+	   -> (Int ->         SList item) -- ^ all axioms for position k, collected
+	   -> (Int, Int)                  -- ^ input bounds
+	   -> IncrementalChart item key
+
+chartList :: (Ord item, Ord key) => 
+	     IncrementalChart item key    -- ^ the final chart
+	  -> (Int -> item -> edge)        -- ^ function building an edge from 
+					  -- the position and the item
+	  -> [edge]
+
+type IncrementalChart item key = Array Int (Assoc key (SList item))
+
+----------
+
+chartLookup chart k key = (chart ! k) ? key
+
+buildChart keyof rules axioms bounds = finalChartArray
+    where buildState k     = limit (rules k) $ axioms k
+	  finalChartList   = map buildState [fst bounds .. snd bounds]
+	  finalChartArray  = listArray bounds $ map stateAssoc finalChartList
+	  stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ]
+
+chartList chart combine = [ combine k item | 
+			    (k, state) <- assocs chart, 
+			    item <- concatMap snd $ aAssocs state ]
+
+
diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs
index 0b340b533..8f96bdc59 100644
--- a/src/GF/Data/SortedList.hs
+++ b/src/GF/Data/SortedList.hs
@@ -1,13 +1,12 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : SortedList
 -- Maintainer  : Peter Ljunglöf
 -- Stability   : stable
 -- Portability : portable
 --
--- > CVS $Date: 2005/03/21 14:17:39 $ 
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Sets as sorted lists
 --
@@ -18,29 +17,37 @@
 --    * /O(n^2)/ fixed point iteration
 -----------------------------------------------------------------------------
 
-module GF.Data.SortedList ( SList, 
-		    nubsort, union, 
-		    (<++>), (<\\>), (<**>), 
-		    limit,
-		    hasCommonElements, subset, 
-		    groupPairs, groupUnion
-		  ) where
+module GF.Data.SortedList 
+    ( -- * type declarations
+      SList, SMap,
+      -- * set operations		    
+      nubsort, union, 
+      (<++>), (<\\>), (<**>), 
+      limit,
+      hasCommonElements, subset, 
+      -- * map operations
+      groupPairs, groupUnion,
+      unionMap, mergeMap
+    ) where
 
 import List (groupBy)
+import GF.Data.Utilities (split, foldMerge)
 
 -- | 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)
+-- | A sorted map also has unique keys, 
+-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
+type SMap a b = SList (a, b)
+
+-- | Group a set of key-value pairs into a sorted map
+groupPairs :: Ord a => SList (a, b) -> SMap 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)
+-- | Group a set of key-(sets-of-values) pairs into a sorted map
+groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
 groupUnion = map unionSnd . groupPairs
     where unionSnd (a, bs) = (a, union bs)
 
@@ -57,13 +64,25 @@ xs `subset` ys = null (xs <\\> ys)
 nubsort :: Ord a => [a] -> SList a
 nubsort = union . map return
 
+-- | the union of a list of sorted maps
+unionMap :: Ord a => (b -> b -> b) 
+	 -> [SMap a b] -> SMap a b
+unionMap plus = foldMerge (mergeMap plus) []
+
+-- | merging two sorted maps
+mergeMap :: Ord a => (b -> b -> b) 
+	 -> SMap a b -> SMap a b -> SMap a b 
+mergeMap plus [] abs = abs
+mergeMap plus abs [] = abs
+mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
+    = case compare a c of
+        EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
+	LT -> ab : mergeMap plus abs' cds
+	GT -> cd : mergeMap plus abs  cds'
+
 -- | 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, [])
+union = foldMerge (<++>) []
 
 -- | The union of two sets
 (<++>) :: Ord a => SList a -> SList a -> SList a 
diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
new file mode 100644
index 000000000..6f93add28
--- /dev/null
+++ b/src/GF/Data/Utilities.hs
@@ -0,0 +1,53 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:49 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Basic functions not in the standard libraries
+-----------------------------------------------------------------------------
+
+
+module GF.Data.Utilities where
+
+-- * functions on lists
+
+sameLength :: [a] -> [a] -> Bool
+sameLength [] [] = True
+sameLength (_:xs) (_:ys) = sameLength xs ys
+sameLength _ _ = False
+
+lookupList :: Eq a => a -> [(a, b)] -> [b]
+lookupList a [] = []
+lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
+		    | otherwise  =         lookupList a ps
+
+split :: [a] -> ([a], [a])
+split (x : y : as) = (x:xs, y:ys)
+    where (xs, ys) = split as
+split as = (as, [])
+
+splitBy :: (a -> Bool) -> [a] -> ([a], [a])
+splitBy p [] = ([], [])
+splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
+    where (xs, ys) = splitBy p as
+
+foldMerge :: (a -> a -> a) -> a -> [a] -> a
+foldMerge merge zero = fm
+    where fm [] = zero
+	  fm [a] = a
+	  fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+
+-- * functions on pairs
+
+mapFst :: (a -> a') -> (a, b) -> (a', b)
+mapFst f (a, b) = (f a, b)
+
+mapSnd :: (b -> b') -> (a, b) -> (a, b')
+mapSnd f (a, b) = (a, f b)
+
+