mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-02 15:52:50 -06:00
change the library root namespace from GF.GFCC to PGF
This commit is contained in:
krasimir
271
src-3.0/PGF/Parsing/FCFG/Utilities.hs
Normal file
271
src-3.0/PGF/Parsing/FCFG/Utilities.hs
Normal file
@@ -0,0 +1,271 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/05/13 12:40:19 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Basic type declarations and functions for grammar formalisms
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module PGF.Parsing.FCFG.Utilities where
|
||||
|
||||
import Control.Monad
|
||||
import Data.Array
|
||||
import Data.List (groupBy)
|
||||
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.Assoc
|
||||
import GF.Data.Utilities (sameLength, foldMerge, splitBy)
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- ranges as single pairs
|
||||
|
||||
type RangeRec = [Range]
|
||||
|
||||
data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int
|
||||
| EmptyRange
|
||||
deriving (Eq, Ord)
|
||||
|
||||
makeRange :: Int -> Int -> Range
|
||||
makeRange = Range
|
||||
|
||||
concatRange :: Range -> Range -> [Range]
|
||||
concatRange EmptyRange rng = return rng
|
||||
concatRange rng EmptyRange = return rng
|
||||
concatRange (Range i j) (Range j' k) = [Range i k | j==j']
|
||||
|
||||
minRange :: Range -> Int
|
||||
minRange (Range i j) = i
|
||||
|
||||
maxRange :: Range -> Int
|
||||
maxRange (Range i j) = j
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * representaions of input tokens
|
||||
|
||||
data Input t = MkInput { inputBounds :: (Int, Int),
|
||||
inputToken :: Assoc t [Range]
|
||||
}
|
||||
|
||||
input :: Ord t => [t] -> Input t
|
||||
input toks = MkInput inBounds inToken
|
||||
where
|
||||
inBounds = (0, length toks)
|
||||
inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,tok) <- zip3 [0..] [1..] toks ]
|
||||
|
||||
inputMany :: Ord t => [[t]] -> Input t
|
||||
inputMany toks = MkInput inBounds inToken
|
||||
where
|
||||
inBounds = (0, length toks)
|
||||
inToken = accumAssoc id [ (tok, makeRange i j) | (i,j,ts) <- zip3 [0..] [1..] toks, tok <- ts ]
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
-- * representations of syntactical analyses
|
||||
|
||||
-- ** charts as finite maps over edges
|
||||
|
||||
-- | The values of the chart, a list of key-daughters pairs,
|
||||
-- has unique keys. In essence, it is a map from 'n' to daughters.
|
||||
-- The daughters should be a set (not necessarily sorted) of rhs's.
|
||||
type SyntaxChart n e = Assoc e [SyntaxNode n [e]]
|
||||
|
||||
data SyntaxNode n e = SMeta
|
||||
| SNode n [e]
|
||||
| SString String
|
||||
| SInt Integer
|
||||
| SFloat Double
|
||||
deriving (Eq,Ord)
|
||||
|
||||
groupSyntaxNodes :: Ord n => [SyntaxNode n e] -> [SyntaxNode n [e]]
|
||||
groupSyntaxNodes [] = []
|
||||
groupSyntaxNodes (SNode n0 es0:xs) = (SNode n0 (es0:ess)) : groupSyntaxNodes xs'
|
||||
where
|
||||
(ess,xs') = span xs
|
||||
|
||||
span [] = ([],[])
|
||||
span xs@(SNode n es:xs')
|
||||
| n0 == n = let (ess,xs) = span xs' in (es:ess,xs)
|
||||
| otherwise = ([],xs)
|
||||
groupSyntaxNodes (SString s:xs) = (SString s) : groupSyntaxNodes xs
|
||||
groupSyntaxNodes (SInt n:xs) = (SInt n) : groupSyntaxNodes xs
|
||||
groupSyntaxNodes (SFloat f:xs) = (SFloat f) : groupSyntaxNodes xs
|
||||
|
||||
-- better(?) representation of forests:
|
||||
-- data Forest n = F (SMap n (SList [Forest n])) Bool
|
||||
-- ==
|
||||
-- type Forest n = GeneralTrie n (SList [Forest n]) Bool
|
||||
-- (the Bool == isMeta)
|
||||
|
||||
-- ** syntax forests
|
||||
|
||||
data SyntaxForest n = FMeta
|
||||
| FNode n [[SyntaxForest n]]
|
||||
-- ^ The outer list should be a set (not necessarily sorted)
|
||||
-- of possible alternatives. Ie. the outer list
|
||||
-- is a disjunctive node, and the inner lists
|
||||
-- are (conjunctive) concatenative nodes
|
||||
| FString String
|
||||
| FInt Integer
|
||||
| FFloat Double
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor SyntaxForest where
|
||||
fmap f (FNode n forests) = FNode (f n) $ map (map (fmap f)) forests
|
||||
fmap _ (FString s) = FString s
|
||||
fmap _ (FInt n) = FInt n
|
||||
fmap _ (FFloat f) = FFloat f
|
||||
fmap _ (FMeta) = FMeta
|
||||
|
||||
forestName :: SyntaxForest n -> Maybe n
|
||||
forestName (FNode n _) = Just n
|
||||
forestName _ = Nothing
|
||||
|
||||
unifyManyForests :: (Monad m, Eq n) => [SyntaxForest n] -> m (SyntaxForest n)
|
||||
unifyManyForests = foldM unifyForests FMeta
|
||||
|
||||
-- | two forests can be unified, if either is 'FMeta', or both have the same parent,
|
||||
-- and all children can be unified
|
||||
unifyForests :: (Monad m, Eq n) => SyntaxForest n -> SyntaxForest n -> m (SyntaxForest n)
|
||||
unifyForests FMeta forest = return forest
|
||||
unifyForests forest FMeta = return forest
|
||||
unifyForests (FNode name1 children1) (FNode name2 children2)
|
||||
| name1 == name2 && not (null children) = return $ FNode name1 children
|
||||
where children = [ forests | forests1 <- children1, forests2 <- children2,
|
||||
sameLength forests1 forests2,
|
||||
forests <- zipWithM unifyForests forests1 forests2 ]
|
||||
unifyForests (FString s1) (FString s2)
|
||||
| s1 == s2 = return $ FString s1
|
||||
unifyForests (FInt n1) (FInt n2)
|
||||
| n1 == n2 = return $ FInt n1
|
||||
unifyForests (FFloat f1) (FFloat f2)
|
||||
| f1 == f2 = return $ FFloat f1
|
||||
unifyForests _ _ = fail "forest unification failure"
|
||||
|
||||
{- måste tänka mer på detta:
|
||||
compactForests :: Ord n => [SyntaxForest n] -> SList (SyntaxForest n)
|
||||
compactForests = map joinForests . groupBy eqNames . sortForests
|
||||
where eqNames f g = forestName f == forestName g
|
||||
sortForests = foldMerge mergeForests [] . map return
|
||||
mergeForests [] gs = gs
|
||||
mergeForests fs [] = fs
|
||||
mergeForests fs@(f:fs') gs@(g:gs')
|
||||
= case forestName f `compare` forestName g of
|
||||
LT -> f : mergeForests fs' gs
|
||||
GT -> g : mergeForests fs gs'
|
||||
EQ -> f : g : mergeForests fs' gs'
|
||||
joinForests fs = case forestName (head fs) of
|
||||
Nothing -> FMeta
|
||||
Just name -> FNode name $
|
||||
compactDaughters $
|
||||
concat [ fss | FNode _ fss <- fs ]
|
||||
compactDaughters fss = case head fss of
|
||||
[] -> [[]]
|
||||
[_] -> map return $ compactForests $ concat fss
|
||||
_ -> nubsort fss
|
||||
-}
|
||||
|
||||
-- ** syntax trees
|
||||
|
||||
data SyntaxTree n = TMeta
|
||||
| TNode n [SyntaxTree n]
|
||||
| TString String
|
||||
| TInt Integer
|
||||
| TFloat Double
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor SyntaxTree where
|
||||
fmap f (TNode n trees) = TNode (f n) $ map (fmap f) trees
|
||||
fmap _ (TString s) = TString s
|
||||
fmap _ (TInt n) = TInt n
|
||||
fmap _ (TFloat f) = TFloat f
|
||||
fmap _ (TMeta) = TMeta
|
||||
|
||||
treeName :: SyntaxTree n -> Maybe n
|
||||
treeName (TNode n _) = Just n
|
||||
treeName (TMeta) = Nothing
|
||||
|
||||
unifyManyTrees :: (Monad m, Eq n) => [SyntaxTree n] -> m (SyntaxTree n)
|
||||
unifyManyTrees = foldM unifyTrees TMeta
|
||||
|
||||
-- | two trees can be unified, if either is 'TMeta',
|
||||
-- or both have the same parent, and their children can be unified
|
||||
unifyTrees :: (Monad m, Eq n) => SyntaxTree n -> SyntaxTree n -> m (SyntaxTree n)
|
||||
unifyTrees TMeta tree = return tree
|
||||
unifyTrees tree TMeta = return tree
|
||||
unifyTrees (TNode name1 children1) (TNode name2 children2)
|
||||
| name1 == name2 && sameLength children1 children2
|
||||
= liftM (TNode name1) $ zipWithM unifyTrees children1 children2
|
||||
unifyTrees (TString s1) (TString s2)
|
||||
| s1 == s2 = return (TString s1)
|
||||
unifyTrees (TInt n1) (TInt n2)
|
||||
| n1 == n2 = return (TInt n1)
|
||||
unifyTrees (TFloat f1) (TFloat f2)
|
||||
| f1 == f2 = return (TFloat f1)
|
||||
unifyTrees _ _ = fail "tree unification failure"
|
||||
|
||||
-- ** conversions between representations
|
||||
|
||||
chart2forests :: (Ord n, Ord e) =>
|
||||
SyntaxChart n e -- ^ The complete chart
|
||||
-> (e -> Bool) -- ^ When is an edge 'FMeta'?
|
||||
-> [e] -- ^ The starting edges
|
||||
-> SList (SyntaxForest n) -- ^ The result has unique keys, ie. all 'n' are joined together.
|
||||
-- In essence, the result is a map from 'n' to forest daughters
|
||||
|
||||
-- simplest implementation
|
||||
|
||||
chart2forests chart isMeta = concatMap (edge2forests [])
|
||||
where edge2forests edges edge
|
||||
| isMeta edge = [FMeta]
|
||||
| edge `elem` edges = []
|
||||
| otherwise = map (item2forest (edge:edges)) $ chart ? edge
|
||||
item2forest edges (SMeta) = FMeta
|
||||
item2forest edges (SNode name children) =
|
||||
FNode name $ children >>= mapM (edge2forests edges)
|
||||
item2forest edges (SString s) = FString s
|
||||
item2forest edges (SInt n) = FInt n
|
||||
item2forest edges (SFloat f) = FFloat f
|
||||
|
||||
{- -before AR inserted peb's patch 8/7/2007, this was:
|
||||
|
||||
chart2forests chart isMeta = concatMap edge2forests
|
||||
where edge2forests edge = if isMeta edge then [FMeta]
|
||||
else map item2forest $ chart ? edge
|
||||
item2forest (SMeta) = FMeta
|
||||
item2forest (SNode name children) = FNode name $ children >>= mapM edge2forests
|
||||
item2forest (SString s) = FString s
|
||||
item2forest (SInt n) = FInt n
|
||||
item2forest (SFloat f) = FFloat f
|
||||
|
||||
-}
|
||||
|
||||
{-
|
||||
-- more intelligent(?) implementation,
|
||||
-- requiring that charts and forests are sorted maps and sorted sets
|
||||
chart2forests chart isMeta = es2fs
|
||||
where e2fs e = if isMeta e then [FMeta] else map i2f $ chart ? e
|
||||
es2fs es = if null metas then fs else FMeta : fs
|
||||
where (metas, nonMetas) = splitBy isMeta es
|
||||
fs = map i2f $ unionMap (<++>) $ map (chart ?) nonMetas
|
||||
i2f (name, children) = FNode name $
|
||||
case head children of
|
||||
[] -> [[]]
|
||||
[_] -> map return $ es2fs $ concat children
|
||||
_ -> children >>= mapM e2fs
|
||||
-}
|
||||
|
||||
|
||||
forest2trees :: SyntaxForest n -> SList (SyntaxTree n)
|
||||
forest2trees (FNode n forests) = map (TNode n) $ forests >>= mapM forest2trees
|
||||
forest2trees (FString s) = [TString s]
|
||||
forest2trees (FInt n) = [TInt n]
|
||||
forest2trees (FFloat f) = [TFloat f]
|
||||
forest2trees (FMeta) = [TMeta]
|
||||
Reference in New Issue
Block a user