GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-15 06:02:55 -06:00
Code Issues Packages Projects Releases Wiki Activity

linref is now used by the linearizer. The visible change is that the 'l' command in the shell now can linearize discontinuous phrases

Browse Source
This commit is contained in:
kr.angelov
2013-10-30 14:42:29 +00:00
parent 9e81b8b224
commit 620e880155
6 changed files with 54 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files

45
src/runtime/haskell/PGF/Linearize.hs
View File

@@ -23,7 +23,9 @@ import qualified Data.Set as Set
-- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Tree -> String
linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin) . linTree pgf lang
linearize pgf lang = concat . take 1 . map (unwords . concatMap flattenBracketedString . snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
where
cnc = lookMap (error "no lang") lang (concretes pgf)
-- | The same as 'linearizeAllLang' but does not return
-- the language.
@@ -36,24 +38,29 @@ linearizeAllLang :: PGF -> Tree -> [(Language,String)]
linearizeAllLang pgf t = [(lang,linearize pgf lang t) | lang <- Map.keys (concretes pgf)]
-- | Linearizes given expression as a bracketed string in the language
bracketedLinearize :: PGF -> Language -> Tree -> BracketedString
bracketedLinearize pgf lang = head . concat . map (snd . untokn Nothing . firstLin) . linTree pgf lang
bracketedLinearize :: PGF -> Language -> Tree -> [BracketedString]
bracketedLinearize pgf lang = concat . map (snd . untokn Nothing . firstLin cnc) . linTree pgf cnc
where
cnc = lookMap (error "no lang") lang (concretes pgf)
-- head [] = error "cannot linearize"
head [] = Leaf ""
-- so that linearize = flattenBracketedString . bracketedLinearize
head (bs:bss) = bs
firstLin (_,arr)
| inRange (bounds arr) 0 = arr ! 0
| otherwise = LeafKS []
firstLin cnc arg@(ct@(cat,n_fid),fid,fun,es,(xs,lin)) =
case IntMap.lookup fid (linrefs cnc) of
Just (funid:_) -> snd (mkLinTable cnc (const True) [] funid [arg]) ! 0
_ -> [LeafKS []]
-- | Creates a table from feature name to linearization.
-- The outher list encodes the variations
tabularLinearizes :: PGF -> Language -> Expr -> [[(String,String)]]
tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
tabularLinearizes pgf lang e = map cnv (linTree pgf cnc e)
where
cnv ((cat,_),lin) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
cnc = lookMap (error "no lang") lang (concretes pgf)
cnv (ct@(cat,_),_,_,_,(_,lin)) = zip (lbls cat) $ map (unwords . concatMap flattenBracketedString . snd . untokn Nothing) (elems lin)
lbls cat = case Map.lookup cat (cnccats (lookConcr pgf lang)) of
Just (CncCat _ _ lbls) -> elems lbls
@@ -63,11 +70,9 @@ tabularLinearizes pgf lang e = map cnv (linTree pgf lang e)
-- Implementation
--------------------------------------------------------------------
linTree :: PGF -> Language -> Expr -> [(CncType, Array LIndex BracketedTokn)]
linTree pgf lang e =
nub [(ct,amapWithIndex (\label -> Bracket_ cat fid label fun es) lin) | (_,(ct@(cat,fid),fun,es,(xs,lin))) <- lin Nothing 0 e [] [] e []]
linTree :: PGF -> Concr -> Expr -> [(CncType, FId, CId, [Expr], LinTable)]
linTree pgf cnc e = nub (map snd (lin Nothing 0 e [] [] e []))
where
cnc = lookMap (error "no lang") lang (concretes pgf)
lp = lproductions cnc
lin mb_cty n_fid e0 ys xs (EAbs _ x e) es = lin mb_cty n_fid e0 ys (x:xs) e es
@@ -78,18 +83,18 @@ linTree pgf lang e =
lin mb_cty n_fid e0 ys xs (EMeta i) es = def mb_cty n_fid e0 ys xs ('?':show i)
lin mb_cty n_fid e0 ys xs (EVar i) _ = def mb_cty n_fid e0 ys xs (showCId ((xs++ys) !! i))
lin mb_cty n_fid e0 ys xs (ELit l) [] = case l of
LStr s -> return (n_fid+1,((cidString,n_fid),wildCId,[e0],([],ss s)))
LInt n -> return (n_fid+1,((cidInt, n_fid),wildCId,[e0],([],ss (show n))))
LFlt f -> return (n_fid+1,((cidFloat, n_fid),wildCId,[e0],([],ss (show f))))
LStr s -> return (n_fid+1,((cidString,n_fid),fidString,wildCId,[e0],([],ss s)))
LInt n -> return (n_fid+1,((cidInt, n_fid),fidInt, wildCId,[e0],([],ss (show n))))
LFlt f -> return (n_fid+1,((cidFloat, n_fid),fidFloat, wildCId,[e0],([],ss (show f))))
ss s = listArray (0,0) [[LeafKS s]]
apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, CId, [Expr], LinTable))]
apply :: Maybe CncType -> FId -> Expr -> [CId] -> [CId] -> CId -> [Expr] -> [(FId,(CncType, FId, CId, [Expr], LinTable))]
apply mb_cty n_fid e0 ys xs f es =
case Map.lookup f lp of
Just prods -> do (funid,(cat,fid),ctys) <- getApps prods
(n_fid,args) <- descend n_fid (zip ctys es)
return (n_fid+1,((cat,n_fid),f,[e0],mkLinTable cnc (const True) xs funid args))
return (n_fid+1,((cat,n_fid),fid,f,[e0],mkLinTable cnc (const True) xs funid args))
Nothing -> def mb_cty n_fid e0 ys xs ("[" ++ showCId f ++ "]") -- fun without lin
where
getApps prods =
@@ -112,10 +117,10 @@ linTree pgf lang e =
def (Just (cat,fid)) n_fid e0 ys xs s =
case IntMap.lookup fid (lindefs cnc) of
Just funs -> do funid <- funs
let args = [((wildCId, n_fid),wildCId,[e0],([],ss s))]
return (n_fid+2,((cat,n_fid+1),wildCId,[e0],mkLinTable cnc (const True) xs funid args))
let args = [((wildCId, n_fid),fidString,wildCId,[e0],([],ss s))]
return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],mkLinTable cnc (const True) xs funid args))
Nothing
| isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
| isPredefFId fid -> return (n_fid+2,((cat,n_fid+1),fid,wildCId,[e0],(xs,listArray (0,0) [[LeafKS s]])))
| otherwise -> do PCoerce fid <- maybe [] Set.toList (IntMap.lookup fid (pproductions cnc))
def (Just (cat,fid)) n_fid e0 ys xs s
def Nothing n_fid e0 ys xs s = []