labels read from config files for dependency trees, eg lib/src/dep.labels

examples/experiments/Dep.labels

@@ -0,0 +1,7 @@
+  Pred  subj head
+  Extr  subj head
+  Compl obj head
+  Mods  nmod head
+  MMods amod nmod head
+  Prepm nmod head
+  Prepp pmod head

lib/src/dep.labels

@@ -0,0 +1,74 @@
+    PredVP subj head
+    PredSCVP subj head
+    SlashVP  subj head
+    AdvSlash  head adv
+    SlashPrep head prep
+    SlashVS subj embed head
+    AdvS adv head
+    RelS head rmod
+    ComplVV  head compl
+    ComplVS  head embed
+    ComplVQ  head embed
+    ComplVA  head compl
+    Slash2V3 head obj
+    Slash3V3 head indobj
+    SlashV2V head compl
+    SlashV2S head embed
+    SlashV2Q head embed
+    SlashV2A head compl
+    ComplSlash head obj
+    SlashVV  head compl
+    SlashV2VNP head obj compl
+    AdvVP head adv
+    AdVVP adv head
+    DetCN det head
+    PredetNP det head
+    PPartNP head amod
+    AdvNP head adv
+    RelNP head rmod
+    DetQuant    head num
+    DetQuantOrd head num ord
+    AdNum adv head
+    ComplN2 head compl
+    ComplN3 head compl
+    AdjCN  amod head
+    RelCN  head rmod
+    AdvCN  head adv
+    SentCN head embed
+    ApposCN appos head
+    ComparA head compl
+    ComplA2 head compl
+    CAdvAP pmod head compl
+    SentAP head embed
+    AdAP adv head
+    ConjS  head coord
+    ConjRS head coord
+    ConjAP head coord
+    ConjNP head coord
+    ConjAdv head coord
+    BaseS head tail
+    ConsS head tail
+    BaseRS head tail
+    ConsRS head tail
+    BaseAdv head tail
+    ConsAdv head tail
+    BaseNP head tail
+    ConsNP head tail
+    BaseAP head tail
+    ConsAP head tail
+    PrepNP head compl
+    ComparAdvAdj pmod head compl
+    ComparAdvAdjS pmod head embed
+    AdAdv amod head
+    SubjS conj head
+    QuestVP subj head
+    QuestSlash obj head
+    QuestIAdv adv head
+    QuestIComp adv head
+    IdetCN det head
+    AdvIP head adv
+    IdetQuant head num
+    PrepIP head compl
+    RelVP subj head
+    RelSlash obj head
+    FunRP pmod compl head

src/GF/Command/Commands.hs

@@ -579,8 +579,14 @@ allCommands cod env@(pgf, mos) = Map.fromList [
        "flag -format."
        ],
      exec = \opts es -> do
+         let debug = isOpt "v" opts
+         let file = valStrOpts "file" "" opts
+         mlab <- case file of
+           "" -> return Nothing
+           _  -> readFile file >>= return . Just . getDepLabels . lines
          let lang = optLang opts
-         let grph = if null es then [] else dependencyTree Nothing pgf lang (head es)
+         let grph = if null es then [] else 
+                       dependencyTree debug mlab Nothing pgf lang (head es)
          if isFlag "view" opts || isFlag "format" opts then do
            let file s = "_grph." ++ s
            let view = optViewGraph opts ++ " "
@@ -595,8 +601,10 @@ allCommands cod env@(pgf, mos) = Map.fromList [
        "gr | vt -view=\"open\" -- generate a tree and display alignment on a Mac"
        ],
      options = [
+       ("v","show extra information")
        ],
      flags = [
+       ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"),
        ("format","format of the visualization file (default \"png\")"),
        ("view","program to open the resulting file (default \"open\")")
        ] 

src/PGF/VisualizeTree.hs

@@ -15,8 +15,8 @@
 --        instead of rolling its own.
 -----------------------------------------------------------------------------
 
-module PGF.VisualizeTree ( visualizeTrees, parseTree, dependencyTree, alignLinearize
-  ,PosText(..),readPosText
+module PGF.VisualizeTree ( visualizeTrees, parseTree, dependencyTree, getDepLabels,
+  alignLinearize, PosText(..), readPosText
 			) where
 
 import PGF.CId (CId,showCId,pCId,mkCId)
@@ -25,6 +25,7 @@ import PGF.Tree
 import PGF.Linearize
 import PGF.Macros (lookValCat)
 
+import qualified Data.Map as Map
 import Data.List (intersperse,nub,isPrefixOf,sort,sortBy)
 import Data.Char (isDigit)
 import qualified Text.ParserCombinators.ReadP as RP
@@ -59,10 +60,12 @@ prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
 
 -- dependency trees from Linearize.linearizeMark
 
-dependencyTree :: Maybe String -> PGF -> CId -> Expr -> String
-dependencyTree ms pgf lang exp = prGraph True lin2dep where
+dependencyTree :: Bool -> Maybe Labels -> Maybe String -> PGF -> CId -> Expr -> String
+dependencyTree debug mlab ms pgf lang exp = prGraph True lin2dep where
 
-  lin2dep = trace (show sortedNodes) $ trace (show nodeWords) $ prelude ++ nodes ++ links
+  lin2dep = trace (ifd (show sortedNodes ++ show nodeWords)) $ prelude ++ nodes ++ links
+
+  ifd s = if debug then s else []
 
   pot = readPosText $ head $ linearizesMark pgf lang exp
   ---- use Just str if you have str to match against
@@ -71,7 +74,7 @@ dependencyTree ms pgf lang exp = prGraph True lin2dep where
 
   nodes = map mkNode nodeWords
   mkNode (i,((_,p),ss)) = 
-    node p ++ " [label = \"" ++ show i ++ ". " ++ show p ++ unwords 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]
 
@@ -91,26 +94,36 @@ dependencyTree ms pgf lang exp = prGraph True lin2dep where
 
   headArg x0 tr x = case (tr,x) of
     (Fun f [],[_]) -> x0 ---- ??
-    (Fun f ts,[_]) -> x0 ++ [length ts - 1]  ---- TODO: head as other than last arg
+    (Fun f ts,[_]) -> x0 ++ [getHead (length ts - 1) f]
     (Fun f ts,i:y) -> headArg x0 (ts !! i) y
 
-  label tr y x = case (tr,y) of
-    (_,       [])  -> ""
-    (Fun f ts,[_]) -> showCId f ++ "#" ++ show (last (0:x)) ----
-    (Fun f ts,i:y) -> label (ts !! i) y x
+  label tr y x = case span (uncurry (==)) (zip y x) of
+    (xys,(_,i):_) -> getLabel i (funAt tr (map fst xys))
+    _ -> "" ----
+
+  funAt tr x = case (tr,x) of
+    (Fun f _ ,[])  -> f
+    (Fun f ts,i:y) -> funAt (ts !! i) y
 
   word x = if elem x sortedNodes then x else 
            let x' = headArg x tr (x ++[0]) in
            if x' == x then [] else word x'
-  -- head [y | y <- sortedNodes, isPrefixOf y x]
 
   tr = expr2tree exp
+  sortedNodes = [p | (_,((_,p),_)) <- nodeWords]
 
-  sortedNodes = --sortBy (\x y -> compare (shortness x,pos x) (shortness y,pos y)) 
-                  [p | (_,((_,p),_)) <- nodeWords]
-  ---- TODO: sort by other head than last
-  pos x = 100 - last x 
-  shortness x = 100 - length x
+  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
+
+type Labels = Map.Map CId [String]
+
+getDepLabels :: [String] -> Labels
+getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]