From 620e88015572efb6d35ed34e444fb631cacb168d Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Wed, 30 Oct 2013 14:42:29 +0000 Subject: [PATCH] linref is now used by the linearizer. The visible change is that the 'l' command in the shell now can linearize discontinuous phrases --- src/compiler/GF/Command/Commands.hs | 2 +- src/runtime/haskell/PGF/Forest.hs | 10 +++--- src/runtime/haskell/PGF/Linearize.hs | 45 +++++++++++++----------- src/runtime/haskell/PGF/Macros.hs | 21 +++++------ src/runtime/haskell/PGF/VisualizeTree.hs | 18 +++++----- src/server/PGFService.hs | 6 ++-- 6 files changed, 54 insertions(+), 48 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 681b64f0d..8a19d2729 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index e6e3c1136..89ebfb299 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -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 diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs index 7ff7d9c7a..1e3aee02e 100644 --- a/src/runtime/haskell/PGF/Linearize.hs +++ b/src/runtime/haskell/PGF/Linearize.hs @@ -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 = [] diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index ffec9279f..ce0f8866e 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -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] diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 940d5950e..ed028feb8 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -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 diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index fcda86e7c..1f4e2bdce 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -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