diff options
| -rw-r--r-- | GF.cabal | 6 | ||||
| -rw-r--r-- | src-3.0/GF/Data/GeneralDeduction.hs | 121 | ||||
| -rw-r--r-- | src-3.0/GF/Data/RedBlackSet.hs | 150 | ||||
| -rw-r--r-- | src-3.0/PGF/Parsing/FCFG/Active.hs | 16 |
4 files changed, 10 insertions, 283 deletions
@@ -40,8 +40,7 @@ library PGF.Raw.Print PGF.Raw.Convert PGF.Raw.Abstract - GF.Data.RedBlackSet - GF.Data.GeneralDeduction + GF.Data.MultiMap 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 diff --git a/src-3.0/GF/Data/GeneralDeduction.hs b/src-3.0/GF/Data/GeneralDeduction.hs deleted file mode 100644 index 137212e5c..000000000 --- a/src-3.0/GF/Data/GeneralDeduction.hs +++ /dev/null @@ -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 ---------------------------------------------------------------------------------} - diff --git a/src-3.0/GF/Data/RedBlackSet.hs b/src-3.0/GF/Data/RedBlackSet.hs deleted file mode 100644 index 8a1b8a743..000000000 --- a/src-3.0/GF/Data/RedBlackSet.hs +++ /dev/null @@ -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) - - - diff --git a/src-3.0/PGF/Parsing/FCFG/Active.hs b/src-3.0/PGF/Parsing/FCFG/Active.hs index 4572062f1..71352c725 100644 --- a/src-3.0/PGF/Parsing/FCFG/Active.hs +++ b/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 -lookupXChartFinal (XChart actives finals) c = chartLookup finals c +lookupXChartAct (XChart actives finals) c = actives MM.! 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)] |