diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs index dc4478c74..7fe28ca8d 100644 --- a/src/compiler/GF/Command/Commands2.hs +++ b/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", diff --git a/src/runtime/c/pgf/graphviz.c b/src/runtime/c/pgf/graphviz.c index 1498035eb..f10303bdc 100644 --- a/src/runtime/c/pgf/graphviz.c +++ b/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, " %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); +} diff --git a/src/runtime/c/pgf/graphviz.h b/src/runtime/c/pgf/graphviz.h index d230fdcd8..483e86f1e 100644 --- a/src/runtime/c/pgf/graphviz.h +++ b/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 diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 45320c6cb..4523279dd 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/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) diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hs index e28e555c2..1a5e7f91b 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/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 ()