mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
the generation of dependency trees in the Haskell runtime is now finally working with bracketed strings. This also fixes some errors in the old implementation
This commit is contained in:
kr.angelov
@@ -28,7 +28,7 @@ module PGF.VisualizeTree
|
||||
, getDepLabels
|
||||
) where
|
||||
|
||||
import PGF.CId (CId,showCId,ppCId,pCId,mkCId)
|
||||
import PGF.CId (CId,wildCId,showCId,ppCId,pCId,mkCId)
|
||||
import PGF.Data
|
||||
import PGF.Expr (showExpr, Tree)
|
||||
import PGF.Linearize
|
||||
@@ -37,7 +37,7 @@ import PGF.Macros (lookValCat, lookMap,
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.List (intersperse,nub,isPrefixOf,sort,sortBy)
|
||||
import Data.List (intersperse,nub,mapAccumL)
|
||||
import Data.Char (isDigit)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Text.PrettyPrint
|
||||
@@ -116,33 +116,39 @@ graphvizAbstractTree pgf (funs,cats) = render . tree2graph
|
||||
|
||||
type Labels = Map.Map CId [String]
|
||||
|
||||
{- This is an attempt to build the dependency tree from the bracketed string.
|
||||
Unfortunately it doesn't quite work. See the actual implementation at
|
||||
the end of this module.
|
||||
|
||||
graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Tree -> String
|
||||
graphvizDependencyTree format debug mlab ms pgf lang t = render $
|
||||
case format of
|
||||
"malt" -> vcat (map (hcat . intersperse (char '\t') ) wnodes)
|
||||
"conll" -> vcat (map (hcat . intersperse (char '\t') ) wnodes)
|
||||
"malt_input" -> vcat (map (hcat . intersperse (char '\t') . take 6) wnodes)
|
||||
_ -> text "digraph {" $$
|
||||
space $$
|
||||
nest 2 (text "rankdir=LR ;" $$
|
||||
nest 2 (text "rankdir=RL ;" $$
|
||||
text "node [shape = plaintext] ;" $$
|
||||
vcat nodes $$
|
||||
vcat links) $$
|
||||
text "}"
|
||||
where
|
||||
nodes = map mkNode leaves
|
||||
links = map mkLink [(fid, fromMaybe nil (lookup fid deps)) | (fid,_,w) <- tail leaves]
|
||||
wnodes = undefined
|
||||
links = map mkLink [(fid, fromMaybe (dep_lbl,nil) (lookup fid deps)) | ((cat,fid,fun),_,w) <- tail leaves]
|
||||
|
||||
wnodes = [[int i, maltws ws, ppCId fun, ppCId cat, ppCId cat, unspec, int parent, text lab, unspec, unspec] |
|
||||
((cat,fid,fun),i,ws) <- tail leaves,
|
||||
let (lab,parent) = maybe (dep_lbl,0)
|
||||
(\(lbl,fid) -> (lbl,head [i | ((_,fid1,_),i,_) <- leaves, fid == fid1]))
|
||||
(lookup fid deps)
|
||||
]
|
||||
maltws = text . concat . intersperse "+" . words -- no spaces in column 2
|
||||
|
||||
nil = -1
|
||||
|
||||
bs = bracketedLinearize pgf lang t
|
||||
|
||||
leaves = (nil,0,"ROOT") : (groupAndIndexIt 1 . getLeaves nil) bs
|
||||
deps = getDeps nil [bs]
|
||||
root = (wildCId,nil,wildCId)
|
||||
|
||||
leaves = (root,0,root_lbl) : (groupAndIndexIt 1 . getLeaves root) bs
|
||||
deps = let (_,(h,deps)) = getDeps 0 [] t []
|
||||
in (h,(dep_lbl,nil)):deps
|
||||
|
||||
groupAndIndexIt id [] = []
|
||||
groupAndIndexIt id ((p,w):pws) = let (ws,pws1) = collect pws
|
||||
@@ -155,32 +161,54 @@ graphvizDependencyTree format debug mlab ms pgf lang t = render $
|
||||
|
||||
getLeaves parent bs =
|
||||
case bs of
|
||||
Leaf w -> [(parent,w)]
|
||||
Bracket _ fid _ _ bss -> concatMap (getLeaves fid) bss
|
||||
Leaf w -> [(parent,w)]
|
||||
Bracket cat fid _ fun _ bss -> concatMap (getLeaves (cat,fid,fun)) bss
|
||||
|
||||
getDeps out_head bss =
|
||||
case selectHead (children bss) of
|
||||
Just ((head, bss'), deps) -> concat (descend out_head head bss' : [descend (headOf head bss') fid bss | (fid,bss) <- IntMap.toList deps])
|
||||
Nothing -> []
|
||||
where
|
||||
descend head fid bss = (fid,head) : getDeps head bss
|
||||
|
||||
headOf head bss
|
||||
| null [() | Leaf _ <- bss] =
|
||||
case selectHead (children bss) of
|
||||
Just ((head, bss), deps) -> headOf head bss
|
||||
Nothing -> head
|
||||
| otherwise = head
|
||||
|
||||
children bss = IntMap.fromListWith (++) [(fid,bss) | Bracket _ fid _ _ bss <- bss]
|
||||
|
||||
selectHead children = IntMap.maxViewWithKey children
|
||||
|
||||
mkNode (p,i,w) =
|
||||
mkNode ((_,p,_),i,w) =
|
||||
tag p <+> brackets (text "label = " <> doubleQuotes (int i <> char '.' <+> text w)) <+> semi
|
||||
|
||||
mkLink (x,y) = tag y <+> text "->" <+> tag x -- ++ " [label = \"" ++ l ++ "\"] ;"
|
||||
-}
|
||||
mkLink (x,(lbl,y)) = tag x <+> text "->" <+> tag y <+> text "[label = " <> doubleQuotes (text lbl) <> text "] ;"
|
||||
|
||||
labels = maybe Map.empty id mlab
|
||||
|
||||
getDeps n_fid xs (EAbs _ x e) es = getDeps n_fid (x:xs) e es
|
||||
getDeps n_fid xs (EApp e1 e2) es = getDeps n_fid xs e1 (e2:es)
|
||||
getDeps n_fid xs (EImplArg e) es = getDeps n_fid xs e es
|
||||
getDeps n_fid xs (ETyped e _) es = getDeps n_fid xs e es
|
||||
getDeps n_fid xs (EFun f) es = let (n_fid_1,ds) = descend n_fid xs es
|
||||
(mb_h, deps) = selectHead f ds
|
||||
in case mb_h of
|
||||
Just (fid,deps0) -> (n_fid_1+1,(fid,deps0++
|
||||
[(n_fid_1,(dep_lbl,fid))]++
|
||||
concat [(m,(lbl,fid)):ds | (lbl,(m,ds)) <- deps]))
|
||||
Nothing -> (n_fid_1+1,(n_fid_1,concat [(m,(lbl,n_fid_1)):ds | (lbl,(m,ds)) <- deps]))
|
||||
getDeps n_fid xs (EMeta i) es = (n_fid+2,(n_fid,[]))
|
||||
getDeps n_fid xs (EVar i) _ = (n_fid+2,(n_fid,[]))
|
||||
getDeps n_fid xs (ELit l) [] = (n_fid+1,(n_fid,[]))
|
||||
|
||||
descend n_fid xs es = mapAccumL (\n_fid e -> getDeps n_fid xs e []) n_fid es
|
||||
|
||||
selectHead f ds =
|
||||
case Map.lookup f labels of
|
||||
Just lbls -> extractHead (zip lbls ds)
|
||||
Nothing -> extractLast ds
|
||||
where
|
||||
extractHead [] = (Nothing, [])
|
||||
extractHead (ld@(l,d):lds)
|
||||
| l == head_lbl = (Just d,lds)
|
||||
| otherwise = let (mb_h,deps) = extractHead lds
|
||||
in (mb_h,ld:deps)
|
||||
|
||||
extractLast [] = (Nothing, [])
|
||||
extractLast (d:ds)
|
||||
| null ds = (Just d,[])
|
||||
| otherwise = let (mb_h,deps) = extractLast ds
|
||||
in (mb_h,(dep_lbl,d):deps)
|
||||
|
||||
dep_lbl = "dep"
|
||||
head_lbl = "head"
|
||||
root_lbl = "ROOT"
|
||||
unspec = text "_"
|
||||
|
||||
getDepLabels :: [String] -> Labels
|
||||
getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
|
||||
@@ -427,213 +455,3 @@ tbrackets d = char '<' <> d <> char '>'
|
||||
tag i
|
||||
| i < 0 = char 'r' <> int (negate i)
|
||||
| otherwise = char 'n' <> int i
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- The linearization code bellow is needed just in order to
|
||||
-- produce the dependency tree. Unfortunately the bracketed string
|
||||
-- doesn't give us an easy way to find which part of the string
|
||||
-- corresponds to which argument of the parent function.
|
||||
--
|
||||
-- Uuuuugly!!! I hope that this code will be removed one day.
|
||||
|
||||
type LinTable = Array LIndex [BracketedTokn]
|
||||
|
||||
|
||||
linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
|
||||
linTree pgf lang mark e = lin0 [] [] [] Nothing e
|
||||
where
|
||||
cnc = lookMap (error "no lang") lang (concretes pgf)
|
||||
lp = lproductions cnc
|
||||
|
||||
lin0 path xs ys mb_fid (EAbs _ x e) = lin0 path (showCId x:xs) ys mb_fid e
|
||||
lin0 path xs ys mb_fid (ETyped e _) = lin0 path xs ys mb_fid e
|
||||
lin0 path xs ys mb_fid e = lin path ys mb_fid e []
|
||||
|
||||
lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es)
|
||||
lin path xs mb_fid (ELit l) [] = case l of
|
||||
LStr s -> return (mark Nothing path (ss s))
|
||||
LInt n -> return (mark Nothing path (ss (show n)))
|
||||
LFlt f -> return (mark Nothing path (ss (show f)))
|
||||
lin path xs mb_fid (EFun f) es = map (mark (Just f) path) (apply path xs mb_fid f es)
|
||||
lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
|
||||
lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
|
||||
|
||||
ss s = listArray (0,0) [[LeafKS [s]]]
|
||||
|
||||
apply path xs mb_fid f es =
|
||||
case Map.lookup f lp of
|
||||
Just prods -> case lookupProds mb_fid prods of
|
||||
Just set -> do prod <- Set.toList set
|
||||
case prod of
|
||||
PApply funid fids -> do guard (length fids == length es)
|
||||
args <- sequence (zipWith3 (\i (PArg _ fid) e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
|
||||
let (CncFun _ lins) = cncfuns cnc ! funid
|
||||
return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
|
||||
PCoerce fid -> apply path xs (Just fid) f es
|
||||
Nothing -> mzero
|
||||
where
|
||||
lookupProds (Just fid) prods = IntMap.lookup fid prods
|
||||
lookupProds Nothing prods = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
|
||||
|
||||
sub i path = i:path
|
||||
|
||||
isApp (PApply _ _) = True
|
||||
isApp _ = False
|
||||
|
||||
computeSeq seqid args = concatMap compute (elems seq)
|
||||
where
|
||||
seq = sequences cnc ! seqid
|
||||
|
||||
compute (SymCat d r) = (args !! d) ! r
|
||||
compute (SymLit d r) = (args !! d) ! r
|
||||
compute (SymKS ts) = [LeafKS ts]
|
||||
compute (SymKP ts alts) = [LeafKP ts alts]
|
||||
|
||||
untokn :: [BracketedTokn] -> [String]
|
||||
untokn ts = case ts of
|
||||
LeafKP d _ : [] -> d
|
||||
LeafKP d vs : ws -> let ss@(s:_) = untokn ws in sel d vs s ++ ss
|
||||
LeafKS s : ws -> s ++ untokn ws
|
||||
[] -> []
|
||||
where
|
||||
sel d vs w = case [v | Alt v cs <- vs, any (\c -> isPrefixOf c w) cs] of
|
||||
v:_ -> v
|
||||
_ -> d
|
||||
|
||||
|
||||
-- show bracketed markup with references to tree structure
|
||||
markLinearizes :: PGF -> CId -> Expr -> [String]
|
||||
markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
|
||||
where
|
||||
mark mb_f path lint = amap (bracket mb_f path) lint
|
||||
|
||||
bracket Nothing path ts = [LeafKS ["("++show (reverse path)]] ++ ts ++ [LeafKS [")"]]
|
||||
bracket (Just f) path ts = [LeafKS ["(("++showCId f++","++show (reverse path)++")"]] ++ ts ++ [LeafKS [")"]]
|
||||
|
||||
|
||||
graphvizDependencyTree :: String -> Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String
|
||||
graphvizDependencyTree format debug mlab ms pgf lang tr = case format of
|
||||
"malt" -> unlines (lin2dep format)
|
||||
"malt_input" -> unlines (lin2dep format)
|
||||
_ -> concat $ map (++"\n") $ ["digraph {\n"] ++ lin2dep format ++ ["}"]
|
||||
where
|
||||
|
||||
lin2dep format = -- trace (ifd (show sortedNodes ++ show nodeWords)) $
|
||||
case format of
|
||||
"malt" -> map (concat . intersperse "\t") wnodes
|
||||
"malt_input" -> map (concat . intersperse "\t" . take 6) wnodes
|
||||
_ -> prelude ++ nodes ++ links
|
||||
|
||||
ifd s = if debug then s else []
|
||||
|
||||
pot = readPosText $ concat $ take 1 $ markLinearizes pgf lang tr
|
||||
---- use Just str if you have str to match against
|
||||
|
||||
prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"]
|
||||
|
||||
nodes = map mkNode nodeWords
|
||||
mkNode (i,((_,p),ss)) =
|
||||
node p ++ " [label = \"" ++ show i ++ ". " ++ ifd (show p) ++ unwords ss ++ "\"] ;"
|
||||
nodeWords = (0,((mkCId "",[]),["ROOT"])) : zip [1..] [((f,p),w)|
|
||||
((Just f,p),w) <- wlins pot]
|
||||
|
||||
links = map mkLink thelinks
|
||||
thelinks = [(word y, x, label tr y x) |
|
||||
(_,((f,x),_)) <- tail nodeWords,
|
||||
let y = dominant x]
|
||||
mkLink (x,y,l) = node x ++ " -> " ++ node y ++ " [label = \"" ++ l ++ "\"] ;"
|
||||
node = show . show
|
||||
|
||||
dominant x = case x of
|
||||
[] -> x
|
||||
_ | not (x == hx) -> hx
|
||||
_ -> dominant (init x)
|
||||
where
|
||||
hx = headArg (init x) tr x
|
||||
|
||||
headArg x0 tr x = case (unApp tr,x) of
|
||||
(Just (f,[]),[_]) -> x0 ---- ??
|
||||
(Just (f,ts),[_]) -> x0 ++ [getHead (length ts - 1) f]
|
||||
(Just (f,ts),i:y) -> headArg x0 (ts !! i) y
|
||||
_ -> x0 ----
|
||||
|
||||
label tr y x = case span (uncurry (==)) (zip y x) of
|
||||
(xys,(_,i):_) -> getLabel i (funAt tr (map fst xys))
|
||||
_ -> "" ----
|
||||
|
||||
funAt tr x = case (unApp tr,x) of
|
||||
(Just (f,_) ,[]) -> f
|
||||
(Just (f,ts),i:y) -> funAt (ts !! i) y
|
||||
_ -> mkCId (render (ppExpr 0 [] tr)) ----
|
||||
|
||||
word x = if elem x sortedNodes then x else
|
||||
let x' = headArg x tr (x ++[0]) in
|
||||
if x' == x then [] else word x'
|
||||
|
||||
sortedNodes = [p | (_,((_,p),_)) <- nodeWords]
|
||||
|
||||
labels = maybe Map.empty id mlab
|
||||
getHead i f = case Map.lookup f labels of
|
||||
Just ls -> length $ takeWhile (/= "head") ls
|
||||
_ -> i
|
||||
getLabel i f = case Map.lookup f labels of
|
||||
Just ls | length ls > i -> ifd (showCId f ++ "#" ++ show i ++ "=") ++ ls !! i
|
||||
_ -> showCId f ++ "#" ++ show i
|
||||
|
||||
-- to generate CoNLL format for MaltParser
|
||||
nodeMap :: Map.Map [Int] Int
|
||||
nodeMap = Map.fromList [(p,i) | (i,((_,p),_)) <- nodeWords]
|
||||
|
||||
arcMap :: Map.Map [Int] ([Int],String)
|
||||
arcMap = Map.fromList [(y,(x,l)) | (x,y,l) <- thelinks]
|
||||
|
||||
lookDomLab p = case Map.lookup p arcMap of
|
||||
Just (q,l) -> (maybe 0 id (Map.lookup q nodeMap), if null l then rootlabel else l)
|
||||
_ -> (0,rootlabel)
|
||||
|
||||
wnodes = [[show i, maltws ws, showCId fun, pos, pos, morph, show dom, lab, unspec, unspec] |
|
||||
(i, ((fun,p),ws)) <- tail nodeWords,
|
||||
let pos = showCId $ lookValCat (abstract pgf) fun,
|
||||
let morph = unspec,
|
||||
let (dom,lab) = lookDomLab p
|
||||
]
|
||||
maltws = concat . intersperse "+" . words . unwords -- no spaces in column 2
|
||||
unspec = "_"
|
||||
rootlabel = "ROOT"
|
||||
|
||||
wlins :: PosText -> [((Maybe CId,[Int]),[String])]
|
||||
wlins pt = case pt of
|
||||
T p pts -> concatMap (lins p) pts
|
||||
M ws -> if null ws then [] else [((Nothing,[]),ws)]
|
||||
where
|
||||
lins p pt = case pt of
|
||||
T q pts -> concatMap (lins q) pts
|
||||
M ws -> if null ws then [] else [(p,ws)]
|
||||
|
||||
data PosText =
|
||||
T (Maybe CId,[Int]) [PosText]
|
||||
| M [String]
|
||||
deriving Show
|
||||
|
||||
readPosText :: String -> PosText
|
||||
readPosText = fst . head . (RP.readP_to_S pPosText) where
|
||||
pPosText = do
|
||||
RP.char '(' >> RP.skipSpaces
|
||||
p <- pPos
|
||||
RP.skipSpaces
|
||||
ts <- RP.many pPosText
|
||||
RP.char ')' >> RP.skipSpaces
|
||||
return (T p ts)
|
||||
RP.<++ do
|
||||
ws <- RP.sepBy1 (RP.munch1 (flip notElem "()")) (RP.char ' ')
|
||||
return (M ws)
|
||||
pPos = do
|
||||
fun <- (RP.char '(' >> pCId >>= \f -> RP.char ',' >> (return $ Just f))
|
||||
RP.<++ (return Nothing)
|
||||
RP.char '[' >> RP.skipSpaces
|
||||
is <- RP.sepBy (RP.munch1 isDigit) (RP.char ',')
|
||||
RP.char ']' >> RP.skipSpaces
|
||||
RP.char ')' RP.<++ return ' '
|
||||
return (fun,map read is)
|
||||
|
||||
Reference in New Issue
Block a user