diff --git a/GenI.cabal b/GenI.cabal --- a/GenI.cabal +++ b/GenI.cabal @@ -1,5 +1,5 @@ Name: GenI -Version: 0.20 +Version: 0.20.1 License: GPL License-file: LICENSE Author: Carlos Areces and Eric Kow @@ -53,7 +53,7 @@ src/NLP/GenI/Test.hs src/NLP/GenI/Simple/SimpleGui.lhs, src/NLP/GenI/Gui.lhs - src/NLP/GenI/GraphvizShow.lhs, + src/NLP/GenI/GraphvizShow.hs, src/NLP/GenI/GuiHelper.hs src/NLP/GenI/Console.hs, src/NLP/GenI/Graphviz.hs diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -6,7 +6,6 @@ * Input files now *assumed* to be UTF-8 encoded (output still ISO8859-1; hopefully locale-based in GHC 6.12) * Interface between GenI and morphological realiser now uses a JSON format. - * --macros renamed to --schemata (still -m) * Rootfeat optimisation now mandatory (flag no longer recognised) - NEW FUNCTIONALITY @@ -19,6 +18,7 @@ * --batchdir now works with instructions files * --metrics always expands 'default' to the default metrics (in addition to any other statistics you request) + * new optimisation: early null-adjunction detection - QUALITY ASSURANCE diff --git a/src/NLP/GenI/GeniParsers.lhs b/src/NLP/GenI/GeniParsers.lhs --- a/src/NLP/GenI/GeniParsers.lhs +++ b/src/NLP/GenI/GeniParsers.lhs @@ -190,8 +190,9 @@ formally, \begin{SaveVerbatim}{KoweyTmp} - ::= "[" * "]" - ::= ":" + ::= "[" * "]" + ::= ":" + ::= | \end{SaveVerbatim} \begin{center} \fbox{\BUseVerbatim{KoweyTmp}} @@ -203,7 +204,7 @@ geniAttVal :: Parser AvPair geniAttVal = do - att <- identifier "an attribute"; colon + att <- identifierR "an attribute"; colon val <- geniValue "a GenI value" return $ AvPair att val \end{code} @@ -892,6 +893,15 @@ -- ---------------------------------------------------------------------- -- parsec helpers -- ---------------------------------------------------------------------- + +-- | identifier, permitting reserved words too +identifierR :: CharParser () String +identifierR + = do { c <- P.identStart geniLanguageDef + ; cs <- many (P.identLetter geniLanguageDef) + ; return (c:cs) + } + "identifier or reserved word" tillEof :: Parser a -> Parser a tillEof p = diff --git a/src/NLP/GenI/GeniShow.hs b/src/NLP/GenI/GeniShow.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GeniShow.hs @@ -0,0 +1,171 @@ +-- GenI surface realiser +-- Copyright (C) 2005 Carlos Areces and Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{- +We need to be able to dump some of GenI's data structures into a simple +text format we call GeniHand. + +There are at least two uses for this, one is that it allows us to +interrupt the debugging process, dump everything to file, muck around +with the trees and then pick up where we left off. + +The other use is to make large grammars faster to load. We don't actually do +this anymore, mind you, but it's nice to have the option. The idea is to take +a massive XML grammar, parse it to a set of TagElems and then write these back +in the lighter syntax. It's not that XML is inherently less efficient to parse +than the handwritten syntax, just that writing an efficient parser for XML +based format is more annoying, so I stuck with HaXml to make my life easy. +Unfortunately, HaXml seems to have some kind of space leak. +-} + +-- This module provides specialised functions for visualising tree data. +module NLP.GenI.GeniShow +where + +import Data.Tree +import Data.List(intersperse, isPrefixOf) +import qualified Data.Map as Map + +import NLP.GenI.Tags + ( TagElem, idname, + tsemantics, ttree, tinterface, ttype, ttreename, + ) +import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), Ptype(..), + Ttree(params, pidname, pfamily, pinterface, ptype, tree, psemantics, ptrace), + GNode(..), GType(..), + SemInput, Pred, + TestCase(..), + ) + +class GeniShow a where + geniShow :: a -> String + +instance GeniShow Ptype where + geniShow Initial = "initial" + geniShow Auxiliar = "auxiliary" + geniShow _ = "" + +instance GeniShow AvPair where + geniShow (AvPair a v) = a ++ ":" ++ geniShow v + +instance GeniShow GeniVal where + geniShow (GConst xs) = concat $ intersperse "|" xs + geniShow x = show x + +instance GeniShow Pred where + geniShow (h, p, l) = + showh ++ geniShow p ++ "(" ++ unwords (map geniShow l) ++ ")" + where + hideh (GConst [x]) = "genihandle" `isPrefixOf` x + hideh _ = False + showh = if hideh h then "" else geniShow h ++ ":" + +instance GeniShow GNode where + geniShow x = + let gaconstrstr = case (gaconstr x, gtype x) of + (True, Other) -> "aconstr:noadj" + _ -> "" + gtypestr n = case (gtype n) of + Subs -> "type:subst" + Foot -> "type:foot" + Lex -> if ganchor n && (null.glexeme) n + then "type:anchor" else "type:lex" + _ -> "" + glexstr n = + if null ls then "" + else concat $ intersperse "|" $ map quote ls + where quote s = "\"" ++ s ++ "\"" + ls = glexeme n + tbFeats n = (geniShow $ gup n) ++ "!" ++ (geniShow $ gdown n) + in unwords $ filter (not.null) $ [ gnname x, gaconstrstr, gtypestr x, glexstr x, tbFeats x ] + +instance (GeniShow a) => GeniShow [a] where + geniShow = squares . unwords . (map geniShow) + +instance (GeniShow a) => GeniShow (Tree a) where + geniShow t = + let treestr i (Node a l) = + spaces i ++ geniShow a ++ + case (l,i) of + ([], 0) -> "{}" + ([], _) -> "" + (_, _) -> "{\n" ++ (unlines $ map next l) ++ spaces i ++ "}" + where next = treestr (i+1) + -- + spaces i = take i $ repeat ' ' + in treestr 0 t + +instance GeniShow TagElem where + geniShow te = + "\n% ------------------------- " ++ idname te + ++ "\n" ++ (ttreename te) ++ ":" ++ (idname te) + ++ " " ++ (geniShow.tinterface $ te) + ++ " " ++ (geniShow.ttype $ te) + ++ "\n" ++ (geniShow.ttree $ te) + ++ "\n" ++ geniShowKeyword "semantics" "" ++ (geniShow.tsemantics $ te) + +instance (GeniShow a) => GeniShow (Ttree a) where + geniShow tt = + "\n% ------------------------- " ++ pidname tt + ++ "\n" ++ (pfamily tt) ++ ":" ++ (pidname tt) + ++ " " ++ (parens $ (unwords $ map geniShow $ params tt) + ++ " ! " + ++ (unwords $ map geniShow $ pinterface tt)) + ++ " " ++ (geniShow.ptype $ tt) + ++ "\n" ++ (geniShow.tree $ tt) + ++ (case psemantics tt of + Nothing -> "" + Just psem -> "\n" ++ geniShowKeyword "semantics" (geniShow psem)) + ++ "\n" ++ geniShowKeyword "trace" (squares.unwords.ptrace $ tt) + +instance GeniShow TestCase where + geniShow (TestCase { tcName = name + , tcExpected = sentences + , tcOutputs = outputs + , tcSemString = semStr + , tcSem = sem }) = + unlines $ [ name, semS ] + ++ map (geniShowKeyword "sentence" . squares) sentences + ++ (concat.prettify.map outStuff $ outputs) + where + semS = if null semStr then geniShowSemInput sem "" else semStr + prettify = if all (Map.null . snd) outputs then id else map ("":) + gshowTrace ((k1,k2),ts) = + geniShowKeyword "trace" . squares . showString (k1 ++ " " ++ k2 ++ " ! " ++ unwords ts) $ "" + outStuff (o,ds) = + [ geniShowKeyword "output" . squares $ o ] + ++ (map gshowTrace $ Map.toList ds) + + +parens, squares :: String -> String +parens s = "(" ++ s ++ ")" +squares s = "[" ++ s ++ "]" + +geniShowKeyword :: String -> ShowS +geniShowKeyword k = showString k . showChar ':' + +geniShowSemInput :: SemInput -> ShowS +geniShowSemInput (sem,icons,lcons) = + let withConstraints lit = + case concat [ cs | (p,cs) <- lcons, p == lit ] of + [] -> geniShow lit + cs -> geniShow lit ++ (squares . unwords $ cs) + semStuff = geniShowKeyword "semantics" . squares + . (showString . unwords . map withConstraints $ sem) + idxStuff = geniShowKeyword "idxconstraints" + . (showString . geniShow $ icons) . squares + in semStuff . (if null icons then id else showChar '\n' . idxStuff) diff --git a/src/NLP/GenI/GeniShow.lhs b/src/NLP/GenI/GeniShow.lhs deleted file mode 100644 --- a/src/NLP/GenI/GeniShow.lhs +++ /dev/null @@ -1,185 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -The GeniShow module provides specialised functions for visualising tree data. - -% ---------------------------------------------------------------------- -\section{GeniShow} -% ---------------------------------------------------------------------- - -We need to be able to dump some of GenI's data structures into a simple -text format we call GeniHand. - -There are at leaste two uses for this, one is that it allows us to -interrupt the debugging process, dump everything to file, muck around -with the trees and then pick up where we left off. - -The other use is to make large grammars faster to load. We don't actually do -this anymore, mind you, but it's nice to have the option. The idea is to take -a massive XML grammar, parse it to a set of TagElems and then write these back -in the lighter syntax. It's not that XML is inherently less efficient to parse -than the handwritten syntax, just that writing an efficient parser for XML -based format is more annoying, so I stuck with HaXml to make my life easy. -Unfortunately, HaXml seems to have some kind of space leak. - -\begin{code} -module NLP.GenI.GeniShow -where -\end{code} - -\ignore{ -\begin{code} -import Data.Tree -import Data.List(intersperse, isPrefixOf) -import qualified Data.Map as Map - -import NLP.GenI.Tags - ( TagElem, idname, - tsemantics, ttree, tinterface, ttype, ttreename, - ) -import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), Ptype(..), - Ttree(params, pidname, pfamily, pinterface, ptype, tree, psemantics, ptrace), - GNode(..), GType(..), - SemInput, Pred, - TestCase(..), - ) -\end{code} -} - -\begin{code} -class GeniShow a where - geniShow :: a -> String - -instance GeniShow Ptype where - geniShow Initial = "initial" - geniShow Auxiliar = "auxiliary" - geniShow _ = "" - -instance GeniShow AvPair where - geniShow (AvPair a v) = a ++ ":" ++ geniShow v - -instance GeniShow GeniVal where - geniShow (GConst xs) = concat $ intersperse "|" xs - geniShow x = show x - -instance GeniShow Pred where - geniShow (h, p, l) = - showh ++ geniShow p ++ "(" ++ unwords (map geniShow l) ++ ")" - where - hideh (GConst [x]) = "genihandle" `isPrefixOf` x - hideh _ = False - showh = if hideh h then "" else geniShow h ++ ":" - -instance GeniShow GNode where - geniShow x = - let gaconstrstr = case (gaconstr x, gtype x) of - (True, Other) -> "aconstr:noadj" - _ -> "" - gtypestr n = case (gtype n) of - Subs -> "type:subst" - Foot -> "type:foot" - Lex -> if ganchor n && (null.glexeme) n - then "type:anchor" else "type:lex" - _ -> "" - glexstr n = - if null ls then "" - else concat $ intersperse "|" $ map quote ls - where quote s = "\"" ++ s ++ "\"" - ls = glexeme n - tbFeats n = (geniShow $ gup n) ++ "!" ++ (geniShow $ gdown n) - in unwords $ filter (not.null) $ [ gnname x, gaconstrstr, gtypestr x, glexstr x, tbFeats x ] - -instance (GeniShow a) => GeniShow [a] where - geniShow = squares . unwords . (map geniShow) - -instance (GeniShow a) => GeniShow (Tree a) where - geniShow t = - let treestr i (Node a l) = - spaces i ++ geniShow a ++ - case (l,i) of - ([], 0) -> "{}" - ([], _) -> "" - (_, _) -> "{\n" ++ (unlines $ map next l) ++ spaces i ++ "}" - where next = treestr (i+1) - -- - spaces i = take i $ repeat ' ' - in treestr 0 t - -instance GeniShow TagElem where - geniShow te = - "\n% ------------------------- " ++ idname te - ++ "\n" ++ (ttreename te) ++ ":" ++ (idname te) - ++ " " ++ (geniShow.tinterface $ te) - ++ " " ++ (geniShow.ttype $ te) - ++ "\n" ++ (geniShow.ttree $ te) - ++ "\n" ++ geniShowKeyword "semantics" "" ++ (geniShow.tsemantics $ te) - -instance (GeniShow a) => GeniShow (Ttree a) where - geniShow tt = - "\n% ------------------------- " ++ pidname tt - ++ "\n" ++ (pfamily tt) ++ ":" ++ (pidname tt) - ++ " " ++ (parens $ (unwords $ map geniShow $ params tt) - ++ " ! " - ++ (unwords $ map geniShow $ pinterface tt)) - ++ " " ++ (geniShow.ptype $ tt) - ++ "\n" ++ (geniShow.tree $ tt) - ++ (case psemantics tt of - Nothing -> "" - Just psem -> "\n" ++ geniShowKeyword "semantics" (geniShow psem)) - ++ "\n" ++ geniShowKeyword "trace" (squares.unwords.ptrace $ tt) - -instance GeniShow TestCase where - geniShow (TestCase { tcName = name - , tcExpected = sentences - , tcOutputs = outputs - , tcSemString = semStr - , tcSem = sem }) = - unlines $ [ name, semS ] - ++ map (geniShowKeyword "sentence" . squares) sentences - ++ (concat.prettify.map outStuff $ outputs) - where - semS = if null semStr then geniShowSemInput sem "" else semStr - prettify = if all (Map.null . snd) outputs then id else map ("":) - gshowTrace ((k1,k2),ts) = - geniShowKeyword "trace" . squares . showString (k1 ++ " " ++ k2 ++ " ! " ++ unwords ts) $ "" - outStuff (o,ds) = - [ geniShowKeyword "output" . squares $ o ] - ++ (map gshowTrace $ Map.toList ds) - - -parens, squares :: String -> String -parens s = "(" ++ s ++ ")" -squares s = "[" ++ s ++ "]" - -geniShowKeyword :: String -> ShowS -geniShowKeyword k = showString k . showChar ':' - -geniShowSemInput :: SemInput -> ShowS -geniShowSemInput (sem,icons,lcons) = - let withConstraints lit = - case concat [ cs | (p,cs) <- lcons, p == lit ] of - [] -> geniShow lit - cs -> geniShow lit ++ (squares . unwords $ cs) - semStuff = geniShowKeyword "semantics" . squares - . (showString . unwords . map withConstraints $ sem) - idxStuff = geniShowKeyword "idxconstraints" - . (showString . geniShow $ icons) . squares - in semStuff . (if null icons then id else showChar '\n' . idxStuff) -\end{code} - -\include{src/NLP/GenI/GraphvizShow.lhs} -\include{src/NLP/GenI/HsShow.lhs} diff --git a/src/NLP/GenI/Graphviz.hs b/src/NLP/GenI/Graphviz.hs --- a/src/NLP/GenI/Graphviz.hs +++ b/src/NLP/GenI/Graphviz.hs @@ -34,7 +34,9 @@ import Control.Monad(when) import Data.List(intersperse) import Data.Tree -import System.IO(hPutStrLn, hClose) +import System.IO ( hClose ) +import System.IO.UTF8 +import Prelude hiding ( writeFile ) import System.Exit(ExitCode) import NLP.GenI.SysGeni(waitForProcess, runInteractiveProcess) @@ -200,7 +202,7 @@ let dotArgs' = ["-Gfontname=courier", "-Nfontname=courier", "-Efontname=courier", - "-Gcharset=latin1", -- FIXME: should really output UTF-8 instead + "-Gcharset=utf-8", "-Tpng", "-o" ++ outputFile ] dotArgs = dotArgs' ++ (if (null dotFile) then [] else [dotFile]) -- putStrLn ("sending to graphviz:\n" ++ dot) diff --git a/src/NLP/GenI/GraphvizShow.hs b/src/NLP/GenI/GraphvizShow.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GraphvizShow.hs @@ -0,0 +1,199 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Outputting core GenI data to graphviz. +module NLP.GenI.GraphvizShow +where + +import Data.List(intersperse,nub) +import Data.List.Split (wordsBy) +import Data.Maybe(listToMaybe) + +import NLP.GenI.Tags + ( TagElem, TagDerivation, idname, + tsemantics, ttree, + DerivationStep(..), + ) +import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), + GNode(..), GType(..), Flist, + isConst, + showSem, + ) +import NLP.GenI.Graphviz + ( gvUnlines, gvNewline + , GraphvizShow(graphvizShowAsSubgraph, graphvizLabel, graphvizParams) + , GraphvizShowNode(graphvizShowNode) + , GraphvizShowString(graphvizShow) + , gvNode, gvEdge, gvShowTree + ) + +-- ---------------------------------------------------------------------- +-- For GraphViz +-- ---------------------------------------------------------------------- + +type GvHighlighter a = a -> (a, Maybe String) + +nullHighlighter :: GvHighlighter GNode +nullHighlighter a = (a,Nothing) + +instance GraphvizShow Bool TagElem where + graphvizShowAsSubgraph sf = graphvizShowAsSubgraph (sf, nullHighlighter) + graphvizLabel sf = graphvizLabel (sf, nullHighlighter ) + graphvizParams sf = graphvizParams (sf, nullHighlighter) + + +instance GraphvizShow (Bool, GvHighlighter GNode) TagElem where + graphvizShowAsSubgraph (sf,hfn) prefix te = + (gvShowTree (\_->[]) sf (prefix ++ "DerivedTree0") $ + fmap hfn $ ttree te) + + graphvizLabel _ te = + -- we display the tree semantics as the graph label + let treename = "name: " ++ (idname te) + semlist = "semantics: " ++ (showSem $ tsemantics te) + in gvUnlines [ treename, semlist ] + + graphvizParams _ _ = + [ "fontsize = 10", "ranksep = 0.3" + , "node [fontsize=10]" + , "edge [fontsize=10 arrowhead=none]" ] + +-- ---------------------------------------------------------------------- +-- Helper functions for the TagElem GraphvizShow instance +-- ---------------------------------------------------------------------- + +instance GraphvizShowNode (Bool) (GNode, Maybe String) where + -- compact -> (node, mcolour) -> String + graphvizShowNode detailed prefix (gn, mcolour) = + let -- attributes + filledParam = ("style", "filled") + fillcolorParam = ("fillcolor", "lemonchiffon") + shapeRecordParam = ("shape", "record") + shapePlaintextParam = ("shape", "plaintext") + -- + colorParams = case mcolour of + Nothing -> [] + Just c -> [ ("fontcolor", c) ] + shapeParams = if detailed + then [ shapeRecordParam, filledParam, fillcolorParam ] + else [ shapePlaintextParam ] + -- content + stub = showGnStub gn + extra = showGnDecorations gn + summary = if null extra then stub + else "{" ++ stub ++ "|" ++ extra ++ "}" + -- + body = if not detailed then graphvizShow_ gn + else "{" ++ summary + ++ (barAnd.showFs $ gup gn) + ++ (maybeShow (barAnd.showFs) $ gdown gn) + ++ "}" + where barAnd x = "|" ++ x + showFs = gvUnlines . (map graphvizShow_) + in gvNode prefix body (shapeParams ++ colorParams) + +instance GraphvizShowString () GNode where + graphvizShow () gn = + let stub = showGnStub gn + extra = showGnDecorations gn + in stub ++ extra + +instance GraphvizShowString () AvPair where + graphvizShow () (AvPair a v) = a ++ ":" ++ graphvizShow_ v + +instance GraphvizShowString () GeniVal where + graphvizShow () (GConst x) = concat $ intersperse " ! " x + graphvizShow () x = show x + +showGnDecorations :: GNode -> String +showGnDecorations gn = + case gtype gn of + Subs -> "↓" + Foot -> "*" + _ -> if gaconstr gn then "ᴺᴬ" else "" + +showGnStub :: GNode -> String +showGnStub gn = + let cat = case getGnVal gup "cat" gn of + Nothing -> "" + Just v -> graphvizShow_ v + -- + getIdx f = + case getGnVal f "idx" gn of + Nothing -> "" + Just v -> if isConst v then graphvizShow_ v else "" + idxT = getIdx gup + idxB = getIdx gdown + idx = idxT ++ (maybeShow_ "." idxB) + -- + lexeme = concat $ intersperse "!" $ glexeme gn + in concat $ intersperse ":" $ filter (not.null) [ cat, idx, lexeme ] + +getGnVal :: (GNode -> Flist) -> String -> GNode -> Maybe GeniVal +getGnVal getFeat attr gn = + listToMaybe [ v | AvPair a v <- getFeat gn, a == attr ] + +-- | Apply fn to s if s is not null +maybeShow :: ([a] -> String) -> [a] -> String +maybeShow fn s = if null s then "" else fn s +-- | Prefix a string if it is not null +maybeShow_ :: String -> String -> String +maybeShow_ prefix s = maybeShow (prefix++) s + +graphvizShow_ :: (GraphvizShowString () a) => a -> String +graphvizShow_ = graphvizShow () + +-- ---------------------------------------------------------------------- +-- Derivation tree +-- ---------------------------------------------------------------------- + +graphvizShowDerivation :: TagDerivation -> String +graphvizShowDerivation deriv = + if (null histNodes) + then "" + else " node [ shape = plaintext ];\n" + ++ (concatMap showHistNode histNodes) + ++ (concatMap graphvizShowDerivation' deriv) + where showHistNode n = gvNode (gvDerivationLab n) (label n) [] + label n = case wordsBy (== ':') n of + name:fam:tree:_ -> name ++ ":" ++ fam ++ gvNewline ++ tree + _ -> n ++ " (geni/gv ERROR)" + histNodes = reverse $ nub $ concatMap (\ (DerivationStep _ c p _) -> [c,p]) deriv + +graphvizShowDerivation' :: DerivationStep -> String +graphvizShowDerivation' (DerivationStep substadj child parent _) = + gvEdge (gvDerivationLab parent) (gvDerivationLab child) "" p + where p = if substadj == 'a' then [("style","dashed")] else [] + + +gvDerivationLab :: String -> String +gvDerivationLab xs = "Derivation" ++ gvMunge xs + +newlineToSlashN :: Char -> String +newlineToSlashN '\n' = gvNewline +newlineToSlashN x = [x] + +-- | Node names can't have hyphens in them and newlines within the node +-- labels should be represented literally as @\\n@. +gvMunge :: String -> String +gvMunge = map dot2x . filter (/= ':') . filter (/= '-') + +dot2x :: Char -> Char +dot2x '.' = 'x' +dot2x c = c diff --git a/src/NLP/GenI/GraphvizShow.lhs b/src/NLP/GenI/GraphvizShow.lhs deleted file mode 100644 --- a/src/NLP/GenI/GraphvizShow.lhs +++ /dev/null @@ -1,222 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\section{GraphvizShow} - -Outputting core GenI data to graphviz. - -\begin{code} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.GraphvizShow -where -\end{code} - -\ignore{ -\begin{code} -import Data.List(intersperse,nub) -import Data.List.Split (wordsBy) -import Data.Maybe(listToMaybe) - -import NLP.GenI.Tags - ( TagElem, TagDerivation, idname, - tsemantics, ttree, - DerivationStep(..), - ) -import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), - GNode(..), GType(..), Flist, - isConst, - showSem, - ) -import NLP.GenI.Graphviz - ( gvUnlines, gvNewline - , GraphvizShow(graphvizShowAsSubgraph, graphvizLabel, graphvizParams) - , GraphvizShowNode(graphvizShowNode) - , GraphvizShowString(graphvizShow) - , gvNode, gvEdge, gvShowTree - ) - -\end{code} -} - -% ---------------------------------------------------------------------- -\section{For GraphViz} -% ---------------------------------------------------------------------- - -\begin{code} -type GvHighlighter a = a -> (a, Maybe String) - -nullHighlighter :: GvHighlighter GNode -nullHighlighter a = (a,Nothing) - -instance GraphvizShow Bool TagElem where - graphvizShowAsSubgraph sf = graphvizShowAsSubgraph (sf, nullHighlighter) - graphvizLabel sf = graphvizLabel (sf, nullHighlighter ) - graphvizParams sf = graphvizParams (sf, nullHighlighter) - - -instance GraphvizShow (Bool, GvHighlighter GNode) TagElem where - graphvizShowAsSubgraph (sf,hfn) prefix te = - (gvShowTree (\_->[]) sf (prefix ++ "DerivedTree0") $ - fmap hfn $ ttree te) - - graphvizLabel _ te = - -- we display the tree semantics as the graph label - let treename = "name: " ++ (idname te) - semlist = "semantics: " ++ (showSem $ tsemantics te) - in gvUnlines [ treename, semlist ] - - graphvizParams _ _ = - [ "fontsize = 10", "ranksep = 0.3" - , "node [fontsize=10]" - , "edge [fontsize=10 arrowhead=none]" ] -\end{code} - -Helper functions for the TagElem GraphvizShow instance - -\section{GNode - GraphvizShow} - -\begin{code} -instance GraphvizShowNode (Bool) (GNode, Maybe String) where - -- compact -> (node, mcolour) -> String - graphvizShowNode detailed prefix (gn, mcolour) = - let -- attributes - filledParam = ("style", "filled") - fillcolorParam = ("fillcolor", "lemonchiffon") - shapeRecordParam = ("shape", "record") - shapePlaintextParam = ("shape", "plaintext") - -- - colorParams = case mcolour of - Nothing -> [] - Just c -> [ ("fontcolor", c) ] - shapeParams = if detailed - then [ shapeRecordParam, filledParam, fillcolorParam ] - else [ shapePlaintextParam ] - -- content - stub = showGnStub gn - extra = showGnDecorations gn - summary = if null extra then stub - else "{" ++ stub ++ "|" ++ extra ++ "}" - -- - body = if not detailed then graphvizShow_ gn - else "{" ++ summary - ++ (barAnd.showFs $ gup gn) - ++ (maybeShow (barAnd.showFs) $ gdown gn) - ++ "}" - where barAnd x = "|" ++ x - showFs = gvUnlines . (map graphvizShow_) - in gvNode prefix body (shapeParams ++ colorParams) -\end{code} - -\begin{code} -instance GraphvizShowString () GNode where - graphvizShow () gn = - let stub = showGnStub gn - extra = showGnDecorations gn - in stub ++ maybeShow_ " " extra - -instance GraphvizShowString () AvPair where - graphvizShow () (AvPair a v) = a ++ ":" ++ graphvizShow_ v - -instance GraphvizShowString () GeniVal where - graphvizShow () (GConst x) = concat $ intersperse " ! " x - graphvizShow () x = show x - -showGnDecorations :: GNode -> String -showGnDecorations gn = - case gtype gn of - Subs -> "!" - Foot -> "*" - _ -> if (gaconstr gn) then "#" else "" - -showGnStub :: GNode -> String -showGnStub gn = - let cat = case getGnVal gup "cat" gn of - Nothing -> "" - Just v -> graphvizShow_ v - -- - getIdx f = - case getGnVal f "idx" gn of - Nothing -> "" - Just v -> if isConst v then graphvizShow_ v else "" - idxT = getIdx gup - idxB = getIdx gdown - idx = idxT ++ (maybeShow_ "." idxB) - -- - lexeme = concat $ intersperse "!" $ glexeme gn - in concat $ intersperse ":" $ filter (not.null) [ cat, idx, lexeme ] - -getGnVal :: (GNode -> Flist) -> String -> GNode -> Maybe GeniVal -getGnVal getFeat attr gn = - listToMaybe [ v | AvPair a v <- getFeat gn, a == attr ] - --- | Apply fn to s if s is not null -maybeShow :: ([a] -> String) -> [a] -> String -maybeShow fn s = if null s then "" else fn s --- | Prefix a string if it is not null -maybeShow_ :: String -> String -> String -maybeShow_ prefix s = maybeShow (prefix++) s - -graphvizShow_ :: (GraphvizShowString () a) => a -> String -graphvizShow_ = graphvizShow () -\end{code} - -% ---------------------------------------------------------------------- -\section{Derivation tree} -% ---------------------------------------------------------------------- - -\begin{code} -graphvizShowDerivation :: TagDerivation -> String -graphvizShowDerivation deriv = - if (null histNodes) - then "" - else " node [ shape = plaintext ];\n" - ++ (concatMap showHistNode histNodes) - ++ (concatMap graphvizShowDerivation' deriv) - where showHistNode n = gvNode (gvDerivationLab n) (label n) [] - label n = case wordsBy (== ':') n of - name:fam:tree:_ -> name ++ ":" ++ fam ++ gvNewline ++ tree - _ -> n ++ " (geni/gv ERROR)" - histNodes = reverse $ nub $ concatMap (\ (DerivationStep _ c p _) -> [c,p]) deriv -\end{code} - -\begin{code} -graphvizShowDerivation' :: DerivationStep -> String -graphvizShowDerivation' (DerivationStep substadj child parent _) = - gvEdge (gvDerivationLab parent) (gvDerivationLab child) "" p - where p = if substadj == 'a' then [("style","dashed")] else [] -\end{code} - -We have a couple of functions to help massage our data into Graphviz input -format: node names can't have hyphens in them and newlines within the node -labels should be represented literally as \verb$\n$. - -\begin{code} -gvDerivationLab :: String -> String -gvDerivationLab xs = "Derivation" ++ gvMunge xs - -newlineToSlashN :: Char -> String -newlineToSlashN '\n' = gvNewline -newlineToSlashN x = [x] - -gvMunge :: String -> String -gvMunge = map dot2x . filter (/= ':') . filter (/= '-') - -dot2x :: Char -> Char -dot2x '.' = 'x' -dot2x c = c -\end{code} diff --git a/src/NLP/GenI/Gui.lhs b/src/NLP/GenI/Gui.lhs --- a/src/NLP/GenI/Gui.lhs +++ b/src/NLP/GenI/Gui.lhs @@ -625,13 +625,14 @@ , hfloatRight $ widget saveBt ] \end{code} +% -------------------------------------------------------------------- +\section{Debugging} \label{sec:gui:debugger} +% -------------------------------------------------------------------- + Instead of going directly to the results window, you could instead use the interactive debugger which GenI provides. The debugger shows a separate tab -for each phase in surfuce realisation (lexical selection, filtering, building). -The building phase has a parameterisable GUI, which means that if you wanted to -develop a new surface realisation algorithm for GenI, you could also extend the -debugger GUI to go with it. +for each phase in surface realisation (lexical selection, filtering, building). \begin{center} \includegraphics[width=0.47\textwidth]{hcar/GenI-debugger-screenshot.jpg} @@ -686,7 +687,50 @@ -- display all tabs if we are not told to pause on lex selection when (not pauseOnLex) (step2 cand) \end{code} - + +\subsection{Stepping through the debugger} + +The interactive debugger can have a diffrent GUI for each realisation algorithm. +Here we will discuss the interface for the Simple 2-Phase algorithm which \geni +uses by default. The interfaces for other algorithms are likely to very similar. + +\begin{center} +\includegraphics[width=0.47\textwidth]{images/debugger-features.png} +\end{center} + +The debugger allows you to step through chart generation. Using the 'Step by' +button, you can walk through an arbitrary number of steps, where each step +consists in pulling one item of the agenda, combining it with the chart and +putting some of the results back on to the agenda (or the trash, or results +pile as the case may be). New chart items produced on each step typically have +one of their nodes highlighted in red. This indicates that the node was the +site of the most recent ``event''. For example in the substitution phase, the +red node indicates where the substitution operation was performed; whereas in +the adjunction phase, it could either indicate where adjunction was performed +or where a null-adjunction constraint was applied. + +If you select the ``show features'' checkbox, all nodes in the chart item will +be expanded to reveal the underlying feature structures. The components of this +expanded representation are segmented into the following boxes: + +\vspace{1em} +\begin{tabular}{ll} +\begin{minipage}{0.10\textwidth} +\includegraphics[width=\textwidth]{images/debugger-features-focus.png} +\end{minipage} & +\begin{minipage}{0.70\textwidth} +\begin{enumerate} +\item Summary: here, \verb!n:j.m! indicates that the category is \verb!n!, + that the top \verb!idx! feature is associated with \verb'j' and the + bottom one with \verb!m!. +\item Decorations: here, $\downarrow$ indicates that this is a TAG substitution + node, following the usual conventions in the literature. +\item The top feature structure +\item The bottom feature structure +\end{enumerate} +\end{minipage} \\ +\end{tabular} + % -------------------------------------------------------------------- \section{Tree browser} \label{sec:treebrowser_gui}