graphvizWordAlignment in the C runtime

src/compiler/GF/Command/Commands2.hs

@@ -59,7 +59,6 @@ instance Monad m => TypeCheckArg m where
 
 pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
 pgfCommands = Map.fromList [
-{-
   ("aw", emptyCommandInfo {
      longname = "align_words",
      synopsis = "show word alignments between languages graphically",
@@ -71,9 +70,9 @@ pgfCommands = Map.fromList [
        "by the flag. The target format is postscript, unless overridden by the",
        "flag -format."
        ],
-     exec = \env@(pgf, mos) opts es -> do
-         let langs = optLangs pgf opts
-         if isOpt "giza" opts
+     exec = needPGF $ \opts es env -> do
+         let cncs = optConcs env opts
+         {-if isOpt "giza" opts
            then do
              let giz = map (H.gizaAlignment pgf (head $ langs, head $ tail $ langs)) es
              let lsrc = unlines $ map (\(x,_,_) -> x) giz
@@ -81,8 +80,12 @@ pgfCommands = Map.fromList [
              let align = unlines $ map (\(_,_,x) -> x) giz
              let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align
              return $ fromString grph
-           else do
-             let grph = if null es then [] else H.graphvizAlignment pgf langs (head es)
+           else do-}
+         do  let gvOptions=graphvizDefaults{leafFont = valStrOpts "font" "" opts,
+                                            leafColor = valStrOpts "color" "" opts,
+                                            leafEdgeStyle = valStrOpts "edgestyle" "" opts
+                                           }
+                 grph = if null (toExprs es) then [] else graphvizWordAlignment (map snd cncs) gvOptions (cExpr (head (toExprs es)))
              if isFlag "view" opts || isFlag "format" opts
                then do
                  let file s = "_grph." ++ s
@@ -105,10 +108,12 @@ pgfCommands = Map.fromList [
      flags = [
        ("format","format of the visualization file (default \"png\")"),
        ("lang",  "alignments for this list of languages (default: all)"),
-       ("view",  "program to open the resulting file")
+       ("view",  "program to open the resulting file"),
+       ("font",  "font for the words"),
+       ("color", "color for the words"),
+       ("edgestyle", "the style for links between words")
        ]
     }),
--}
 {-
   ("eb", emptyCommandInfo {
      longname = "example_based",

src/runtime/c/pgf/graphviz.c

@@ -311,8 +311,10 @@ pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, PgfGraphvizOptions* opts,
 	
 	GuEnum* cts = 
 		pgf_lzr_concretize(concr, expr, err, tmp_pool);
-	if (!gu_ok(err))
+	if (!gu_ok(err)) {
+		gu_pool_free(tmp_pool);
 		return;
+	}
 
 	PgfCncTree ctree = gu_next(cts, PgfCncTree, tmp_pool);
 	if (gu_variant_is_null(ctree)) {
@@ -346,3 +348,68 @@ pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, PgfGraphvizOptions* opts,
 
 	gu_pool_free(tmp_pool);
 }
+
+
+PGF_API_DECL void
+pgf_graphviz_word_alignment(PgfConcr** concrs, size_t n_concrs, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err)
+{
+	GuPool* tmp_pool = gu_local_pool();
+	
+	gu_puts("digraph {\n", out, err);
+	gu_puts("rankdir=LR ;\n", out, err);
+	gu_puts("node [shape = record", out, err);
+	if (opts->leafFont != NULL && *opts->leafFont)
+		gu_printf(out, err, ", fontname = \"%s\"", opts->leafFont);
+	if (opts->leafColor != NULL && *opts->leafColor)
+		gu_printf(out, err, ", fontcolor = \"%s\"", opts->leafColor);
+	gu_puts("] ;\n\n", out, err);
+	if (opts->leafEdgeStyle != NULL && *opts->leafEdgeStyle)
+		gu_printf(out, err, "edge [style = %s];\n", opts->leafEdgeStyle);
+	gu_puts("\n", out, err);
+
+	GuSeq* alignment = NULL;
+	GuSeq* last_alignment = NULL;
+	for (size_t i = 0; i < n_concrs; i++) {
+		alignment = pgf_align_words(concrs[i], expr, err, tmp_pool);
+		gu_printf(out, err, "  struct%d[label=\"", i);
+
+		size_t n_tokens = gu_seq_length(alignment);
+		for (size_t j = 0; j < n_tokens; j++) {
+			PgfAlignmentPhrase* phrase = gu_seq_get(alignment, PgfAlignmentPhrase*, j);
+			if (j > 0)
+				gu_puts(" | ", out, err);
+			gu_printf(out, err, "<n%d> %s", j, phrase->phrase);
+		}
+
+		gu_puts("\"] ;\n", out, err);
+
+		if (last_alignment != NULL) {
+			size_t n_last_tokens = gu_seq_length(last_alignment);
+
+			for (size_t j = 0; j < n_tokens; j++) {
+				PgfAlignmentPhrase* phrase = gu_seq_get(alignment, PgfAlignmentPhrase*, j);
+
+				for (size_t k = 0; k < phrase->n_fids; k++) {
+					int fid = phrase->fids[k];
+
+					for (size_t l = 0; l < n_last_tokens; l++) {
+						PgfAlignmentPhrase* last_phrase = gu_seq_get(last_alignment, PgfAlignmentPhrase*, l);
+						
+						for (size_t r = 0; r < last_phrase->n_fids; r++) {
+							int last_fid = last_phrase->fids[r];
+							if (fid == last_fid) {
+								gu_printf(out, err, "struct%d:n%d:e -> struct%d:n%d:w ;\n",i,j,i-1,l);
+							}
+						}
+					}
+				}
+			}
+		}
+
+		last_alignment = alignment;
+	}
+
+	gu_puts("}", out, err);
+
+	gu_pool_free(tmp_pool);
+}

src/runtime/c/pgf/graphviz.h

@@ -22,4 +22,7 @@ pgf_graphviz_abstract_tree(PgfPGF* pgf, PgfExpr expr, PgfGraphvizOptions* opts,
 PGF_API_DECL void
 pgf_graphviz_parse_tree(PgfConcr* concr, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err);
 
+PGF_API_DECL void
+pgf_graphviz_word_alignment(PgfConcr** concrs, size_t n_concrs, PgfExpr expr, PgfGraphvizOptions* opts, GuOut* out, GuExn* err);
+
 #endif

src/runtime/haskell-bind/PGF2.hsc

@@ -67,7 +67,7 @@ module PGF2 (-- * PGF
              MorphoAnalysis, lookupMorpho, fullFormLexicon,
              -- ** Visualizations
              GraphvizOptions(..), graphvizDefaults,
-             graphvizAbstractTree, graphvizParseTree,
+             graphvizAbstractTree, graphvizParseTree, graphvizWordAlignment,
 
              -- * Exceptions
              PGFError(..),
@@ -357,6 +357,19 @@ graphvizParseTree c opts e =
          s <- gu_string_buf_freeze sb tmpPl
          peekUtf8CString s
 
+graphvizWordAlignment :: [Concr] -> GraphvizOptions -> Expr -> String
+graphvizWordAlignment cs opts e =
+  unsafePerformIO $
+    withGuPool $ \tmpPl ->
+    withArrayLen (map concr cs) $ \n_concrs ptr ->
+      do (sb,out) <- newOut tmpPl
+         exn <- gu_new_exn tmpPl
+         c_opts <- newGraphvizOptions tmpPl opts
+         pgf_graphviz_word_alignment ptr (fromIntegral n_concrs) (expr e) c_opts out exn
+         touchExpr e
+         s <- gu_string_buf_freeze sb tmpPl
+         peekUtf8CString s
+
 newGraphvizOptions :: Ptr GuPool -> GraphvizOptions -> IO (Ptr PgfGraphvizOptions)
 newGraphvizOptions pool opts = do
   c_opts <- gu_malloc pool (#size PgfGraphvizOptions)

src/runtime/haskell-bind/PGF2/FFI.hs

@@ -369,3 +369,6 @@ foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
 
 foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
   pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
+
+foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
+  pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CInt -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()