mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
use MultiMap from the reference implementation instead of GeneralDeduction and RedBlackTree
This commit is contained in:
krasimir
6
GF.cabal
6
GF.cabal
@@ -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
|
||||
|
||||
@@ -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
|
||||
--------------------------------------------------------------------------------}
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
|
||||
@@ -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)]
|
||||
|
||||
Reference in New Issue
Block a user