GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-14 15:29:31 -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

2
src/compiler/GF/Command/Commands.hs
View File

@@ -1166,7 +1166,7 @@ allCommands = Map.fromList [
map (map (unl . snd)) . tabularLinearizes pgf lang
_ | isOpt "table" opts -> unlines . concat . intersperse [[]] .
map (map (\(p,v) -> p+++":"+++unl v)) . tabularLinearizes pgf lang
_ | isOpt "bracket" opts -> showBracketedString . bracketedLinearize pgf lang
_ | isOpt "bracket" opts -> unwords . map showBracketedString . bracketedLinearize pgf lang
_ -> unl . linearize pgf lang
-- replace each non-atomic constructor with mkC, where C is the val cat

10
src/runtime/haskell/PGF/Forest.hs
View File

@@ -47,7 +47,7 @@ data Forest
--------------------------------------------------------------------
linearizeWithBrackets :: Maybe Int -> Forest -> BracketedString
linearizeWithBrackets dp = head . snd . untokn Nothing . bracketedTokn dp
linearizeWithBrackets dp = head . snd . untokn Nothing . (:[]) .bracketedTokn dp
---------------------------------------------------------------
-- Internally we have to do everything with Tokn first because
@@ -67,8 +67,8 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
render forest arg@(PArg hypos fid) =
case IntMap.lookup fid forest >>= Set.maxView of
Just (p,set) -> let (ct,fun,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p
in (ct,fun,es,(map getVar hypos,lin))
Just (p,set) -> let (ct,fid',fun,es,(_,lin)) = descend (if Set.null set then forest else IntMap.insert fid set forest) p
in (ct,fid',fun,es,(map getVar hypos,lin))
Nothing -> error ("wrong forest id " ++ show fid)
where
descend forest (PApply funid args) = let (CncFun fun lins) = cncfuns cnc ! funid
@@ -78,9 +78,9 @@ bracketedTokn dp f@(Forest abs cnc forest root) =
Just (DTyp _ cat _,_,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
in ((cat,fid),0,wildCId,either (const []) id $ getAbsTrees f arg Nothing dp,ltable)
descend forest (PCoerce fid) = render forest (PArg [] fid)
descend forest (PConst cat e ts) = ((cat,fid),wildCId,[e],([],listArray (0,0) [map LeafKS ts]))
descend forest (PConst cat e ts) = ((cat,fid),0,wildCId,[e],([],listArray (0,0) [map LeafKS ts]))
getVar (fid,_)
| fid == fidVar = wildCId

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 = []

21
src/runtime/haskell/PGF/Macros.hs
View File

@@ -179,11 +179,12 @@ lengthBracketedString :: BracketedString -> Int
lengthBracketedString (Leaf _) = 1
lengthBracketedString (Bracket _ _ _ _ _ bss) = sum (map lengthBracketedString bss)
untokn :: Maybe String -> BracketedTokn -> (Maybe String,[BracketedString])
untokn nw bs =
case untokn nw bs of
(nw,Nothing ) -> (nw,[] )
(nw,Just bss) -> (nw,bss)
untokn :: Maybe String -> [BracketedTokn] -> (Maybe String,[BracketedString])
untokn nw bss =
let (nw',bss') = mapAccumR untokn nw bss
in case sequence bss' of
Just bss -> (nw,concat bss)
Nothing -> (nw,[])
where
untokn nw (Bracket_ cat fid index fun es bss) =
let (nw',bss') = mapAccumR untokn nw bss
@@ -207,12 +208,12 @@ untokn nw bs =
type CncType = (CId, FId) -- concrete type is the abstract type (the category) + the forest id
mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,CId,[Expr],LinTable)] -> LinTable
mkLinTable :: Concr -> (CncType -> Bool) -> [CId] -> FunId -> [(CncType,FId,CId,[Expr],LinTable)] -> LinTable
mkLinTable cnc filter xs funid args = (xs,listArray (bounds lins) [computeSeq filter (elems (sequences cnc ! seqid)) args | seqid <- elems lins])
where
(CncFun _ lins) = cncfuns cnc ! funid
computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq :: (CncType -> Bool) -> [Symbol] -> [(CncType,FId,CId,[Expr],LinTable)] -> [BracketedTokn]
computeSeq filter seq args = concatMap compute seq
where
compute (SymCat d r) = getArg d r
@@ -228,12 +229,12 @@ computeSeq filter seq args = concatMap compute seq
filter ct = [Bracket_ cat fid r fun es arg_lin]
| otherwise = arg_lin
where
arg_lin = lin ! r
(ct@(cat,fid),fun,es,(xs,lin)) = args !! d
arg_lin = lin ! r
(ct@(cat,fid),_,fun,es,(xs,lin)) = args !! d
getVar d r = [LeafKS (showCId (xs !! r))]
where
(ct,fun,es,(xs,lin)) = args !! d
(ct,_,fun,es,(xs,lin)) = args !! d
flattenBracketedString :: BracketedString -> [String]
flattenBracketedString (Leaf w) = [w]

18
src/runtime/haskell/PGF/VisualizeTree.hs
View File

@@ -137,11 +137,11 @@ graphvizDependencyTree format debug mlab ms pgf lang t = render $
nil = -1
bs = bracketedLinearize pgf lang t
bss = bracketedLinearize pgf lang t
root = (wildCId,nil,wildCId)
leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . getLeaves root) bs
leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . concatMap (getLeaves root)) bss
deps = let (_,(h,deps)) = getDeps 0 [] t []
in (h,(dep_lbl,nil)):deps
@@ -213,8 +213,8 @@ graphvizParseTree :: PGF -> Language -> GraphvizOptions -> Tree -> String
graphvizParseTree pgf lang opts = graphvizBracketedString opts . bracketedLinearize pgf lang
graphvizBracketedString :: GraphvizOptions -> BracketedString -> String
graphvizBracketedString opts bs = render graphviz_code
graphvizBracketedString :: GraphvizOptions -> [BracketedString] -> String
graphvizBracketedString opts bss = render graphviz_code
where
graphviz_code
= text "graph {" $$
@@ -250,10 +250,10 @@ graphvizBracketedString opts bs = render graphviz_code
nil = -1
internal_nodes = [mkLevel internals |
internals <- getInternals [(nil, bs)],
internals <- getInternals (map ((,) nil) bss),
not (null internals)]
leaf_nodes = mkLevel [(parent, id, word) |
(id, (parent, word)) <- zip [100000..] (getLeaves nil bs)]
(id, (parent, word)) <- zip [100000..] (concatMap (getLeaves nil) bss)]
getInternals [] = []
getInternals nodes
@@ -300,12 +300,12 @@ genPreAlignment pgf langs = lin2align . linsBracketed
where
linsBracketed t = [bracketedLinearize pgf lang t | lang <- langs]
lin2align :: [BracketedString] -> PreAlign
lin2align bss = PreAlign langSeqs langRels
lin2align :: [[BracketedString]] -> PreAlign
lin2align bsss = PreAlign langSeqs langRels
where
(langSeqs,langRels) = mkLayers leaves
nil = -1
leaves = map (groupAndIndexIt 0 . getLeaves nil) bss
leaves = map (groupAndIndexIt 0 . concatMap (getLeaves nil)) bsss
groupAndIndexIt id [] = []
groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws

6
src/server/PGFService.hs
View File

@@ -601,9 +601,9 @@ linearizeTabular pgf tos tree =
vs = concat (PGF.tabularLinearizes pgf to t)
linearizeAndBind pgf mto tree =
[(to,s,bs) | to<-langs,
let bs = PGF.bracketedLinearize pgf to (transfer to tree)
s = unwords . bind $ PGF.flattenBracketedString bs]
[(to,s,bss) | to<-langs,
let bss = PGF.bracketedLinearize pgf to (transfer to tree)
s = unwords . bind $ concatMap PGF.flattenBracketedString bss]
where
langs = if null mto then PGF.languages pgf else mto