dependency labels in parse trees now with the -deps flag, -file=labels_file for configuration. With -nocat option this shows reasonable dep trees, more familiar looking than the vd command. With -showfun flag, the tree gives a rather complete picture of the analysis of the sentence.

3 files changed, 39 insertions, 12 deletions

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 32612df2c..015ba4931 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -572,7 +572,7 @@ pgfCommands = Map.fromList [
        ("v","show extra information")
        ],
      flags = [
-       ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"),
+       ("file","configuration file for labels, format per line 'fun label*'"),
        ("format","format of the visualization file (default \"png\")"),
        ("output","output format of graph source (default \"dot\")"),
        ("view","program to open the resulting file (default \"open\")"),
@@ -597,7 +597,7 @@ pgfCommands = Map.fromList [
          let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
                                           noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
                                           noCat = isOpt "nocat" opts && not (isOpt "showcat" opts),
-                                          noDep = True, ---- TODO
+                                          noDep = not (isOpt "deps" opts),
                                           nodeFont = valStrOpts "nodefont" "" opts,
                                           leafFont = valStrOpts "leaffont" "" opts,
                                           nodeColor = valStrOpts "nodecolor" "" opts,
@@ -605,9 +605,14 @@ pgfCommands = Map.fromList [
                                           nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts,
                                           leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts
                                          }
+         let depfile = valStrOpts "file" "" opts
+         mlab <- case depfile of
+           "" -> return Nothing
+           _  -> (Just . getDepLabels . lines) `fmap` restricted (readFile depfile)
+
          let grph = if null es 
                       then []
-                      else graphvizParseTree pgf lang gvOptions (head es)
+                      else graphvizParseTreeDep mlab pgf lang gvOptions (head es)
          if isFlag "view" opts || isFlag "format" opts then do
            let file s = "_grph." ++ s
            let view = optViewGraph opts
@@ -619,11 +624,13 @@ pgfCommands = Map.fromList [
           else return $ fromString grph,
      examples = [
        mkEx "p \"John walks\" | vp  -- generate a tree and show parse tree as .dot script",
-       mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac"
+       mkEx "gr | vp -view=open -- generate a tree and display parse tree on a Mac",
+       mkEx "p \"she loves us\" | vp -view=open -deps -file=uddeps.labels -nocat"  -- show a visual variant of a dependency tree"
        ],
      options = [
        ("showcat","show categories in the tree nodes (default)"),
        ("nocat","don't show categories"),
+       ("deps","show dependency labels"),
        ("showfun","show function names in the tree nodes"),
        ("nofun","don't show function names (default)"),
        ("showleaves","show the leaves of the tree (default)"),
@@ -631,6 +638,7 @@ pgfCommands = Map.fromList [
        ],
      flags = [
        ("lang","the language to visualize"),
+       ("file","configuration file for dependency labels with -deps, format per line 'fun label*'"),
        ("format","format of the visualization file (default \"png\")"),
        ("view","program to open the resulting file (default \"open\")"),
        ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"),
diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs
index 07c14324f..9259bacb4 100644
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -122,6 +122,7 @@ module PGF(
            -- ** Visualizations
            graphvizAbstractTree,
            graphvizParseTree,
+           graphvizParseTreeDep,
            graphvizDependencyTree,
            graphvizBracketedString,
            graphvizAlignment,
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index ad043a505..f0b4de1ac 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -14,6 +14,7 @@ module PGF.VisualizeTree
              , graphvizDefaults
              , graphvizAbstractTree
              , graphvizParseTree
+             , graphvizParseTreeDep
              , graphvizDependencyTree
              , graphvizBracketedString
              , graphvizAlignment
@@ -255,20 +256,20 @@ graphvizBracketedString opts mbl tree bss = render graphviz_code
       internal_nodes = [mkLevel internals |
                         internals <- getInternals (map ((,) nil) bss),
                         not (null internals)]
-      leaf_nodes = mkLevel [(parent, id, word) |
-                            (id, (parent, word)) <- zip [100000..] (concatMap (getLeaves nil) bss)]
+      leaf_nodes = mkLevel [(parent, id, mkLeafNode cat word) |
+                            (id, (parent, (cat,word))) <- zip [100000..] (concatMap (getLeaves (mkCId "?") nil) bss)]
 
       getInternals []    = []
       getInternals nodes
           = nub [(parent, fid, mkNode fun cat) |
-                 (parent, Bracket cat fid lind fun _ _) <- nodes]
+                 (parent, Bracket cat fid _ fun _ _) <- nodes]
             : getInternals [(fid, child) |
                             (_, Bracket _ fid _ _ _ children) <- nodes,
                             child <- children]
 
-      getLeaves parent (Leaf word) = [(parent, word)]
-      getLeaves parent (Bracket _ fid i _ _ children)
-          = concatMap (getLeaves fid) children
+      getLeaves cat parent (Leaf word) = [(parent, (cat, word))] -- the lowest cat before the word
+      getLeaves _ parent (Bracket cat fid i _ _ children)
+          = concatMap (getLeaves cat fid) children
 
       mkLevel nodes
           = text "subgraph {rank=same;" $$
@@ -288,10 +289,27 @@ graphvizBracketedString opts mbl tree bss = render graphviz_code
       depLabel node@(parent,id,lbl) 
         | noDep opts = ";"
         | otherwise = case getArg id of
-            Just (fun,arg) -> (mkOption "" "label" (showCId fun ++ "#" ++ show arg))
+            Just (fun,arg) -> mkOption "" "label" (lookLabel fun arg) 
             _ -> ";"
       getArg i = getArgumentPlace i (expr2numtree tree) Nothing
 
+      labels = maybe Map.empty id mbl
+
+      lookLabel fun arg = case Map.lookup fun labels of
+        Just xx | length xx > arg -> case xx !! arg of
+          "head" -> ""
+          l -> l
+        _ -> argLabel fun arg
+      argLabel fun arg = showCId fun ++ "#" ++ show arg
+
+      mkLeafNode cat word
+       | noDep opts = word        --- || not (noCat opts) -- show POS only if intermediate nodes hidden
+       | otherwise = posCat cat ++ "\n" ++ word         -- show POS in dependency tree
+
+      posCat cat = case Map.lookup cat labels of
+        Just [p] -> p
+        _ -> showCId cat
+
 ---- to restore the argument place from bracketed linearization
 data NumTree = NumTree Int CId [NumTree]
 
@@ -314,7 +332,7 @@ expr2numtree = fst . renumber 0 . flatten where
     t:tt -> case renumber i t of
       (t',j) -> case renumbers j tt of (tt',k) -> (t':tt',k)
     _ -> ([],i)
------ end this terrible stuff
+----- end this terrible stuff AR 4/11/2015