rudimentary dependency tree by command vd

2 files changed, 71 insertions, 2 deletions

diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index 5fdceee58..8284c5e2c 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -565,6 +565,44 @@ allCommands cod env@(pgf, mos) = Map.fromList [
      options = transliterationPrintNames
      }),
 
+  ("vd", emptyCommandInfo {
+     longname = "visualize_dependency",
+     synopsis = "show word dependency tree graphically",
+     explanation = unlines [
+       "Prints a dependency tree the .dot format (the graphviz format).",
+       "By default, the last argument is the head of every abstract syntax",
+       "function; moreover, the head depends on the head of the function above.",
+       "The graph can be saved in a file by the wf command as usual.",
+       "If the -view flag is defined, the graph is saved in a temporary file",
+       "which is processed by graphviz and displayed by the program indicated",
+       "by the flag. The target format is png, unless overridden by the",
+       "flag -format."
+       ],
+     exec = \opts es -> do
+         let lang = optLang opts
+         let grph = if null es then [] else dependencyTree Nothing pgf lang (head es)
+         if isFlag "view" opts || isFlag "format" opts then do
+           let file s = "_grph." ++ s
+           let view = optViewGraph opts ++ " "
+           let format = optViewFormat opts 
+           writeFile (file "dot") (enc grph)
+           system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++ 
+                    " ; " ++ view ++ file format
+           return void
+          else return $ fromString grph,
+     examples = [
+       "gr | aw              -- generate a tree and show word alignment as graph script",
+       "gr | vt -view=\"open\" -- generate a tree and display alignment on a Mac"
+       ],
+     options = [
+       ],
+     flags = [
+       ("format","format of the visualization file (default \"png\")"),
+       ("view","program to open the resulting file (default \"open\")")
+       ] 
+    }),
+
+
   ("vp", emptyCommandInfo {
      longname = "visualize_parse",
      synopsis = "show parse tree graphically",
diff --git a/src/PGF/VisualizeTree.hs b/src/PGF/VisualizeTree.hs
index 3599afe4d..f363e12ec 100644
--- a/src/PGF/VisualizeTree.hs
+++ b/src/PGF/VisualizeTree.hs
@@ -15,7 +15,7 @@
 --        instead of rolling its own.
 -----------------------------------------------------------------------------
 
-module PGF.VisualizeTree ( visualizeTrees, parseTree, alignLinearize
+module PGF.VisualizeTree ( visualizeTrees, parseTree, dependencyTree, alignLinearize
   ,PosText(..),readPosText
 			) where
 
@@ -25,7 +25,7 @@ import PGF.Tree
 import PGF.Linearize
 import PGF.Macros (lookValCat)
 
-import Data.List (intersperse,nub)
+import Data.List (intersperse,nub,isPrefixOf,sort,sortBy)
 import Data.Char (isDigit)
 import qualified Text.ParserCombinators.ReadP as RP
 
@@ -57,6 +57,37 @@ prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
   graph = if digr then "digraph" else "graph"
 
 
+-- dependency trees from Linearize.linearizeMark
+
+dependencyTree :: Maybe String -> PGF -> CId -> Expr -> String
+dependencyTree ms pgf lang = prGraph True . lin2dep pgf . linMark where
+  linMark = head . linearizesMark pgf lang
+  ---- use Just str if you have str to match against
+
+lin2dep pgf s = trace s $ trace (show sortedNodeWords) $ prelude ++ nodes ++ links where
+
+  prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"]
+
+  nodes = map mkNode nodeWords
+  mkNode (i,(p,ss)) = 
+    show (show i) ++ " [label = \"" ++ show i ++ ". " ++ show p ++ unwords ss ++ "\"] ;"
+
+  links = map mkLink [(x,dominant x) | x <- init sortedNodeWords]
+  dominant x = head [y | y <- sortedNodeWords, y /=x, dominates (pos y) (pos x)]
+  dominates y x = y /= x && isPrefixOf y x
+  sortedNodeWords = reverse $ sortBy (\x y -> compare (length (pos x)) (length (pos y))) $ 
+                              sortBy (\x y -> compare (pos x) (pos y)) nodeWords
+  pos = fst . snd
+
+  linkss = map mkLink [(x,y) | x <- nodeWords, y <- nodeWords, x /= y, depends x y]
+  mkLink (x,y) = show (fst x) ++ " -> " ++ show (fst y) ;
+  depends (_,(p,_)) (_,(q,_)) = sister p q || daughter p q
+  daughter p q = not (null p) && init p == q && (null q || last q == 0)
+  sister p q = False -- not (null p) && not (null q) && init p == init q && last q == 0
+
+  nodeWords = (0,([],["ROOT"])) : zip [1..] [(p++[0],f)| (p,f) <- wlins (readPosText s)]
+
+
 -- parse trees from Linearize.linearizeMark
 ---- nubrec and domins are quadratic, but could be (n log n)