use MultiMap from the reference implementation instead of GeneralDeduction and RedBlackTree

GF.cabal

@@ -40,8 +40,7 @@ library
     PGF.Raw.Print
     PGF.Raw.Convert
     PGF.Raw.Abstract
-    GF.Data.RedBlackSet
+    GF.Data.MultiMap
-    GF.Data.GeneralDeduction
     GF.Data.Utilities
     GF.Data.SortedList
     GF.Data.Assoc
@@ -81,10 +80,9 @@ executable gf3
     GF.Command.LexGFShell
     GF.Command.AbsGFShell
     GF.Command.PrintGFShell
-    GF.Data.RedBlackSet
-    GF.Data.GeneralDeduction
     GF.Infra.CompactPrint
     GF.Text.UTF8
+    GF.Data.MultiMap
     GF.Data.Utilities
     GF.Data.SortedList
     GF.Data.Assoc

src-3.0/GF/Data/GeneralDeduction.hs

@@ -1,121 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer  : Peter Ljunglöf
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:01 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.3 $
---
--- Simple implementation of deductive chart parsing
------------------------------------------------------------------------------
-
-module GF.Data.GeneralDeduction
-    (-- * Type definition
-     ParseChart,
-     -- * Main functions
-     chartLookup,
-     buildChart, buildChartM,
-     -- * Probably not needed
-     emptyChart,
-     chartMember,
-     chartInsert, chartInsertM,
-     chartList, chartKeys, chartAssocs,
-     addToChart, addToChartM
-    ) where
-
--- import Trace 
-
-import GF.Data.RedBlackSet
-import Control.Monad (foldM)
-
-----------------------------------------------------------------------
--- main functions
-
-chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item]
-chartList   :: (Ord item, Ord key) => ParseChart item key -> [item]
-chartKeys   :: (Ord item, Ord key) => ParseChart item key -> [key]
-chartAssocs :: (Ord item, Ord key) => ParseChart item key -> [(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)
-chartKeys   (KC tree)          = map fst (rbmList tree)
-chartAssocs (KC tree)          = [(key,item) | (key,items) <- rbmList tree, item <- items]
-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
---------------------------------------------------------------------------------}
-

src-3.0/GF/Data/RedBlackSet.hs

@@ -1,150 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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)
-
-
-

src-3.0/PGF/Parsing/FCFG/Active.hs

@@ -9,10 +9,10 @@
 
 module PGF.Parsing.FCFG.Active (FCFParser, parse, makeFinalEdge) where
 
-import GF.Data.GeneralDeduction
 import GF.Data.Assoc
 import GF.Data.SortedList
 import GF.Data.Utilities
+import qualified GF.Data.MultiMap as MM
 
 import PGF.CId
 import PGF.Data
@@ -117,23 +117,23 @@ data Item
   | Final RangeRec (SyntaxNode RuleId RangeRec)
   deriving (Eq, Ord)
 
-data XChart c = XChart !(ParseChart Item c) !(ParseChart Item c)
+data XChart c = XChart !(MM.MultiMap c Item) !(MM.MultiMap c Item)
 
 emptyXChart :: Ord c => XChart c
-emptyXChart = XChart emptyChart emptyChart
+emptyXChart = XChart MM.empty MM.empty
 
 insertXChart (XChart actives finals) item@(Active _ _ _ _ _) c = 
-  case chartInsert actives item c of
+  case MM.insert' c item actives of
     Nothing      -> Nothing
     Just actives -> Just (XChart actives finals)
 
 insertXChart (XChart actives finals) item@(Final _ _) c =
-  case chartInsert finals item c of
+  case MM.insert' c item finals of
     Nothing     -> Nothing
     Just finals -> Just (XChart actives finals)
 
-lookupXChartAct   (XChart actives finals) c = chartLookup actives c
+lookupXChartAct   (XChart actives finals) c = actives MM.! c
-lookupXChartFinal (XChart actives finals) c = chartLookup finals  c
+lookupXChartFinal (XChart actives finals) c = finals  MM.! c
 
 xchart2syntaxchart :: XChart FCat -> ParserInfo -> SyntaxChart (CId,[Profile]) (FCat,RangeRec)
 xchart2syntaxchart (XChart actives finals) pinfo =
@@ -144,7 +144,7 @@ xchart2syntaxchart (XChart actives finals) pinfo =
         SString s          ->    ((cat,found), SString s)
         SInt    n          ->    ((cat,found), SInt    n)
         SFloat  f          ->    ((cat,found), SFloat  f)
-    | (cat, Final found node) <- chartAssocs finals
+    | (cat, Final found node) <- MM.toList finals
     ]
 
 literals :: ParserInfo -> Input FToken -> [(FCat,Item)]