diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,2 @@ +Carlos Areces +Eric Kow diff --git a/EnableGUI.hs b/EnableGUI.hs deleted file mode 100644 --- a/EnableGUI.hs +++ /dev/null @@ -1,38 +0,0 @@ --- this is just to get the GUI running on my mac, no big deal --- note: for Observe.lhs: -fglasgow-exts -cpp -package concurrent - -module EnableGUI(enableGUI) where - -import Data.Int -import Foreign -import qualified Main as Main2 - -{- -import Posix -import Concurrent -import Control.Exception -catchCtrlC = do - main_thread <- myThreadId - installHandler sigINT (Catch (hupHandler main_thread)) Nothing - where - hupHandler :: ThreadId -> IO () - hupHandler main_thread - = throwTo main_thread (ErrorCall "Control-C") --} - -main = do (enableGUI >> Main2.main) - -type ProcessSerialNumber = Int64 - -foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 -foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () -foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () - -enableGUI = alloca $ \psn -> do - getCurrentProcess psn - cgsDefaultConnection - cpsEnableForegroundOperation psn - cpsSignalAppReady psn - cpsSetFrontProcess psn diff --git a/GenI.cabal b/GenI.cabal --- a/GenI.cabal +++ b/GenI.cabal @@ -1,38 +1,121 @@ Name: GenI -Version: 0.16.1 +Version: 0.17.3 License: GPL License-file: LICENSE Author: Carlos Areces and Eric Kow -Cabal-version: >=1.2 -build-type: Custom Category: Natural Language Processing -Homepage: http://trac.loria.fr/~geni Synopsis: A natural language generator (specifically, an FB-LTAG surface realiser) Description: A natural language generator (specifically, an FB-LTAG surface realiser) -Maintainer: eric.kow@loria.fr +Homepage: http://projects.haskell.org/GenI +Maintainer: geni-users@loria.fr +Build-Type: Custom +Cabal-Version: >=1.2.3 +data-files: AUTHORS, INSTALL, README, NEWS, GenI.cabal, + examples/artificial/lexicon, + examples/artificial/macros, + examples/artificial/suite, + examples/artificial/suite-bad, + examples/chatnoir/lexicon, + examples/chatnoir/macros, + examples/chatnoir/suite, + examples/demo/lexicon, + examples/demo/macros, + examples/demo/README, + examples/demo/suite, + examples/ej/lexicon, + examples/ej/macros, + examples/ej/suite, + examples/nosemantics/lexicon, + examples/nosemantics/macros, + examples/nosemantics/README.txt, + examples/promettre/lexicon, + examples/promettre/macros, + examples/promettre/morphinfo, + examples/promettre/suite, + examples/xmg-example/grammar/Arguments.mg, + examples/xmg-example/grammar/demo-corpus-latin1.txt, + examples/xmg-example/grammar/Entete.mg, + examples/xmg-example/grammar/Evaluations.mg, + examples/xmg-example/grammar/Misc.mg, + examples/xmg-example/grammar/parse-corpus.sh, + examples/xmg-example/grammar/Sem.mg, + examples/xmg-example/grammar/VerbMorph.mg, + examples/xmg-example/lexicon/demo-lemma-latin1.lex, + examples/xmg-example/lexicon/demo-morph-latin1.mph, + examples/xmg-example/Makefile, + examples/xmg-example/README, + examples/xmg-example/suite, + etc/macstuff/macosx-app, etc/macstuff/Info.plist, etc/macstuff/wxmac.icns -extra-source-files: EnableGUI.hs, NLP/GenI/SysGeni.lhs - NLP/GenI/CkyEarley/CkyGui.lhs - NLP/GenI/Simple/SimpleGui.lhs, NLP/GenI/Gui.lhs - NLP/GenI/GraphvizShow.lhs, NLP/GenI/GuiHelper.lhs - NLP/GenI/Console.hs, NLP/GenI/Graphviz.hs - NLP/GenI/BuilderGui.lhs, NLP/GenI/unused/Predictors.lhs - NLP/GenI/GraphvizShowPolarity.lhs +extra-source-files: src/EnableGUI.hs + src/NLP/GenI/SysGeni.lhs + src/NLP/GenI/Test.hs + src/NLP/GenI/CkyEarley/CkyGui.lhs + src/NLP/GenI/Simple/SimpleGui.lhs, src/NLP/GenI/Gui.lhs + src/NLP/GenI/GraphvizShow.lhs, src/NLP/GenI/GuiHelper.lhs + src/NLP/GenI/Console.hs, src/NLP/GenI/Graphviz.hs + src/NLP/GenI/BuilderGui.lhs, src/NLP/GenI/unused/Predictors.lhs + src/NLP/GenI/GraphvizShowPolarity.lhs -data-files: GenI.cabal macstuff/macosx-app +Flag gui + description: Build with a graphical user interface + Flag splitBase description: Choose the new smaller, split-up base package. +Library + Build-depends: parsec >= 2 && < 3, + QuickCheck >= 1.2 && < 2, + HUnit > 1 && < 1.3, + mtl > 1.0 && < 1.2, + binary > 0.2 && < 0.5 + if flag(splitBase) + Build-depends: base >= 3 && < 4, containers, process + else + Build-Depends: base < 3 + + if !flag(gui) + cpp-options: -DDISABLE_GUI + + Exposed-Modules: + NLP.GenI.Btypes, + NLP.GenI.BtypesBinary, + NLP.GenI.General, + NLP.GenI.GeniParsers, + NLP.GenI.GeniShow, + NLP.GenI.Tags, + NLP.GenI.Morphology, + NLP.GenI.Polarity, NLP.GenI.Automaton, + NLP.GenI.Statistics, + NLP.GenI.Builder, + NLP.GenI.Simple.SimpleBuilder, NLP.GenI.CkyEarley.CkyBuilder, + NLP.GenI.Geni, NLP.GenI.Configuration + + Hs-Source-Dirs: src + Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ExistentialQuantification, LiberalTypeSynonyms + Ghc-options: -Wall -O2 + Executable geni Main-Is: MainGeni.lhs - Hs-Source-Dirs: . - Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses + Hs-Source-Dirs: src + Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ExistentialQuantification, LiberalTypeSynonyms + Ghc-options: -Wall + Build-Depends: filepath > 1.0 && < 1.2, + parsec >= 2.1 && < 3, + QuickCheck >= 1.2 && < 2, + HUnit >= 1 && < 1.3, + mtl >= 1.0 && < 1.2, + binary >= 0.2 && < 0.5 if flag(splitBase) - Build-Depends: base >= 3, binary, wx, wxcore, mtl, parsec, - QuickCheck, HUnit, HaXml >=1.16, libGenI, + Build-Depends: base >= 3, process > 1, directory > 1, containers >= 0.1 else - Build-Depends: base < 3, binary, wx, wxcore, mtl, parsec, - QuickCheck, HUnit, HaXml >=1.16, libGenI + Build-Depends: base < 3 + + if flag(gui) + Build-Depends: wx >= 0.10.3 && < 0.12 + else + cpp-options: -DDISABLE_GUI + diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,17 @@ +Requirements +------------ + * ghc 6.8 or 6.10 + * libgmp (for ghc) + * wxhaskell 0.10 (darcs version for now) + * wxWidgets 2.8 (for wxhaskell 0.11) + * graphviz (for GUI) + +Building GenI +-------------- +1. obtain cabal-install + +2. cabal configure + cabal build + cabal install + +For more details, see http://trac.haskell.org/GenI diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -2,7 +2,7 @@ Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @@ -313,7 +313,7 @@ If the program is interactive, make it output a short notice like this when it starts in an interactive mode: - Gnomovision version 69, Copyright (C) year name of author + Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. diff --git a/MainGeni.lhs b/MainGeni.lhs deleted file mode 100644 --- a/MainGeni.lhs +++ /dev/null @@ -1,87 +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. - -\chapter{Main} - -Welcome to the GenI source code. The main module is where everything -starts from. If you're trying to figure out how GenI works, the main -action is in Geni and Tags -(chapters \ref{cha:Geni} and \ref{cha:Tags}). - -\begin{code} -module Main (main) where -\end{code} - -\ignore{ -\begin{code} -import Data.IORef(newIORef) -import System.Environment(getArgs) - -import NLP.GenI.Geni(emptyProgState) -import NLP.GenI.Console(consoleGeni) -import NLP.GenI.Configuration (treatStandardArgs, processInstructions, - hasFlagP, BatchDirFlg(..), DisableGuiFlg(..), FromStdinFlg(..), - RegressionTestModeFlg(..), - ) - -#ifndef DISABLE_GUI -import NLP.GenI.Gui(guiGeni) -#else -guiGeni = consoleGeni -#endif -\end{code} -} - -In figure \ref{fig:code-outline-main} we show what happens from main: First, we -hand control off to either the console or the graphical user interface. These -functions then do all the business stuff like loading files and figuring out -what to generate. From there, they invoke the the generation step -\fnref{runGeni} which does surface realisation from A-Z. Alternately, the -graphical interface could invoke a graphical debugger which also does surface -realisation from A-Z but allows you to intervene, inspect and stop at each -step. - -\begin{figure} -\begin{center} -\includegraphics[scale=0.25]{images/code-outline-main} -\label{fig:code-outline-main} -\caption{How the GenI entry point is used} -\end{center} -\end{figure} - -\begin{code} -main :: IO () -main = do - args <- getArgs - confArgs <- treatStandardArgs args >>= processInstructions - let pst = emptyProgState confArgs - pstRef <- newIORef pst - let batch = hasFlagP BatchDirFlg confArgs - console = hasFlagP DisableGuiFlg confArgs - fromstdin = hasFlagP FromStdinFlg confArgs - regression = hasFlagP RegressionTestModeFlg confArgs - if (fromstdin || console || batch || regression) - then consoleGeni pstRef - else guiGeni pstRef -\end{code} - -% TODO -% Define what is and what is not exported from the modules. -% In particular in BTypes take care to export the inspection function -% but not the types. -% Re-write functions in Main as needed. -% Change input in Lexicon and Grammar to allow more than one anchor. diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,13 @@ +GenI 0.17.3, 3 Apr 2009 +----------------------- +* Simplified build method + * one single cabal package instead of two + * cabal configure -f-gui to disable GUI + * makefile stripped out + +* Lexical selection on empty semantics now allowed + * This is so that the zero-literal semantics mechanism can work again + +* Better help text + +* Baked-in unit testing (geni --unit-test) diff --git a/NLP/GenI/BuilderGui.lhs b/NLP/GenI/BuilderGui.lhs deleted file mode 100644 --- a/NLP/GenI/BuilderGui.lhs +++ /dev/null @@ -1,34 +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. - -\begin{code} -module NLP.GenI.BuilderGui -where - -import Graphics.UI.WXCore - -import qualified NLP.GenI.Builder as B -import NLP.GenI.Geni (ProgStateRef, GeniResult) -import NLP.GenI.Configuration (Params) -import NLP.GenI.Statistics (Statistics) -\end{code} - -\begin{code} -data BuilderGui = BuilderGui - { resultsPnl :: forall a . ProgStateRef -> (Window a) -> IO ([GeniResult],Statistics,Layout) - , debuggerPnl :: forall a . (Window a) -> Params -> B.Input -> String -> IO Layout } -\end{code} diff --git a/NLP/GenI/CkyEarley/CkyGui.lhs b/NLP/GenI/CkyEarley/CkyGui.lhs deleted file mode 100644 --- a/NLP/GenI/CkyEarley/CkyGui.lhs +++ /dev/null @@ -1,457 +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. - -\chapter{CKY Gui} - -\begin{code} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.CkyEarley.CkyGui where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX hiding (when) -import Graphics.UI.WXCore hiding (when) - -import qualified Control.Monad as Monad -import Control.Monad (liftM) - -import Data.IORef -import Data.List (intersperse, findIndex, sort) -import qualified Data.Map as Map -import Data.Maybe (listToMaybe, catMaybes) -import Data.Tree - -import NLP.GenI.Statistics (Statistics) - -import NLP.GenI.Automaton - ( NFA(states, transitions, startSt, finalStList) - , addTrans ) -import qualified NLP.GenI.Builder as B -import qualified NLP.GenI.BuilderGui as BG -import NLP.GenI.Btypes ( GNode, gnname ) - -import NLP.GenI.CkyEarley.CkyBuilder - ( ckyBuilder, earleyBuilder, CkyStatus, CkyItem(..), ChartId - , ciRoot, ciAdjDone - , bitVectorToSem, findId - , extractDerivations - , theResults, theAgenda, theChart, theTrash - , emptySentenceAut, mJoinAutomata, mAutomatonPaths - , unpackItemToAuts, - ) -import NLP.GenI.Configuration ( Params(..) ) - -import NLP.GenI.Geni - ( ProgStateRef, runGeni, GeniResult ) -import NLP.GenI.General ( boundsCheck, geniBug ) -import NLP.GenI.GuiHelper - ( messageGui, toSentence - , debuggerPanel, DebuggerItemBar - , addGvHandler, modifyGvParams - , GraphvizGuiSt(gvitems, gvsel, gvparams), GvIO, setGvSel - , graphvizGui, newGvRef, setGvDrawables, - ) - -import NLP.GenI.Tags ( idname, tsemantics, ttree, TagElem ) - -import NLP.GenI.Graphviz - ( GraphvizShow(..), gvNode, gvEdge, gvSubgraph, gvUnlines, gvShowTree - , gvNewline - , GraphvizShowNode(..) ) -\end{code} -} - -% -------------------------------------------------------------------- -\section{Interface} -% -------------------------------------------------------------------- - -\begin{code} -ckyGui, earleyGui :: BG.BuilderGui -ckyGui = ckyOrEarleyGui False -earleyGui = ckyOrEarleyGui True - -ckyOrEarleyGui :: Bool -> BG.BuilderGui -ckyOrEarleyGui isEarley = BG.BuilderGui { - BG.resultsPnl = resultsPnl builder - , BG.debuggerPnl = ckyDebuggerTab builder } - where builder = if isEarley then earleyBuilder else ckyBuilder - -resultsPnl :: B.Builder CkyStatus CkyItem Params -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) -resultsPnl builder pstRef f = - do (sentences, stats, st) <- runGeni pstRef builder - (lay, _, _) <- realisationsGui pstRef f (theResults st) - return (sentences, stats, lay) -\end{code} - -% -------------------------------------------------------------------- -\section{Results} -\label{sec:cky_results_gui} -% -------------------------------------------------------------------- - -\begin{code} --- | Browser for the results (if there are any) -realisationsGui :: ProgStateRef -> (Window a) -> [CkyItem] - -> GvIO CkyDebugParams (Maybe CkyItem) -realisationsGui _ f [] = - do m <- messageGui f "No results found" - gvRef <- newGvRef initCkyDebugParams [] "" - return (m, gvRef, return ()) -realisationsGui _ f resultsRaw = - do let tip = "result" - results = map Just resultsRaw - labels = map (toSentence.ciSourceTree) resultsRaw - gvRef <- newGvRef initCkyDebugParams labels tip - setGvDrawables gvRef results - graphvizGui f "cky-results" gvRef -\end{code} - -\begin{code} -data CkyDebugParams = - CkyDebugParams { debugShowFeats :: Bool - , debugShowFullDerv :: Bool - , debugShowSourceTree :: Bool - , debugWhichDerivation :: Int - , debugNodeChoice :: [ChartId] } - -initCkyDebugParams :: CkyDebugParams -initCkyDebugParams = - CkyDebugParams { debugShowFeats = False - , debugShowFullDerv = False - , debugShowSourceTree = False - , debugWhichDerivation = 0 - , debugNodeChoice = [] } - --- would be nice if Haskell sugared this kind of stuff for us -setDebugShowFeats, setDebugShowFullDerv, setDebugShowSourceTree :: Bool -> CkyDebugParams -> CkyDebugParams -setDebugShowFeats b x = x { debugShowFeats = b } -setDebugShowFullDerv b x = x { debugShowFullDerv = b } -setDebugShowSourceTree b x = x { debugShowSourceTree = b } - -setDebugWhichDerivation :: Int -> CkyDebugParams -> CkyDebugParams -setDebugWhichDerivation w x = x { debugWhichDerivation = w } - -clearDebugNodeChoice :: CkyDebugParams -> CkyDebugParams -clearDebugNodeChoice x = x { debugNodeChoice = [] } - -pushDebugNodeChoice :: ChartId -> CkyDebugParams -> CkyDebugParams -pushDebugNodeChoice w x = x { debugNodeChoice = w:(debugNodeChoice x) } - -popDebugNodeChoice :: CkyDebugParams -> Maybe (ChartId, CkyDebugParams) -popDebugNodeChoice x = - case debugNodeChoice x of - [] -> Nothing - (h:t) -> Just (h, x { debugNodeChoice = t }) - -ckyDebuggerTab :: B.Builder CkyStatus CkyItem Params - -> (Window a) -> Params -> B.Input -> String -> IO Layout -ckyDebuggerTab builder = debuggerPanel builder initCkyDebugParams stateToGv ckyItemBar - where - stateToGv :: CkyStatus -> ([(Maybe (CkyStatus,CkyItem))], [String]) - stateToGv st = - let agenda = section "AGENDA" $ theAgenda st - trash = section "TRASH" $ theTrash st - chart = section "CHART" $ theChart st - results = section "RESULTS" $ theResults st - -- - section n i = hd : (map tlFn i) - where hd = (Nothing, "___" ++ n ++ "___") - tlFn x = (Just (st,x), labelFn x) - showPaths = const "" - {- if (polarised $ genconfig st) - then (\t -> " (" ++ showPolPaths t ++ ")") - else const "" -} - gorn i = case gornAddressStr (ttree $ ciSourceTree i) (ciNode i) of - Nothing -> geniBug "A chart item claims to have a node which is not in its tree" - Just x -> x - isComplete i = ciRoot i && ciAdjDone i - -- try displaying as an automaton, or if all else fails, the tree sentence - fancyToSentence ci = - let mergedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts st ci - boringSentence = toSentence $ ciSourceTree ci - in case mAutomatonPaths mergedAut of - [] -> boringSentence - (h:_) -> unwords $ map fst $ h - labelFn i = unwords [ completeStr ++ idStr ++ gornStr - , fancyToSentence i - , "/" ++ (idname $ ciSourceTree i) - , showPaths i - ] - where idStr = show $ ciId i - completeStr = if isComplete i then ">" else "" - gornStr = if isComplete i then "" else " g" ++ (gorn i) - in unzip $ agenda ++ chart ++ results ++ trash - -ckyItemBar :: DebuggerItemBar CkyDebugParams (CkyStatus, CkyItem) -ckyItemBar f gvRef updaterFn = - do ib <- panel f [] - -- select derivation - derTxt <- staticText ib [] - derChoice <- choice ib [ tooltip := "Select a derivation" ] - jumpBtn <- button ib [ text := "Go to node" ] - unjumpBtn <- button ib [ text := "Pop back" ] - jumpChoice <- choice ib [ tooltip := "Jump to item." ] - let onDerChoice = - do sel <- get derChoice selection - modifyGvParams gvRef (setDebugWhichDerivation sel) - gvSt <- readIORef gvRef - -- update the list of jump choices - case Map.lookup (gvsel gvSt) (gvitems gvSt) of - Just (Just (s,c)) -> do - let t = selectedDerivation (gvparams gvSt) s c - nodes = map show $ sort $ derivationNodes t - set jumpChoice [ items := nodes, selection := 0 ] - updaterFn - _ -> return () - set derChoice [ on select := onDerChoice ] - -- show features - detailsChk <- checkBox ib [ text := "features" - , enabled := False, checked := False ] - fullDervChk <- checkBox ib [ text := "full derivation" - , checked := False ] - srcTreeChk <- checkBox ib [ text := "src tree" - , checked := False ] - let setChkBoxUpdater box setter = - set box [ on command := do isChecked <- get box checked - modifyGvParams gvRef $ setter isChecked - updaterFn ] - setChkBoxUpdater detailsChk setDebugShowFeats - setChkBoxUpdater fullDervChk setDebugShowFullDerv - setChkBoxUpdater srcTreeChk setDebugShowSourceTree - -- make detailsChk conditioned on srcTreeChk - set srcTreeChk [ on command :~ \x -> x >> do - isChecked <- get srcTreeChk checked - set detailsChk [ enabled := isChecked ] - ] - -- add a handler for when an item is selected: - -- update the list of derivations to choose from - let updateDerTxt t = set derTxt [ text := "Deriviations (" ++ t ++ ")" ] - handler gvSt = - do case Map.lookup (gvsel gvSt) (gvitems gvSt) of - Just (Just (s,c)) -> - do let derivations = extractDerivations s c - dervLabels = zipWith (\n _ -> show n) ([1..]::[Int]) derivations - set derChoice [ enabled := True, items := dervLabels, selection := 0 ] - onDerChoice - updateDerTxt $ show $ length derivations - _ -> - do set derChoice [ enabled := False, items := [] ] - updateDerTxt "n/a" - addGvHandler gvRef handler - -- call the handler to react to the first selection - handler `liftM` readIORef gvRef - -- pushing and popping between nodes - let jumpToNode jmpTo = - do gvSt <- readIORef gvRef - let chartItems = Map.elems $ gvitems gvSt - case findIndex isJmpTo chartItems of - Nothing -> geniBug $ "Was asked to see node " ++ (show jmpTo) ++ ", which is not in the list" - Just x -> - do setGvSel gvRef x - modifyGvParams gvRef (setDebugWhichDerivation 0) - readIORef gvRef >>= handler - updaterFn - where isJmpTo Nothing = False - isJmpTo (Just (_,x)) = ciId x == jmpTo - set jumpBtn [ on command := do - gvSt <- readIORef gvRef - case Map.lookup (gvsel gvSt) (gvitems gvSt) of - Just (Just x) -> modifyGvParams gvRef (pushDebugNodeChoice $ (ciId.snd) x) - _ -> return () - jmpSel <- get jumpChoice selection - jmpItms <- get jumpChoice items - let jmpTo = (read $ jmpItms !! jmpSel) - jumpToNode jmpTo ] - - set unjumpBtn [ on command := do - gvSt <- readIORef gvRef - case popDebugNodeChoice (gvparams gvSt) of - Nothing -> return () - Just (x,gvParam) -> do modifyGvParams gvRef (const gvParam) - jumpToNode x ] - -- - return $ hfloatCentre $ container ib $ column 0 $ - [ row 5 - [ label "Show...", widget fullDervChk, widget srcTreeChk, widget detailsChk ] - , row 5 - [ widget derTxt, widget derChoice - , hspace 5, label "Node", widget jumpChoice, widget jumpBtn, widget unjumpBtn ] ] -\end{code} - -\section{Helper code} - -\begin{code} - -gornAddressStr :: Tree GNode -> GNode -> Maybe String -gornAddressStr t target = - (concat . (intersperse ".") . (map show)) `liftM` gornAddress t target - -gornAddress :: Tree GNode -> GNode -> Maybe [Int] -gornAddress tr target = reverse `liftM` helper [] tr - where - helper current (Node x _) | (gnname x == gnname target) = Just current - helper current (Node _ l) = listToMaybe $ catMaybes $ - zipWith (\c t -> helper (c:current) t) [1..] l - - -selectedDerivation :: CkyDebugParams -> CkyStatus -> CkyItem -> Tree (ChartId, String) -selectedDerivation f s c = - let derivations = extractDerivations s c - whichDer = debugWhichDerivation f - in if boundsCheck whichDer derivations - then derivations !! whichDer - else geniBug $ "Bounds check failed on derivations selector:\n" - ++ "Selected derivation: " ++ (show whichDer) ++ "\n" - ++ "Bounds: 0 to " ++ (show $ length derivations - 1) - -derivationNodes :: Tree (ChartId, String) -> [ChartId] -derivationNodes = (map fst).flatten - --- | Remove na and subst or adj completion links -thinDerivationTree :: Tree (ChartId, String) -> Tree (ChartId, String) -thinDerivationTree = - let thinlst = ["no-adj", "subst", "adj" ] - helper n@(Node _ []) = n - -- this is made complicated for fancy highlighting to work - helper (Node (i,op) [k]) | op `elem` thinlst = (Node (i,op2) k2) - where (Node (_,op2) k2) = helper k - helper (Node x kids) = (Node x $ map helper kids) - in helper - -instance GraphvizShow CkyDebugParams (CkyStatus, CkyItem) where - graphvizLabel f (_,c) = graphvizLabel f c - graphvizParams f (_,c) = graphvizParams f c - graphvizShowAsSubgraph f p (s,c) = - let color_ x = ("color", x) - label_ x = ("label", x) - style_ x = ("style", x) - arrowtail_ x = ("arrowtail", x) - -- - substColor = color_ "blue" - adjColor = color_ "red" - -- - edgeParams (_ ,"no-adj") = [ label_ "na" ] - edgeParams (_, "kids" ) = [] - edgeParams (_, "init" ) = [ label_ "i" ] - edgeParams (_, "subst" ) = [ substColor ] - edgeParams (_, "adj" ) = [ adjColor ] - edgeParams (_, "subst-finish") = [ substColor, style_ "bold" , arrowtail_ "normal" ] - edgeParams (_, "adj-finish") = [ adjColor , style_ "dashed, bold", arrowtail_ "normal" ] - edgeParams (_, k) = [ ("label", "UNKNOWN: " ++ k) ] - -- - whichDer = debugWhichDerivation f - showFullDer = debugShowFullDerv f - showSrcTree = debugShowSourceTree f - showTree i t = gvSubgraph $ gvShowTree edgeParams (s,showFullDer, [ciId c]) prfx t - where prfx = p ++ "t" ++ (show i) - gvDerv = showTree whichDer $ if showFullDer then t else thinDerivationTree t - where t = selectedDerivation f s c - -- - joinedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts s c - gvAut = graphvizShowAsSubgraph () (p ++ "aut") joinedAut - -- - showFeats = debugShowFeats f - treeParams = unlines $ graphvizParams showFeats $ ciSourceTree c - -- FIXME: will have to make this configurable, maybe, show aut, show tree? radio button? - in "\n// ------------------- derivations --------------------------\n" - ++ treeParams ++ "node [ shape = plaintext, peripheries = 0 ]\n" - ++ gvDerv - ++ "\n// ------------------- automata (joined) ------------------------\n" - ++ gvSubgraph gvAut - ++ if showSrcTree - then ("\n// ------------------- elementary tree --------------------------\n" - ++ treeParams ++ graphvizShowAsSubgraph f p c) - else "" - -instance GraphvizShowNode (CkyStatus,Bool,[ChartId]) (ChartId, String) where - graphvizShowNode (st,showFullDerv,highlight) prefix (theId,_) = - let idStr = show theId - treename i = " (" ++ ((idname.ciSourceTree) i) ++ ")" - txt = case findId st theId of - Nothing -> ("???" ++ idStr) - Just i -> idStr ++ " " ++ (show.ciNode) i - ++ (if showFullDerv then treename i else "") - custom = if theId `elem` highlight then [ ("fontcolor","red") ] else [] - in gvNode prefix txt custom - -instance GraphvizShow CkyDebugParams CkyItem where - graphvizLabel f ci = - graphvizLabel (debugShowFeats f, nullHlter) (toTagElem ci) ++ - gvNewline ++ (gvUnlines $ ciDiagnostic ci) - - graphvizShowAsSubgraph f prefix ci = - let showFeats = debugShowFeats f - hlter n = (n, if (gnname n) == (gnname $ ciNode ci) - then Just "red" else Nothing) - in graphvizShowAsSubgraph (showFeats,hlter) (prefix ++ "tree") $ toTagElem ci - -nullHlter :: GNode -> (GNode, Maybe String) -nullHlter a = (a,Nothing) - -toTagElem :: CkyItem -> TagElem -toTagElem ci = - te { ttree = ttree te - , tsemantics = bitVectorToSem (ciSemBitMap ci) (ciSemantics ci) } - where te = ciSourceTree ci - --- FIXME: this is largely copy-and-pasted from Polarity.lhs --- it should be refactored later -instance GraphvizShow () B.SentenceAut where - graphvizShowAsSubgraph _ prefix aut = - let st = (concat.states) aut - ids = map (\x -> prefix ++ show x) ([0..]::[Int]) - -- map which permits us to assign an id to a state - stmap = Map.fromList $ zip st ids - lookupFinal x = Map.findWithDefault "error_final" x stmap - in -- final states should be a double-edged ellispse - "node [ shape = ellipse, peripheries = 2 ]; " - ++ (unlines $ map lookupFinal $ finalStList aut) - -- any other state should be an ellipse - ++ "node [ shape = ellipse, peripheries = 1 ]\n" - -- draw the states and transitions - ++ (concat $ zipWith gvShowState ids st) - ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) - -type SentenceAutState = Int - -gvShowState :: String -> SentenceAutState -> String -gvShowState stId st = gvNode stId (show st) [] - -gvShowTrans :: B.SentenceAut -> Map.Map SentenceAutState String - -> String -> SentenceAutState -> String -gvShowTrans aut stmap idFrom st = - let -- outgoing transition labels from st - trans = Map.findWithDefault Map.empty st $ transitions aut - -- returns the graphviz dot command to draw a labeled transition - drawTrans (stTo,x) = case Map.lookup stTo stmap of - Nothing -> drawTrans' ("id_error_" ++ (show stTo)) x - Just idTo -> drawTrans' idTo x - drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] - drawLabel labels = gvUnlines $ map fst $ catMaybes labels - in unlines $ map drawTrans $ Map.toList trans -\end{code} - -\begin{code} --- | join two automata, inserting a ".." transition between them -mJoinAutomataUsingHole :: Maybe B.SentenceAut -> Maybe B.SentenceAut -> Maybe B.SentenceAut -mJoinAutomataUsingHole aut1 Nothing = aut1 -mJoinAutomataUsingHole aut1 aut2 = - mJoinAutomata aut1 $ mJoinAutomata (Just holeAut) aut2 - where holeAut = addTrans emptyA 0 (Just ("..",[])) 1 - emptyA = emptySentenceAut { startSt = 0, finalStList = [1], states = [[0,1]] } -\end{code} diff --git a/NLP/GenI/Console.hs b/NLP/GenI/Console.hs deleted file mode 100644 --- a/NLP/GenI/Console.hs +++ /dev/null @@ -1,191 +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 console user interface including batch processing on entire --- test suites. - -module NLP.GenI.Console(consoleGeni, runTestCaseOnly) where - -import Control.Monad -import Data.IORef(readIORef, modifyIORef) -import Data.List(find, sort) -import Data.Maybe ( isJust, fromMaybe ) -import System.Directory(createDirectoryIfMissing) -import System.Exit ( exitFailure ) -import Test.HUnit.Text (runTestTT) -import qualified Test.HUnit.Base as H -import Test.HUnit.Base ((@?)) - -import NLP.GenI.Btypes - ( SemInput, showSem - , TestCase(tcSem, tcName, tcExpected) - ) -import qualified NLP.GenI.Btypes as G -import NLP.GenI.General - ( ePutStrLn, withTimeout, exitTimeout, (///) - , fst3, - ) -import NLP.GenI.Geni -import NLP.GenI.Configuration - ( Params - , BatchDirFlg(..), EarlyDeathFlg(..), FromStdinFlg(..), OutputFileFlg(..) - , MetricsFlg(..), RegressionTestModeFlg(..), StatsFileFlg(..) - , TestCaseFlg(..), TimeoutFlg(..), VerboseModeFlg(..) - , hasFlagP, getFlagP - , builderType , BuilderType(..) - ) -import qualified NLP.GenI.Builder as B -import NLP.GenI.CkyEarley.CkyBuilder -import NLP.GenI.Simple.SimpleBuilder -import NLP.GenI.Statistics ( showFinalStats, Statistics ) - -consoleGeni :: ProgStateRef -> IO() -consoleGeni pstRef = do - pst <- readIORef pstRef - loadEverything pstRef - case getFlagP TimeoutFlg (pa pst) of - Nothing -> runSuite pstRef - Just t -> withTimeout t (timeoutErr t) $ runSuite pstRef - where - timeoutErr t = do ePutStrLn $ "GenI timed out after " ++ (show t) ++ "s" - exitTimeout - --- | Runs a test suite. --- We assume that the grammar and target semantics are already --- loaded into the monadic state. --- If batch processing is enabled, save the results to the batch output --- directory with one subdirectory per case. -runSuite :: ProgStateRef -> IO () -runSuite pstRef = - do pst <- readIORef pstRef - let suite = tsuite pst - config = pa pst - verbose = hasFlagP VerboseModeFlg config - earlyDeath = hasFlagP EarlyDeathFlg config - if hasFlagP RegressionTestModeFlg config - then runRegressionSuite pstRef >> return () - else case getFlagP BatchDirFlg config of - Nothing -> runTestCaseOnly pstRef >> return () - Just bdir -> runBatch earlyDeath verbose bdir suite - where - runBatch earlyDeath verbose bdir suite = - if any null $ map tcName suite - then ePutStrLn "Can't do batch processing. The test suite has cases with no name." - else do ePutStrLn "Batch processing mode" - mapM_ (runCase earlyDeath verbose bdir) suite - runCase earlyDeath verbose bdir (G.TestCase { tcName = n, tcSem = s }) = - do when verbose $ - ePutStrLn "======================================================" - (res , _) <- runOnSemInput pstRef (PartOfSuite n bdir) s - ePutStrLn $ " " ++ n ++ " - " ++ (show $ length res) ++ " results" - when (null res && earlyDeath) $ do - ePutStrLn $ "Exiting early because test case " ++ n ++ " failed." - exitFailure - --- | Run a test suite, but in HUnit regression testing mode, --- treating each GenI test case as an HUnit test. Obviously --- we need a test suite, grammar, etc as input -runRegressionSuite :: ProgStateRef -> IO (H.Counts) -runRegressionSuite pstRef = - do pst <- readIORef pstRef - tests <- (mapM toTest) . tsuite $ pst - runTestTT . (H.TestList) . concat $ tests - where - toTest :: G.TestCase -> IO [H.Test] -- ^ GenI test case to HUnit Tests - toTest tc = -- run the case, and return a test case for each expected result - do (res , _) <- runOnSemInput pstRef InRegressionTest (tcSem tc) - let sentences = fst (unzip res) - name = tcName tc - semStr = showSem . fst3 . tcSem $ tc - mainMsg = "for " ++ semStr ++ ", got no results" - mainCase = H.TestLabel name - $ H.TestCase $ (not.null $ sentences) @? mainMsg - subMsg e = "for " ++ semStr ++ ", failed to get (" ++ e ++ ")" - subCase e = H.TestLabel name - $ H.TestCase $ (e `elem` sentences) @? subMsg e - return $ (mainCase :) $ map subCase (tcExpected tc) - --- | Run the specified test case, or failing that, the first test --- case in the suite -runTestCaseOnly :: ProgStateRef -> IO ([GeniResult], Statistics) -runTestCaseOnly pstRef = - do pst <- readIORef pstRef - let config = pa pst - pstOutfile = fromMaybe "" $ getFlagP OutputFileFlg config - sFile = fromMaybe "" $ getFlagP StatsFileFlg config - semInput <- case getFlagP TestCaseFlg config of - Nothing -> if hasFlagP FromStdinFlg config - then do getContents >>= loadTargetSemStr pstRef - ts `fmap` readIORef pstRef - else getFirstCase pst - Just c -> findCase pst c - runOnSemInput pstRef (Standalone pstOutfile sFile) semInput - where - getFirstCase pst = - case tsuite pst of - [] -> fail "Test suite is empty." - (c:_) -> return $ tcSem c - findCase pst theCase = - case find (\x -> tcName x == theCase) (tsuite pst) of - Nothing -> fail ("No such test case: " ++ theCase) - Just s -> return $ tcSem s - -data RunAs = Standalone FilePath FilePath - | PartOfSuite String FilePath - | InRegressionTest - --- | Runs a case in the test suite. If the user does not specify any test --- cases, we run the first one. If the user specifies a non-existing --- test case we raise an error. -runOnSemInput :: ProgStateRef - -> RunAs - -> SemInput - -> IO ([GeniResult], Statistics) -runOnSemInput pstRef args semInput = - do modifyIORef pstRef (\x -> x{ts = semInput}) - pst <- readIORef pstRef - let config = pa pst - (results', stats) <- case builderType config of - NullBuilder -> helper B.nullBuilder - SimpleBuilder -> helper simpleBuilder_2p - SimpleOnePhaseBuilder -> helper simpleBuilder_1p - CkyBuilder -> helper ckyBuilder - EarleyBuilder -> helper earleyBuilder - let results = sort results' - -- create directory if need be - case args of - PartOfSuite n f -> createDirectoryIfMissing False (f///n) - _ -> return () - let oWrite = case args of - Standalone "" _ -> putStrLn - Standalone f _ -> writeFile f - PartOfSuite n f -> writeFile $ f /// n /// "responses" - InRegressionTest -> const $ return () - soWrite = case args of - Standalone _ "" -> putStrLn - Standalone _ f -> writeFile f - PartOfSuite n f -> writeFile $ f /// n /// "stats" - InRegressionTest -> const $ return () - oWrite . unlines . map fst $ results - -- print out statistical data (if available) - when (isJust $ getFlagP MetricsFlg config) $ - do soWrite $ "begin stats\n" ++ showFinalStats stats ++ "end" - return (results, stats) - where - helper builder = - do (results, stats, _) <- runGeni pstRef builder - return (results, stats) diff --git a/NLP/GenI/Graphviz.hs b/NLP/GenI/Graphviz.hs deleted file mode 100644 --- a/NLP/GenI/Graphviz.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -{- - 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. --} - -{- | Graphviz is an open source tool which converts an abstract - representation of a graph (node foo is connected to node bar, etc.) - into a nicely laid out graphic. This module contains methods - to invoke graphviz and to convert graphs and trees to its input format. - - You can download this (open source) tool at - --} - -module NLP.GenI.Graphviz -where - -import Control.Monad(when) -import Data.List(intersperse) -import Data.Tree -import System.IO(hPutStrLn, hClose) -import System.Exit(ExitCode) - -import NLP.GenI.SysGeni(waitForProcess, runInteractiveProcess) - -{- | - Data structures which can be visualised with GraphViz should - implement this class. Note the first argument to graphvizShowGraph is - so that you can parameterise your show function (i.e. pass in - flags to change the way you show particular object). Note - that by default, all graphs are treated as directed graphs. You - can hide this by turning off edge arrows. --} -class GraphvizShow flag b where - graphvizShowGraph :: flag -> b -> String - graphvizShowAsSubgraph :: flag -- ^ flag - -> String -- ^ prefix - -> b -- ^ item - -> String -- ^ gv output - graphvizLabel :: flag -- ^ flag - -> b -- ^ item - -> String -- ^ gv output - graphvizParams :: flag -> b -> [String] - - graphvizShowGraph f b = - let l = graphvizLabel f b - in "digraph {\n" - ++ (unlines $ graphvizParams f b) - ++ graphvizShowAsSubgraph f "_" b ++ "\n" - ++ (if null l then "" else " label = \"" ++ l ++ "\";\n") - ++ "}" - graphvizLabel _ _ = "" - graphvizParams _ _ = [] - -class GraphvizShowNode flag b where - graphvizShowNode :: flag -- ^ flag - -> String -- ^ prefix - -> b -- ^ item - -> String -- ^ gv output - --- | Things which are meant to be displayed within some other graph --- as (part) of a node label -class GraphvizShowString flag b where - graphvizShow :: flag -- ^ flag - -> b -- ^ item - -> String -- ^ gv output - --- | Note: the 'dotFile' argument allows you to save the intermediary --- dot output to a file. You can pass in the empty string if you don't -toGraphviz :: (GraphvizShow f a) => f - -> a - -> String -- ^ the 'dotFile' - -> String -> IO ExitCode -toGraphviz p x dotFile outputFile = do - graphviz (graphvizShowGraph p x) dotFile outputFile - --- --------------------------------------------------------------------- --- useful utility functions --- --------------------------------------------------------------------- - -gvNewline :: String -gvNewline = "\\n" - -gvUnlines :: [String] -> String -gvUnlines = concat . (intersperse gvNewline) - -gvSubgraph :: String -> String -gvSubgraph g = "subgraph {\n" ++ g ++ "}\n" - --- | The Graphviz string for a node. Note that we make absolutely no --- effort to escape any characters for you; so if you need to protect --- anything from graphviz, you're on your own -gvNode :: String -- ^ the node name - -> String -- ^ the label (may be empty) - -> [(String,String)] -- ^ any other parameters - -> String -gvNode name label params = - " " ++ name ++ " " ++ (gvLabelAndParams label params) ++ "\n" - --- | The Graphviz string for a connection between two nodes. --- Same disclaimer as 'gvNode' applies. -gvEdge :: String -- ^ the 'from' node - -> String -- ^ the 'to' node - -> String -- ^ the label (may be empty) - -> [(String,String)] -- ^ any other parameters - -> String -gvEdge from to label params = - " " ++ from ++ " -> " ++ to ++ (gvLabelAndParams label params) ++ "\n" - -gvLabelAndParams :: String -> [(String,String)] -> String -gvLabelAndParams l p = - gvParams $ if null l then p else ("label", l) : p - -gvParams :: [(String,String)] -> String -gvParams [] = "" -gvParams p = "[ " ++ (concat $ intersperse ", " $ map showPair p) ++ " ]" - where showPair (a,v) = a ++ "=\"" ++ v ++ "\"" - --- --------------------------------------------------------------------- --- some instances --- --------------------------------------------------------------------- - -instance (GraphvizShow f b) => GraphvizShow f (Maybe b) where - graphvizShowAsSubgraph _ _ Nothing = "" - graphvizShowAsSubgraph f p (Just b) = graphvizShowAsSubgraph f p b - - graphvizLabel _ Nothing = "" - graphvizLabel f (Just b) = graphvizLabel f b - - graphvizParams _ Nothing = [] - graphvizParams f (Just b) = graphvizParams f b - --- | Displays a tree in graphviz format. -{- Note that we could make this an - instance of GraphvizShow, but I'm not too sure about the wisdom of - such a move. - - Maybe if we had some really super-sophisticated types in Haskell, where - we can define this as the default instance which could be overrided by - something more specific, that would be cool. - - The prefix argument is interpreted as the name of the top node. Node - names below are basically Gorn addresses (e.g. n0x2x3 means 3rd child of - the 2nd child of the root) to keep them distinct. Note : We use the - letter `x' as seperator because graphviz will choke on `.' or `-', even - underscore. -} -gvShowTree :: (GraphvizShowNode f n) => - (n->[(String,String)]) -- ^ function to convert a node to a list of graphviz parameters for the edge - -> f -- ^ GraphvizShow flag - -> String -- ^ node prefix - -> (Tree n) -- ^ the tree - -> String -gvShowTree edgeFn f prefix t = - "edge [ arrowhead = none ]\n" ++ gvShowTreeHelper edgeFn f prefix t - -gvShowTreeHelper :: forall n . forall f . (GraphvizShowNode f n) => (n->[(String,String)]) -> f -> String -> (Tree n) -> String -gvShowTreeHelper edgeFn f prefix (Node node l) = - let showNode = graphvizShowNode f prefix - showKid :: Integer -> Tree n -> String - showKid index kid = - gvShowTreeHelper edgeFn f kidname kid ++ " " - ++ (gvEdge prefix kidname "" (edgeFn node)) - where kidname = prefix ++ "x" ++ (show index) - in showNode node ++ "\n" ++ (concat $ zipWith showKid [0..] l) - --- --------------------------------------------------------------------- --- invocation --- --------------------------------------------------------------------- - --- | Calls graphviz. If the second argument is the empty string, then we --- just send stuff directly to dot's stdin - -graphviz :: String -- ^ graphviz's dot format. - -> String -- ^ the name of the file graphviz should write the dot - -> String -- ^ the name of the file graphviz should write its output - -> IO ExitCode - --- We write the dot String to a temporary file which we then feed to graphviz. --- This is avoid complications with fork and pipes. We use png output even --- though it's uglier, because we don't have a wxhaskell widget that can --- display postscript... do we? - -graphviz dot dotFile outputFile = do - let dotArgs' = ["-Gfontname=courier", - "-Nfontname=courier", - "-Efontname=courier", - "-Gcharset=latin1", -- FIXME: should really output UTF-8 instead - "-Tpng", "-o" ++ outputFile ] - dotArgs = dotArgs' ++ (if (null dotFile) then [] else [dotFile]) - -- putStrLn ("sending to graphviz:\n" ++ dot) - when (not $ null dotFile) $ writeFile dotFile dot - (_, toGV, _, pid) <- runInteractiveProcess "dot" dotArgs Nothing Nothing - when (null dotFile) $ do - hPutStrLn toGV dot - hClose toGV - waitForProcess pid diff --git a/NLP/GenI/GraphvizShow.lhs b/NLP/GenI/GraphvizShow.lhs deleted file mode 100644 --- a/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 NLP.GenI.Tags - ( TagElem, TagDerivation, idname, - tsemantics, ttree, - ) -import NLP.GenI.Btypes (GeniVal(GConst), AvPair, - GNode(..), GType(..), Flist, - isConst, - showSem, - ) -import NLP.GenI.General (wordsBy) -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 () (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 = - case [ av | av <- getFeat gn, fst av == attr ] of - [] -> Nothing - (av:_) -> Just (snd av) - --- | 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 (\ (_,c,(p,_)) -> [c,p]) deriv -\end{code} - -\begin{code} -graphvizShowDerivation' :: (Char, String, (String, String)) -> String -graphvizShowDerivation' (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/NLP/GenI/GraphvizShowPolarity.lhs b/NLP/GenI/GraphvizShowPolarity.lhs deleted file mode 100644 --- a/NLP/GenI/GraphvizShowPolarity.lhs +++ /dev/null @@ -1,130 +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. - -\begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.GraphvizShowPolarity -where - -import Data.List (intersperse) -import qualified Data.Map as Map - -import NLP.GenI.Btypes(showSem) -import NLP.GenI.General(showInterval, isEmptyIntersect) -import NLP.GenI.Polarity(PolAut, PolState(PolSt), NFA(states, transitions), finalSt) -import NLP.GenI.Graphviz(GraphvizShow(..), gvUnlines, gvNewline, gvNode, gvEdge) -import NLP.GenI.Tags(idname) -\end{code} - -\begin{code} -instance GraphvizShow () PolAut where - -- we want a directed graph (arrows) - graphvizShowGraph f aut = - "digraph aut {\n" - ++ "rankdir=LR\n" - ++ "ranksep = 0.02\n" - ++ "pack=1\n" - ++ "edge [ fontsize=10 ]\n" - ++ "node [ fontsize=10 ]\n" - ++ graphvizShowAsSubgraph f "aut" aut - ++ "}" - - -- - graphvizShowAsSubgraph _ prefix aut = - let st = (concat.states) aut - ids = map (\x -> prefix ++ show x) ([0..] :: [Int]) - -- map which permits us to assign an id to a state - stmap = Map.fromList $ zip st ids - in -- - gvShowFinal aut stmap - -- any other state should be an ellipse - ++ "node [ shape = ellipse, peripheries = 1 ]\n" - -- draw the states and transitions - ++ (concat $ zipWith gvShowState ids st) - ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) -\end{code} - -\begin{code} -gvShowState :: String -> PolState -> String -gvShowState stId st = - -- note that we pass the label param explicitly to allow for null label - gvNode stId "" [ ("label", showSt st) ] - where showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po - showPr _ = "" -- (_,pr,_) = pr ++ gvNewline - showPo po = concat $ intersperse "," $ map showInterval po - showEx ex = if null ex then "" else showSem ex ++ gvNewline -\end{code} - -Specify that the final states are drawn with a double circle - -\begin{code} -gvShowFinal :: PolAut -> Map.Map PolState String -> String -gvShowFinal aut stmap = - if isEmptyIntersect (concat $ states aut) fin - then "" - else "node [ peripheries = 2 ]; " - ++ concatMap (\x -> " " ++ lookupId x) fin - ++ "\n" - where fin = finalSt aut - lookupId x = Map.findWithDefault "error_final" x stmap -\end{code} - -Each transition is displayed with the name of the tree. If there is more -than one transition to the same state, they are displayed on a single -label. - -\begin{code} -gvShowTrans :: PolAut -> Map.Map PolState String - -> String -> PolState -> String -gvShowTrans aut stmap idFrom st = - let -- outgoing transition labels from st - trans = Map.findWithDefault Map.empty st $ transitions aut - -- returns the graphviz dot command to draw a labeled transition - drawTrans (stTo,x) = case Map.lookup stTo stmap of - Nothing -> drawTrans' ("id_error_" ++ (sem_ stTo)) x - Just idTo -> drawTrans' idTo x - where sem_ (PolSt i _ _) = show i - --showSem (PolSt (_,pred,_) _ _) = pred - drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] - drawLabel labels = gvUnlines labs - where - lablen = length labels - maxlabs = 6 - excess = "...and " ++ (show $ lablen - maxlabs) ++ " more" - -- - labstrs = map fn labels - fn Nothing = "EMPTY" - fn (Just x) = idname x - -- - labs = if lablen > maxlabs - then take maxlabs labstrs ++ [ excess ] - else labstrs - in unlines $ map drawTrans $ Map.toList trans -\end{code} - -%gvShowTransPred te = -% let p = tpredictors te -% charge fv = case () of _ | c == -1 -> "-" -% | c == 1 -> "+" -% | c > 0 -> "+" ++ (show c) -% | otherwise -> (show c) -% where c = lookupWithDefaultFM p 0 fv -% showfv (f,v) = charge (f,v) ++ f -% ++ (if (null v) then "" else ":" ++ v) -% in map showfv $ Map.keys p - diff --git a/NLP/GenI/Gui.lhs b/NLP/GenI/Gui.lhs deleted file mode 100644 --- a/NLP/GenI/Gui.lhs +++ /dev/null @@ -1,762 +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. - -\chapter{Graphical User Interface} - -\begin{code} -{-# LANGUAGE FlexibleContexts #-} -module NLP.GenI.Gui(guiGeni) where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX -import Graphics.UI.WXCore - -import qualified Control.Monad as Monad -import qualified Data.Map as Map - -import Data.IORef -import Data.List (isPrefixOf, nub, delete, (\\), find) -import Data.Maybe (isJust) -import System.Directory -import System.Exit (exitWith, ExitCode(ExitSuccess)) - -import qualified NLP.GenI.Builder as B -import qualified NLP.GenI.BuilderGui as BG -import NLP.GenI.Geni - ( ProgState(..), ProgStateRef, combine, initGeni - , loadEverything, loadTestSuite, loadTargetSemStr) -import NLP.GenI.General (boundsCheck, geniBug, trim, fst3) -import NLP.GenI.Btypes (ILexEntry(isemantics), TestCase(..), showFlist,) -import NLP.GenI.Tags (idname, tpolarities, tsemantics, TagElem) -import NLP.GenI.GeniShow (geniShow) -import NLP.GenI.Configuration - ( Params(..), Instruction, hasOpt - , hasFlagP, deleteFlagP, setFlagP, getFlagP, getListFlagP - , parseFlagWithParsec - -- - , ExtraPolaritiesFlg(..) - , IgnoreSemanticsFlg(..) - , LexiconFlg(..) - , MacrosFlg(..) - , MaxTreesFlg(..) - , MorphCmdFlg(..) - , MorphInfoFlg(..) - , OptimisationsFlg(..) - , RootFeatureFlg(..) - , TestSuiteFlg(..) - , TestCaseFlg(..) - , TestInstructionsFlg(..) - , ViewCmdFlg(..) - -- - , Optimisation(..) - , BuilderType(..), mainBuilderTypes ) -import NLP.GenI.GeniParsers -import NLP.GenI.GuiHelper - -import NLP.GenI.Polarity -import NLP.GenI.Simple.SimpleGui -import NLP.GenI.CkyEarley.CkyGui - - -\end{code} -} - -\section{Main Gui} - -\begin{code} -guiGeni :: ProgStateRef -> IO() -guiGeni pstRef = start $ mainGui pstRef -\end{code} - -When you first start GenI, you will see this screen: -[[FIXME:screenshot wanted]] - -It allows you to type in an input semantics (or to modify the one that was -automatically loaded up), twiddle some optimisations and run the realiser. You -can also opt to run the debugger instead of the realiser; see page -\pageref{sec:gui:debugger}. - -\begin{code} -mainGui :: ProgStateRef -> IO () -mainGui pstRef - = do -- - pst <- readIORef pstRef - -- Top Window - f <- frame [text := "Geni Project"] - -- create statusbar field - status <- statusField [] - -- create the file menu - fileMen <- menuPane [text := "&File"] - loadMenIt <- menuItem fileMen [text := "&Open files or configure GenI"] - quitMenIt <- menuQuit fileMen [text := "&Quit"] - set quitMenIt [on command := close f ] - -- create the tools menu - toolsMen <- menuPane [text := "&Tools"] - gbrowserMenIt <- menuItem toolsMen [ text := "&Inspect grammar" - , help := "Displays the trees in the grammar" ] - -- create the help menu - helpMen <- menuPane [text := "&Help"] - aboutMeIt <- menuAbout helpMen [help := "About"] - -- Tie the menu to this window - set f [ statusBar := [status] - , menuBar := [fileMen, toolsMen, helpMen] - -- put the menu event handler for an about box on the frame. - , on (menu aboutMeIt) := infoDialog f "About GenI" "The GenI generator.\nhttp://wiki.loria.fr/wiki/GenI" - -- event handler for the tree browser - , on (menu gbrowserMenIt) := do { loadEverything pstRef; treeBrowserGui pstRef } - ] - -- ----------------------------------------------------------------- - -- buttons - -- ----------------------------------------------------------------- - let config = pa pst - hasSem = hasFlagP TestSuiteFlg config - ignoreSem = hasFlagP IgnoreSemanticsFlg config - -- Target Semantics - testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ] - tsTextBox <- textCtrl f [ wrap := WrapWord - , clientSize := sz 400 80 - , enabled := hasSem - , text := if ignoreSem - then "% --ignoresemantics set" else "" ] - testCaseChoice <- choice f [ selection := 0 - , enabled := hasSem ] - -- Box and Frame for files loaded - macrosFileLabel <- staticText f [ text := getListFlagP MacrosFlg config ] - lexiconFileLabel <- staticText f [ text := getListFlagP LexiconFlg config ] - -- Generate and Debug - let genfn = doGenerate f pstRef tsTextBox - pauseOnLexChk <- checkBox f [ text := "Inspect lex", tooltip := "Affects debugger only" ] - debugBt <- button f [ text := "Debug" - , on command := get pauseOnLexChk checked >>= genfn True ] - genBt <- button f [text := "Generate", on command := genfn False False ] - quitBt <- button f [ text := "Quit", - on command := close f] - -- ----------------------------------------------------------------- - -- optimisations - -- ----------------------------------------------------------------- - algoChoiceBox <- radioBox f Vertical (map show mainBuilderTypes) - [ selection := case builderType config of - SimpleBuilder -> 0 - SimpleOnePhaseBuilder -> 1 - CkyBuilder -> 2 - EarleyBuilder -> 3 - NullBuilder -> 0 ] - set algoChoiceBox [ on select := toggleAlgo pstRef algoChoiceBox ] - polChk <- optCheckBox Polarised pstRef f - [ text := "Polarities" - , tooltip := "Use the polarity optimisation" - ] - useSemConstraintsChk <- antiOptCheckBox NoConstraints pstRef f - [ text := "Sem constraints" - , tooltip := "Use any sem constraints the user provides" - ] - iafChk <- optCheckBox Iaf pstRef f - [ text := "Idx acc filter" - , tooltip := "Only available in CKY/Earley for now" - ] - semfilterChk <- optCheckBox SemFiltered pstRef f - [ text := "Semantic filters" - , tooltip := "(2p only) Filter away semantically incomplete structures before adjunction phase" - ] - rootfilterChk <- optCheckBox RootCatFiltered pstRef f - [ text := "Root filters" - , tooltip := "(2p only) Filter away non-root structures before adjunction phase" - ] - extrapolText <- staticText f - [ text := maybe "" showLitePm $ getFlagP ExtraPolaritiesFlg config - , tooltip := "Use the following additional polarities" - ] - -- commands for the checkboxes - let togglePolStuff = do c <- get polChk checked - set extrapolText [ enabled := c ] - set polChk [on command :~ (>> togglePolStuff) ] - -- ----------------------------------------------------------------- - -- layout; packing it all together - -- ----------------------------------------------------------------- - -- set any last minute handlers, run any last minute functions - let onLoad = readConfig f pstRef macrosFileLabel lexiconFileLabel testSuiteChoice tsTextBox testCaseChoice - set loadMenIt [ on command := do configGui pstRef onLoad ] - onLoad - togglePolStuff - -- - let labeledRow l w = row 1 [ label l, hfill (widget w) ] - let gramsemBox = boxed "Files last loaded" $ - hfill $ column 1 - [ labeledRow "trees:" macrosFileLabel - , labeledRow "lexicon:" lexiconFileLabel - ] - optimBox = --boxed "Optimisations " $ -- can't used boxed with wxwidgets 2.6 -- bug? - column 5 [ label "Algorithm" - , dynamic $ widget algoChoiceBox - , label "Optimisations" - , dynamic $ widget polChk - , row 5 [ label " ", column 5 - [ dynamic $ row 5 [ label "Extra: ", widget extrapolText ] ] ] - , dynamic $ widget useSemConstraintsChk - , dynamic $ widget semfilterChk - , dynamic $ widget rootfilterChk - , dynamic $ widget iafChk - ] - set f [layout := column 5 [ gramsemBox - , row 5 [ fill $ -- boxed "Input Semantics" $ - hfill $ column 5 - [ labeledRow "test suite: " testSuiteChoice - , labeledRow "test case: " testCaseChoice - , fill $ widget tsTextBox ] - , vfill optimBox ] - -- ----------------------------- Generate and quit - , row 1 [ widget quitBt - , hfloatRight $ row 5 [ widget pauseOnLexChk, widget debugBt, widget genBt ]] ] - , clientSize := sz 525 325 - , on closing := exitWith ExitSuccess - ] - -- this is to make the menubar appear on OS X (in app bundles) - -- don't know why we need to do this though, bug? - windowHide f - windowShow f - windowRaise f -\end{code} - -\subsection{Configuration} - -Most of the optimisations are availalable as checkboxes. Note the following -point about anti-optimisations: An anti-optimisation disables a default -behaviour which is assumed to be ``optimisation''. But of course we don't -want to confuse the GUI user, so we confuse the programmer instead: -Given an anti-optimisation DisableFoo, we have a check box UseFoo. If UseFoo -is checked, we remove DisableFoo from the list; if it is unchecked, we add -it to the list. This is the opposite of the default behaviour, but the -result, I hope, is intuitive for the user. - -\begin{code} -toggleAlgo :: (Selection a, Items a String) => ProgStateRef -> a -> IO () -toggleAlgo pstRef box = - do asel <- get box selection - aitems <- get box items - let selected = aitems !! asel - btable = zip (map show mainBuilderTypes) mainBuilderTypes - btype = case [ b | (name, b) <- btable, name == selected ] of - [] -> geniBug $ "Unknown builder type " ++ selected - [b] -> b - _ -> geniBug $ "More than one builder has the name " ++ selected - modifyIORef pstRef (\x -> x { pa = (pa x) { builderType = btype } }) - -optCheckBox, antiOptCheckBox :: - Optimisation -> ProgStateRef - -> Window a -> [Prop (CheckBox ())] - -> IO (CheckBox ()) - --- | Checkbox for enabling or disabling an optimisation --- You need not set the checked or on command attributes --- as this is done for you (but you can if you want, --- setting checked will override the default, and any --- command you set will be run before the toggle stuff) -optCheckBox = optCheckBoxHelper id - --- | Same as 'optCheckBox' but for anti-optimisations -antiOptCheckBox = optCheckBoxHelper not - -optCheckBoxHelper :: (Bool -> Bool) -> Optimisation -> ProgStateRef - -> Window a -> [Prop (CheckBox ())] - -> IO (CheckBox ()) -optCheckBoxHelper idOrNot o pstRef f as = - do pst <- readIORef pstRef - chk <- checkBox f $ [ checked := idOrNot $ hasOpt o $ pa pst ] ++ as - set chk [ on command :~ (>> onCheck chk) ] - return chk - where - onCheck chk = - do isChecked <- get chk checked - pst <- readIORef pstRef - let config = pa pst - modopt = if idOrNot isChecked then (o:) else delete o - newopts = nub.modopt $ getListFlagP OptimisationsFlg config - modifyIORef pstRef (\x -> x{pa = setFlagP OptimisationsFlg newopts (pa x)}) -\end{code} - -% -------------------------------------------------------------------- -\section{Loading files} -% -------------------------------------------------------------------- - -\paragraph{readConfig} is used to update the graphical interface after -you run the \fnref{configGui}. It is also called when you first launch -the GUI - -\begin{code} -readConfig :: (Textual l, Textual t, Able ch, Items ch String, Selection ch, Selecting ch) - => Window w -> ProgStateRef -> l -> l -> ch -> t -> ch -> IO () -readConfig f pstRef macrosFileLabel lexiconFileLabel suiteChoice tsBox caseChoice = - do pst <- readIORef pstRef - let config = pa pst - -- errHandler title err = errorDialog f title (show err) - set macrosFileLabel [ text := getListFlagP MacrosFlg config ] - set lexiconFileLabel [ text := getListFlagP LexiconFlg config ] - -- set tsFileLabel [ text := getListFlagP TestSuiteFlg config ] - -- read the test suite if there is one - case getListFlagP TestInstructionsFlg config of - [] -> - do set suiteChoice [ enabled := False, items := [] ] - set caseChoice [ enabled := False, items := [] ] - is -> - do -- handler for selecting a test suite - let imap = Map.fromList $ zip [0..] is - onTestSuiteChoice = do - sel <- get suiteChoice selection - case Map.lookup sel imap of - Nothing -> geniBug $ "No such index in test suite selector (gui): " ++ show sel - Just t -> loadTestSuiteAndRefresh f pstRef t tsBox caseChoice - set suiteChoice [ enabled := True, items := map fst is - , on select := onTestSuiteChoice, selection := 0 ] - set caseChoice [ enabled := True ] - onTestSuiteChoice -- load the first suite - --- | Load the given test suite and update the GUI accordingly. --- This is used when you first start the graphical interface --- or when you run the configuration menu. -loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String) - => Window w -> ProgStateRef -> Instruction -> a -> b -> IO () -loadTestSuiteAndRefresh f pstRef (suitePath,mcs) tsBox caseChoice = - do modifyIORef pstRef $ \pst -> - pst { pa = setFlagP TestSuiteFlg suitePath - $ deleteFlagP TestCaseFlg -- shouldn't change anything - $ pa pst } - catch - (loadTestSuite pstRef) - (\e -> errorDialog f ("Error reading test suite " ++ suitePath) (show e)) - pst <- readIORef pstRef - let suite = tsuite pst - theCase = tcase pst - filterCases = - case mcs of - Nothing -> id - Just cs -> filter (\c -> tcName c `elem` cs) - suiteCases = filterCases suite - suiteCaseNames = map tcName suiteCases - -- we number the cases for easy identification, putting - -- a star to highlight the selected test case (if available) - let numfn :: Int -> String -> String - numfn n t = (if t == theCase then "* " else "") - ++ (show n) ++ ". " ++ t - tcaseLabels = zipWith numfn [1..] suiteCaseNames - -- we select the first case in cases_, if available - let fstInCases _ [] = 0 - fstInCases n (x:xs) = - if (x == theCase) then n else fstInCases (n+1) xs - caseSel = if null theCase then 0 - else fstInCases 0 suiteCaseNames - ---------------------------------------------------- - -- handler for selecting a test case - ---------------------------------------------------- - let displaySemInput (TestCase { tcSem = si, tcSemString = str }) = - geniShow $ toSemInputString si str - let onTestCaseChoice = do - csel <- get caseChoice selection - if (boundsCheck csel suite) - then do let s = (suiteCases !! csel) - set tsBox [ text :~ (\_ -> displaySemInput s) ] - else geniBug $ "Gui: test case selector bounds check error: " ++ - show csel ++ " of " ++ show suite ++ "\n" - ---------------------------------------------------- - set caseChoice [ items := tcaseLabels - , selection := caseSel - , on select := onTestCaseChoice ] - when (not $ null suite) onTestCaseChoice -- run this once -\end{code} - -% -------------------------------------------------------------------- -\section{Configuration} -% -------------------------------------------------------------------- - -\paragraph{configGui}\label{fn:configGui} provides a graphical interface which -aims to be a complete substitute for the command line switches. In addition to -the program state \fnparam{pstRef}, it takes a continuation \fnparam{loadFn} -which tells what to do when the user closes the window. - -The only thing which are not provided in this GUI are a list of optimisations -and a test case selector (which are already handled by the main interface). -This GUI is a standalone window with two tabbed sections. Note: one thing -you may want to note is that we do not divide the same way between basic -and advanced options as with the console interface. - -\begin{code} -configGui :: ProgStateRef -> IO () -> IO () -configGui pstRef loadFn = do - pst <- readIORef pstRef - let config = pa pst - -- - f <- frame [] - p <- panel f [] - nb <- notebook p [] - let browseTxt = "Browse" - -- - let fakeBoxed title lst = hstretch $ column 3 $ map hfill $ - [ hrule 1 , alignRight $ label title, vspace 5 ] - ++ map hfill lst - let shortSize = sz 10 25 - let longSize = sz 20 25 -\end{code} - -The first tab contains only the basic options: - -\begin{code} - pbas <- panel nb [] - -- files loaded (labels) - macrosFileLabel <- staticText pbas [ text := getListFlagP MacrosFlg config ] - lexiconFileLabel <- staticText pbas [ text := getListFlagP LexiconFlg config ] - tsFileLabel <- staticText pbas [ text := getListFlagP TestSuiteFlg config ] - -- "Browse buttons" - macrosBrowseBt <- button pbas [ text := browseTxt ] - lexiconBrowseBt <- button pbas [ text := browseTxt ] - tsBrowseBt <- button pbas [ text := browseTxt ] - -- root feature - rootFeatTxt <- entry pbas - [ text := showFlist $ getListFlagP RootFeatureFlg config - , size := longSize ] - let layFiles = [ row 1 [ label "trees:" - , fill $ widget macrosFileLabel - , widget macrosBrowseBt ] - , row 1 [ label "lexicon:" - , fill $ widget lexiconFileLabel - , widget lexiconBrowseBt ] - , row 1 [ label "test suite:" - , fill $ widget tsFileLabel - , widget tsBrowseBt ] - , hspace 5 - , hfill $ vrule 1 - , row 3 [ label "root features" - , hglue - , rigid $ widget rootFeatTxt ] - ] - -- the layout for the basic stuff - let layBasic = dynamic $ container pbas $ -- boxed "Basic options" $ - hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) $ layFiles -\end{code} - -The second tab contains more advanced options. Maybe we should split this -into more tabs? - -\begin{code} - padv <- panel nb [] - -- XMG tools - viewCmdTxt <- entry padv - [ tooltip := "Command used for XMG tree viewing" - , text := getListFlagP ViewCmdFlg config ] - let layXMG = fakeBoxed "XMG tools" - [ row 3 [ label "XMG view command" - , marginRight $ hfill $ widget viewCmdTxt ] ] - -- polarities - extraPolsTxt <- entry padv - [ text := maybe "" showLitePm $ getFlagP ExtraPolaritiesFlg config - , size := shortSize ] - let layPolarities = fakeBoxed "Polarities" [ hfill $ row 1 - [ label "extra polarities", rigid $ widget extraPolsTxt ] ] - -- morphology - morphFileLabel <- staticText padv [ text := getListFlagP MorphInfoFlg config ] - morphFileBrowseBt <- button padv [ text := browseTxt ] - morphCmdTxt <- entry padv - [ tooltip := "Commmand used for morphological generation" - , text := getListFlagP MorphCmdFlg config ] - let layMorph = fakeBoxed "Morphology" - [ row 3 [ label "morph info:" - , expand $ hfill $ widget morphFileLabel - , widget morphFileBrowseBt ] - , row 3 [ label "morph command" - , (marginRight.hfill) $ widget morphCmdTxt ] ] - -- ignore semantics - ignoreSemChk <- checkBox padv - [ text := "Ignore semantics" - , tooltip := "Useful as a corpus generator" - , checked := hasFlagP IgnoreSemanticsFlg config ] - let maxTreesStr = maybe "" show $ getFlagP MaxTreesFlg config - maxTreesText <- entry padv - [ text := maxTreesStr - , tooltip := "Limit number of elementary trees in a derived tree" - , size := shortSize ] - let layIgnoreSem = fakeBoxed "Ignore Semantics Mode" - [ row 3 [ widget ignoreSemChk - , hspace 5 - , label "max trees", rigid $ widget maxTreesText ] ] - -- put the whole darn thing together - let layAdvanced = hfloatLeft $ container padv $ column 10 - $ [ layXMG, layPolarities, layMorph, layIgnoreSem ] -\end{code} - -When the user clicks on a Browse button, an open file dialogue should pop up. -It gets its value from the file label on its left (passed in as an argument), -and updates said label when the user has made a selection. - -\begin{code} - -- helper functions - curDir <- getCurrentDirectory - let curDir2 = curDir ++ "/" - trim2 pth = if curDir2 `isPrefixOf` pth2 - then drop (length curDir2) pth2 - else pth2 - where pth2 = trim pth - let onBrowse theLabel - = do rawFilename <- get theLabel text - let filename = trim2 rawFilename - filetypes = [("Any file",["*","*.*"])] - fsel <- fileOpenDialog f False True - "Choose your file..." filetypes "" filename - case fsel of - -- if the user does not select any file there are no changes - Nothing -> return () - Just file -> set theLabel [ text := trim2 file ] - -- end onBrowse - -- activate those "Browse" buttons - let setBrowse w l = set w [ on command := onBrowse l ] - setBrowse macrosBrowseBt macrosFileLabel - setBrowse lexiconBrowseBt lexiconFileLabel - setBrowse tsBrowseBt tsFileLabel - setBrowse morphFileBrowseBt morphFileLabel -\end{code} - -Let's not forget the layout which puts the whole configGui together and the -command that makes everything ``work'': - -\begin{code} - let parsePol = parseFlagWithParsec "polarities" geniPolarities - parseRF = parseFlagWithParsec "root features" geniFeats - onLoad - = do macrosVal <- get macrosFileLabel text - lexconVal <- get lexiconFileLabel text - tsVal <- get tsFileLabel text - -- - rootCatVal <- get rootFeatTxt text - extraPolVal <- get extraPolsTxt text - -- - viewVal <- get viewCmdTxt text - -- - morphCmdVal <- get morphCmdTxt text - morphInfoVal <- get morphFileLabel text - -- - ignoreVal <- get ignoreSemChk checked - maxTreesVal <- get maxTreesText text - -- - let maybeSet fl fn x = - if null x then deleteFlagP fl else setFlagP fl (fn x) - maybeSetStr fl x = maybeSet fl id x - toggleFlag fl b = if b then setFlagP fl () else deleteFlagP fl - let setConfig = id - . (maybeSet MaxTreesFlg read maxTreesVal) - . (toggleFlag IgnoreSemanticsFlg ignoreVal) - . (maybeSetStr MacrosFlg macrosVal) - . (maybeSetStr LexiconFlg lexconVal) - . (maybeSetStr TestSuiteFlg tsVal) - . (maybeSet RootFeatureFlg parseRF rootCatVal) - . (maybeSet ExtraPolaritiesFlg parsePol extraPolVal) - . (maybeSetStr ViewCmdFlg viewVal) - . (maybeSetStr MorphCmdFlg morphCmdVal) - . (maybeSetStr MorphInfoFlg morphInfoVal) - modifyIORef pstRef $ \x -> x { pa = setConfig (pa x) } - loadFn - -- end onLoad - -- the button bar - cancelBt <- button p - [ text := "Cancel", on command := close f ] - loadBt <- button p - [ text := "Load", on command := do { onLoad; close f } ] - let layButtons = hfill $ row 1 - [ hfloatLeft $ widget cancelBt - , hfloatRight $ widget loadBt ] - -- - set f [ layout := dynamic $ fill $ container p $ column 0 - [ fill $ tabs nb [ tab "Basic" layBasic - , tab "Advanced" layAdvanced ] - , hfill $ layButtons ] - ] -\end{code} - -% -------------------------------------------------------------------- -\section{Running the generator} -% -------------------------------------------------------------------- - -\paragraph{doGenerate} parses the target semantics, then calls the -generator and displays the result in a results gui (below). - -\begin{code} -doGenerate :: Textual b => Window a -> ProgStateRef -> b -> Bool -> Bool -> IO () -doGenerate f pstRef sembox useDebugger pauseOnLex = - do loadEverything pstRef - sem <- get sembox text - loadTargetSemStr pstRef sem - -- - pst <- readIORef pstRef - let config = pa pst - withBuilderGui a = - case builderType config of - NullBuilder -> error "No gui available for NullBuilder" - SimpleBuilder -> a simpleGui_2p - SimpleOnePhaseBuilder -> a simpleGui_1p - CkyBuilder -> a ckyGui - EarleyBuilder -> a earleyGui - -- - let doDebugger bg = debugGui bg pstRef pauseOnLex - doResults bg = resultsGui bg pstRef - do catch (withBuilderGui $ if useDebugger then doDebugger else doResults) - (handler "Error during realisation") - -- FIXME: it would be nice to distinguish between generation and ts - -- parsing errors - `catch` (handler "Error parsing the input semantics") - where - handler title err = errorDialog f title (show err) -\end{code} - -\paragraph{resultsGui} displays generation result in a window. The window -consists of various tabs for intermediary results in lexical -selection, derived trees, derivation trees and generation statistics. - -\begin{code} -resultsGui :: BG.BuilderGui -> ProgStateRef -> IO () -resultsGui builderGui pstRef = - do -- results window - f <- frame [ text := "Results" - , fullRepaintOnResize := False - , layout := stretch $ label "Generating..." - , clientSize := sz 300 300 - ] - p <- panel f [] - nb <- notebook p [] - -- realisations tab - (results,stats,resTab) <- BG.resultsPnl builderGui pstRef nb - -- statistics tab - let sentences = (fst . unzip) results - statTab <- statsGui nb sentences stats - -- pack it all together - set f [ layout := container p $ column 0 [ tabs nb - -- we put the realisations tab last because of what - -- seems to be buggy behaviour wrt to wxhaskell - -- or wxWidgets 2.4 and the splitter - [ tab "summary" statTab - , tab "realisations" resTab ] ] - , clientSize := sz 700 600 ] - return () -\end{code} - -\paragraph{debuggerGui} All GenI builders can make use of an interactive -graphical debugger. We provide here a universal debugging interface, -which makes use of some parameterisable bits as defined in the BuilderGui -module. This window shows a seperate tab for each surface realisation -task (lexical selection, filtering, building). We also rely heavily on -helper code defined in \ref{sec:debugger_helpers}. - -\begin{code} -debugGui :: BG.BuilderGui -> ProgStateRef -> Bool -> IO () -debugGui builderGui pstRef pauseOnLex = - do pst <- readIORef pstRef - let config = pa pst - btype = show $ builderType config - -- - f <- frame [ text := "GenI Debugger - " ++ btype ++ " edition" - , fullRepaintOnResize := False - , clientSize := sz 300 300 ] - p <- panel f [] - nb <- notebook p [] - -- generation step 1 - initStuff <- initGeni pstRef - let (tsem,_,_) = B.inSemInput initStuff - (cand,_) = unzip $ B.inCands initStuff - lexonly = B.inLex initStuff - -- continuation for candidate selection tab - let step2 newCands = - do -- generation step 2.A (run polarity stuff) - let newInitStuff = initStuff { B.inCands = map (\x -> (x, -1)) newCands } - (input2, _, autstuff) = B.preInit newInitStuff config - -- automata tab - let (auts, _, finalaut, _) = autstuff - autPnl <- if hasOpt Polarised config - then fst3 `fmap` polarityGui nb auts finalaut - else messageGui nb "polarity filtering disabled" - -- generation step 2.B (start the generator for each path) - debugPnl <- BG.debuggerPnl builderGui nb config input2 btype - let autTab = tab "automata" autPnl - debugTab = tab (btype ++ "-session") debugPnl - genTabs = if hasOpt Polarised config - then [ autTab, debugTab ] else [ debugTab ] - -- - set f [ layout := container p $ tabs nb genTabs - , clientSize := sz 700 600 ] - return () - -- candidate selection tab - let missedSem = tsem \\ (nub $ concatMap tsemantics cand) - -- we assume that for a tree to correspond to a lexical item, - -- it must have the same semantics - hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand - where lsem = isemantics l - missedLex = [ l | l <- lexonly, (not.hasTree) l ] - (canPnl,_,_) <- if pauseOnLex - then pauseOnLexGui pst nb cand missedSem missedLex step2 - else candidateGui pst nb cand missedSem missedLex - -- basic tabs - let basicTabs = [ tab "lexical selection" canPnl ] - -- - set f [ layout := container p $ tabs nb basicTabs - , clientSize := sz 700 600 ] - -- display all tabs if we are not told to pause on lex selection - when (not pauseOnLex) (step2 cand) -\end{code} - - - -% -------------------------------------------------------------------- -\section{Tree browser} -\label{sec:treebrowser_gui} -% -------------------------------------------------------------------- - -This is a very simple semantically-separated browser for all the -trees in the grammar. Note that we can't just reuse candidateGui's -code because we label and sort the trees differently. Here we -ignore the arguments in tree semantics, and we display the tree -polarities in its label. - -\begin{code} -treeBrowserGui :: ProgStateRef -> IO () -treeBrowserGui pstRef = do - pst <- readIORef pstRef - -- ALL THE TREES in the grammar... muahahaha! - let semmap = combine (gr pst) (le pst) - -- browser window - f <- frame [ text := "Tree Browser" - , fullRepaintOnResize := False - ] - -- the heavy GUI artillery - let sem = Map.keys semmap - -- - lookupTr k = Map.findWithDefault [] k semmap - treesfor k = Nothing : (map Just $ lookupTr k) - labsfor k = ("___" ++ k ++ "___") : (map fn $ lookupTr k) - where fn t = idname t ++ polfn (tpolarities t) - polfn p = if Map.null p - then "" - else " (" ++ showLitePm p ++ ")" - -- - trees = concatMap treesfor sem - itNlabl = zip trees (concatMap labsfor sem) - (browser,_,_) <- tagViewerGui pst f "tree browser" "grambrowser" itNlabl - -- the button panel - let count = length trees - length sem - quitBt <- button f [ text := "Close", on command := close f ] - -- pack it all together - set f [ layout := column 5 [ browser, - row 5 [ label ("number of trees: " ++ show count) - , hfloatRight $ widget quitBt ] ] - , clientSize := sz 700 600 ] - return () -\end{code} diff --git a/NLP/GenI/GuiHelper.lhs b/NLP/GenI/GuiHelper.lhs deleted file mode 100644 --- a/NLP/GenI/GuiHelper.lhs +++ /dev/null @@ -1,858 +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. - -\chapter{GUI Helper} - -This module provides helper functions for building the GenI graphical -user interface - -\begin{code} -{-# LANGUAGE FlexibleContexts #-} -module NLP.GenI.GuiHelper where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX -import Graphics.UI.WXCore - -import qualified Control.Monad as Monad -import Control.Monad.State ( execStateT, runState ) -import qualified Data.Map as Map - -import Data.IORef -import Data.List (intersperse) -import System.Directory -import System.Process (runProcess) -import Text.ParserCombinators.Parsec (parseFromFile) - -import NLP.GenI.Graphviz -import NLP.GenI.Automaton (numStates, numTransitions) -import NLP.GenI.Statistics (Statistics, showFinalStats) - -import NLP.GenI.Configuration ( getFlagP, MacrosFlg(..), ViewCmdFlg(..) ) -import NLP.GenI.GeniShow(geniShow) -import NLP.GenI.GraphvizShow () -import NLP.GenI.Tags (TagItem(tgIdName), tagLeaves) -import NLP.GenI.Geni - ( ProgState(..), showRealisations ) -import NLP.GenI.GeniParsers ( geniTagElems ) -import NLP.GenI.General - (geniBug, boundsCheck, (///), dropTillIncluding, basename, ePutStrLn) -import NLP.GenI.Btypes - ( showAv, showPred, showSem, showLexeme, Sem, ILexEntry(iword, ifamname), ) -import NLP.GenI.Tags - ( idname, mapBySem, TagElem(ttrace, tinterface) ) - -import NLP.GenI.Configuration - ( Params(..), MetricsFlg(..), setFlagP ) - -import qualified NLP.GenI.Builder as B -import NLP.GenI.Builder (queryCounter, num_iterations, chart_size, - num_comparisons) -import NLP.GenI.Polarity (PolAut, detectPolFeatures) -import NLP.GenI.GraphvizShowPolarity () -\end{code} -} - -\subsection{Lexically selected items} - -We have a browser for the lexically selected items. We group the lexically -selected items by the semantics they subsume, inserting along the way some -fake trees and labels for the semantics. - -The arguments \fnparam{missedSem} and \fnparam{missedLex} are used to -indicate to the user respectively if any bits of the input semantics -have not been accounted for, or if there have been lexically selected -items for which no tree has been found. - -\begin{code} -candidateGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry] - -> GvIO Bool (Maybe TagElem) -candidateGui pst f xs missedSem missedLex = do - p <- panel f [] - (tb,gvRef,updater) <- tagViewerGui pst p "lexically selected item" "candidates" - $ sectionsBySem xs - let warningSem = if null missedSem then "" - else "WARNING: no lexical selection for " ++ showSem missedSem - warningLex = if null missedLex then "" - else "WARNING: '" ++ (concat $ intersperse ", " $ map showLex missedLex) - ++ "' were lexically selected, but are not anchored to" - ++ " any trees" - where showLex l = (showLexeme $ iword l) ++ "-" ++ (ifamname l) - -- - polFeats = "Polarity attributes detected: " ++ (unwords.detectPolFeatures) xs - warning = unlines $ filter (not.null) [ warningSem, warningLex, polFeats ] - -- side panel - sidePnl <- panel p [] - ifaceLst <- singleListBox sidePnl [ tooltip := "interface for this tree (double-click me!)" ] - traceLst <- singleListBox sidePnl [ tooltip := "trace for this tree (double-click me!)" ] - tNoted <- textCtrl sidePnl [ wrap := WrapWord, text := "Hint: copy from below and paste into the sem:\n" ] - let laySide = container sidePnl $ column 2 - [ label "interface" - , fill $ widget ifaceLst - , label "trace" - , fill $ widget traceLst - , label "notes" - , fill $ widget tNoted ] - -- handlers - let addLine :: String -> String -> String - addLine x y = y ++ "\n" ++ x - -- - addToNoted w = - do sel <- get w selection - things <- get w items - when (sel > 0) $ set tNoted [ text :~ addLine (things !! sel) ] - set ifaceLst [ on doubleClick := \_ -> addToNoted ifaceLst ] - set traceLst [ on doubleClick := \_ -> addToNoted traceLst ] - -- updaters : what happens when the user selects an item - let updateTrace = gvOnSelect (return ()) - (\s -> set traceLst [ items := ttrace s ]) - updateIface = gvOnSelect (return ()) - (\s -> set ifaceLst [ items := map showAv $ tinterface s ]) - Monad.unless (null xs) $ do - addGvHandler gvRef updateTrace - addGvHandler gvRef updateIface - -- first time run - gvSt <- readIORef gvRef - updateIface gvSt - updateTrace gvSt - -- - let layMain = fill $ row 2 [ fill tb, vfill laySide ] - theItems = if null warning then [ layMain ] else [ hfill (label warning) , layMain ] - lay = fill $ container p $ column 5 theItems - return (lay, gvRef, updater) - -sectionsBySem :: (TagItem t) => [t] -> [ (Maybe t, String) ] -sectionsBySem tsem = - let semmap = mapBySem tsem - sem = Map.keys semmap - -- - lookupTr k = Map.findWithDefault [] k semmap - section k = (Nothing, header) : (map tlab $ lookupTr k) - where header = "___" ++ showPred k ++ "___" - tlab t = (Just t, tgIdName t) - in concatMap section sem -\end{code} - -\subsection{Polarity Automata} - -A browser to see the automata constructed during the polarity optimisation -step. - -\begin{code} -polarityGui :: (Window a) -> [(String,PolAut,PolAut)] -> PolAut - -> GvIO () PolAut -polarityGui f xs final = do - let stats a = " (" ++ (show $ numStates a) ++ "st " ++ (show $ numTransitions a) ++ "tr)" - aut2 (_ , a1, a2) = [ a1, a2 ] - autLabel (fv,a1,a2) = [ fv ++ stats a1, fv ++ " pruned" ++ stats a2] - autlist = (concatMap aut2 xs) ++ [ final ] - labels = (concatMap autLabel xs) ++ [ "final" ++ stats final ] - -- - gvRef <- newGvRef () labels "automata" - setGvDrawables gvRef autlist - graphvizGui f "polarity" gvRef -\end{code} - -\paragraph{statsGui} displays the generation statistics and provides a -handy button for saving results to a text file. - -\begin{code} -statsGui :: (Window a) -> [String] -> Statistics -> IO Layout -statsGui f sentences stats = - do let msg = showRealisations sentences - -- - p <- panel f [] - t <- textCtrl p [ text := msg, enabled := False ] - statsTxt <- staticText p [ text := showFinalStats stats ] - -- - saveBt <- button p [ text := "Save to file" - , on command := maybeSaveAsFile f msg ] - return $ fill $ container p $ column 1 $ - [ hfill $ label "Performance data" - , hfill $ widget statsTxt - , hfill $ label "Realisations" - , fill $ widget t - , hfloatRight $ widget saveBt ] -\end{code} - -\subsection{TAG trees} - -Our graphical interfaces have to display a great variety of items. To -keep things nicely factorised, we define some type classes to describe -the things that these items may have in common. - -\begin{code} --- | Any data structure which has corresponds to a TAG tree and which --- has some notion of derivation -class XMGDerivation a where - getSourceTrees :: a -> [String] - -instance XMGDerivation TagElem where - getSourceTrees te = [idname te] -\end{code} - -\fnlabel{toSentence} almost displays a TagElem as a sentence, but only -good enough for debugging needs. The problem is that each leaf may be -an atomic disjunction. Our solution is just to display each choice and -use some delimiter to seperate them. We also do not do any -morphological processing. - -\begin{code} -toSentence :: TagElem -> String -toSentence = unwords . map squishLeaf . tagLeaves - -squishLeaf :: (a,([String], b)) -> String -squishLeaf = showLexeme.fst.snd -\end{code} - -\subsection{TAG viewer} - -A TAG viewer is a graphvizGui that lets the user toggle the display -of TAG feature structures. - -\begin{code} -tagViewerGui :: (GraphvizShow Bool t, TagItem t, XMGDerivation t) - => ProgState -> (Window a) -> String -> String -> [(Maybe t,String)] - -> GvIO Bool (Maybe t) -tagViewerGui pst f tip cachedir itNlab = do - p <- panel f [] - let (tagelems,labels) = unzip itNlab - gvRef <- newGvRef False labels tip - setGvDrawables gvRef tagelems - (lay,ref,updaterFn) <- graphvizGui p cachedir gvRef - -- button bar widgets - detailsChk <- checkBox p [ text := "Show features" - , checked := False ] - viewTagLay <- viewTagWidgets p gvRef (pa pst) - -- handlers - let onDetailsChk = - do isDetailed <- get detailsChk checked - setGvParams gvRef isDetailed - updaterFn - set detailsChk [ on command := onDetailsChk ] - -- pack it all in - let cmdBar = hfill $ row 5 - [ dynamic $ widget detailsChk - , viewTagLay ] - lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ] - return (lay2,ref,updaterFn) -\end{code} - -\subsection{XMG Metagrammar stuff} - -XMG trees are produced by the XMG metagrammar system -(\url{http://sourcesup.cru.fr/xmg/}). To debug these grammars, it is useful, -given a TAG tree, to see what its metagrammar origins are. We provide here an -interface to Yannick Parmentier's handy visualisation tool ViewTAG. - -\begin{code} -viewTagWidgets :: (GraphvizShow Bool t, TagItem t, XMGDerivation t) - => Window a -> GraphvizRef (Maybe t) Bool -> Params - -> IO Layout -viewTagWidgets p gvRef config = - do viewTagBtn <- button p [ text := "ViewTAG" ] - viewTagCom <- choice p [ tooltip := "derivation tree" ] - -- handlers - let onViewTag = readIORef gvRef >>= - gvOnSelect (return ()) - (\t -> do let derv = getSourceTrees t - ds <- get viewTagCom selection - if boundsCheck ds derv - then runViewTag config (derv !! ds) - else geniBug $ "Gui: bounds check in onViewTag" - ) - set viewTagBtn [ on command := onViewTag ] - -- when the user selects a tree, we want to update the list of derivations - let updateDerivationList = gvOnSelect - (set viewTagCom [ enabled := False ]) - (\s -> set viewTagCom [ enabled := True - , items := getSourceTrees s - , selection := 0] ) - addGvHandler gvRef updateDerivationList - updateDerivationList =<< readIORef gvRef - -- - return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ] - -runViewTag :: Params -> String -> IO () -runViewTag params drName = - case getFlagP MacrosFlg params of - Nothing -> ePutStrLn "Warning: No macros files specified (runViewTag)" - Just f -> do - -- figure out what grammar file to use - let gramfile = basename f ++ ".rec" - treenameOnly = takeWhile (/= ':') . dropTillIncluding ':' . dropTillIncluding ':' - -- run the viewer - case getFlagP ViewCmdFlg params of - Nothing -> ePutStrLn "Warning: No viewcmd specified (runViewTag)" - Just c -> do -- run the viewer - runProcess c [gramfile, treenameOnly drName] - Nothing Nothing Nothing Nothing Nothing - return () -\end{code} - -% -------------------------------------------------------------------- -\section{Graphical debugger} -\label{sec:debugger_helpers} -% -------------------------------------------------------------------- - -All GenI builders can make use of an interactive graphical debugger. In -this section, we provide some helper code to build such a debugger. - -\paragraph{pauseOnLexGui} sometimes it is useful for the user to see the -lexical selection only and either dump it to file or read replace it by -the contents of some other file. We provide an optional wrapper around -\fnref{candidateGui} which adds this extra functionality. The wrapper -also includes a "Begin" button which runs your continuation on the new -lexical selection. - -\begin{code} -pauseOnLexGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry] - -> ([TagElem] -> IO ()) -- ^ continuation - -> GvIO Bool (Maybe TagElem) -pauseOnLexGui pst f xs missedSem missedLex job = do - p <- panel f [] - candV <- varCreate xs - (tb, ref, updater) <- candidateGui pst p xs missedSem missedLex - -- supplementary button bar - let saveCmd = - do c <- varGet candV - let cStr = unlines $ map geniShow c - maybeSaveAsFile f cStr - loadCmd = - do let filetypes = [("Any file",["*","*.*"])] - fsel <- fileOpenDialog f False True "Choose your file..." filetypes "" "" - case fsel of - Nothing -> return () - Just file -> - do parsed <- parseFromFile geniTagElems file - case parsed of - Left err -> errorDialog f "" (show err) - Right c -> do varSet candV c - setGvDrawables2 ref (unzip $ sectionsBySem c) - updater - -- - saveBt <- button p [ text := "Save to file", on command := saveCmd ] - loadBt <- button p [ text := "Load from file", on command := loadCmd ] - nextBt <- button p [ text := "Begin" ] - let disableW w = set w [ enabled := False ] - set nextBt [ on command := do mapM disableW [ saveBt, loadBt, nextBt ] - varGet candV >>= job ] - -- - let lay = fill $ container p $ column 5 - [ fill tb, hfill (vrule 1) - , row 0 [ row 5 [ widget saveBt, widget loadBt ] - , hfloatRight $ widget nextBt ] ] - return (lay, ref, updater) -\end{code} - -\paragraph{debuggerTab} is potentially the most useful part of the -debugger. It shows you the contents of chart, agenda and other -such structures used during the actual surface realisation process. -This may be a bit complicated to use because there is lots of extra -stuff you need to pass in order to parameterise the whole deal. - -The function \fnreflite{debuggerTab} fills the parent window with the -standard components of a graphical debugger: -\begin{itemize} -\item An item viewer which allows the user to select one of the items - in the builder state. -\item An item bar which provides some options on how to view the - currently selected item, for example, if you want to display the - features or not. -\item A dashboard which lets the user do things like ``go ahead 6 - steps''. -\end{itemize} - -See the API for more details. - -\begin{code} -type DebuggerItemBar flg itm - = (Panel ()) -- ^ parent panel - -> GraphvizRef (Maybe itm) flg - -- ^ gv ref to use - -> GvUpdater -- ^ updaterFn - -> IO Layout - --- | A generic graphical debugger widget for GenI --- --- Besides the Builder, there are two functions you need to pass in make this --- work: --- --- 1. a 'stateToGv' which converts the builder state into a list of items --- and labels the way 'graphvizGui' likes it --- --- 2. an 'item bar' function which lets you control what bits you display --- of a selected item (for example, if you want a detailed view or not) --- the item bar should return a layout --- --- Note that we don't constrain the type of item returned by the builder to --- be the same as the type handled by your gui: that's quite normal because --- you might want to decorate the type with some other information -debuggerPanel :: (GraphvizShow flg itm) - => B.Builder st itm2 Params -- ^ builder to use - -> flg -- ^ initial value for the flag argument in GraphvizShow - -> (st -> ([Maybe itm], [String])) - -- ^ function to convert a Builder state into lists of items - -- and their labels, the way graphvizGui likes it - -> (DebuggerItemBar flg itm) - -- ^ 'itemBar' function returning a control panel configuring - -- how you want the currently selected item in the debugger - -- to be displayed - -> (Window a) -- ^ parent window - -> Params -- ^ geni params - -> B.Input -- ^ builder input - -> String -- ^ graphviz cache directory - -> IO Layout -debuggerPanel builder gvInitial stateToGv itemBar f config input cachedir = - do let initBuilder = B.init builder - nextStep = B.step builder - allSteps = B.stepAll builder - -- - let (initS, initStats) = initBuilder input config2 - config2 = setFlagP MetricsFlg (B.defaultMetricNames) config - (theItems,labels) = stateToGv initS - p <- panel f [] - -- --------------------------------------------------------- - -- item viewer: select and display an item - -- --------------------------------------------------------- - gvRef <- newGvRef gvInitial labels "debugger session" - setGvDrawables gvRef theItems - (layItemViewer,_,updaterFn) <- graphvizGui p cachedir gvRef - -- ---------------------------------------------------------- - -- item bar: controls for how an individual item is displayed - -- ---------------------------------------------------------- - layItemBar <- itemBar p gvRef updaterFn - -- ------------------------------------------- - -- dashboard: controls for the debugger itself - -- ------------------------------------------- - db <- panel p [] - restartBt <- button db [text := "Start over"] - nextBt <- button db [text := "Leap by..."] - leapVal <- entry db [ text := "1", clientSize := sz 30 25 ] - finishBt <- button db [text := "Continue"] - statsTxt <- staticText db [] - -- dashboard commands - let showQuery c gs = case queryCounter c gs of - Nothing -> "???" - Just q -> show q - updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ] - txtStats gs = "itr " ++ (showQuery num_iterations gs) ++ " " - ++ "chart sz: " ++ (showQuery chart_size gs) - ++ "\ncomparisons: " ++ (showQuery num_comparisons gs) - let genStep _ (st,stats) = runState (execStateT nextStep st) stats - let showNext s_stats = - do leapTxt <- get leapVal text - let leapInt :: Integer - leapInt = read leapTxt - (s2,stats2) = foldr genStep s_stats [1..leapInt] - setGvDrawables2 gvRef (stateToGv s2) - setGvSel gvRef 1 - updaterFn - updateStatsTxt stats2 - set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ] - let showLast = - do -- redo generation from scratch - let (s2, stats2) = runState (execStateT allSteps initS) initStats - setGvDrawables2 gvRef (stateToGv s2) - updaterFn - updateStatsTxt stats2 - let showReset = - do set nextBt [ on command := showNext (initS, initStats) ] - updateStatsTxt initStats - setGvDrawables2 gvRef (stateToGv initS) - setGvSel gvRef 1 - updaterFn - -- dashboard handlers - set finishBt [ on command := showLast ] - set restartBt [ on command := showReset ] - showReset - -- dashboard layout - let layCmdBar = hfill $ container db $ row 5 - [ widget statsTxt, hfloatRight $ row 5 - [ widget restartBt, widget nextBt - , widget leapVal, label " step(s)" - , widget finishBt ] ] - -- ------------------------------------------- - -- overall layout - -- ------------------------------------------- - return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ] -\end{code} - -% -------------------------------------------------------------------- -\section{Graphviz GUI} -\label{sec:graphviz_gui} -% -------------------------------------------------------------------- - -A general-purpose GUI for displaying a list of items graphically via -AT\&T's excellent Graphviz utility. We have a list box where we display -all the labels the user provided. If the user selects an entry from -this box, then the item corresponding to that label will be displayed. -See section \ref{sec:draw_item}. - -\paragraph{gvRef} - -We use IORef as a way to keep track of the gui state and to provide you -the possibility for modifying the contents of the GUI. The idea is that - -\begin{enumerate} -\item you create a GvRef with newGvRef -\item you call graphvizGui and get back an updater function -\item whenever you want to modify something, you use setGvWhatever - and call the updater function -\item if you want to react to the selection being changed, - you should set gvhandler -\end{enumerate} - -\begin{code} -data GraphvizOrder = GvoParams | GvoItems | GvoSel - deriving Eq -data GraphvizGuiSt a b = - GvSt { gvitems :: Map.Map Int a, - gvparams :: b, - gvlabels :: [String], - -- tooltip for the selection box - gvtip :: String, - -- handler function to call when the selection is - -- updated (note: before displaying the object) - gvhandler :: Maybe (GraphvizGuiSt a b -> IO ()), - gvsel :: Int, - gvorders :: [GraphvizOrder] } -type GraphvizRef a b = IORef (GraphvizGuiSt a b) - -newGvRef :: forall a . forall b . b -> [String] -> String -> IO (GraphvizRef a b) -newGvRef p l t = - let st = GvSt { gvparams = p, - gvitems = Map.empty, - gvlabels = l, - gvhandler = Nothing, - gvtip = t, - gvsel = 0, - gvorders = [] } - in newIORef st - -setGvSel :: GraphvizRef a b -> Int -> IO () -setGvSel gvref s = - do let fn x = x { gvsel = s, - gvorders = GvoSel : (gvorders x) } - modifyIORef gvref fn - -setGvParams :: GraphvizRef a b -> b -> IO () -setGvParams gvref c = - do let fn x = x { gvparams = c, - gvorders = GvoParams : (gvorders x) } - modifyIORef gvref fn - -modifyGvParams :: GraphvizRef a b -> (b -> b) -> IO () -modifyGvParams gvref fn = - do gvSt <- readIORef gvref - setGvParams gvref (fn $ gvparams gvSt) - -setGvDrawables :: GraphvizRef a b -> [a] -> IO () -setGvDrawables gvref it = - do let fn x = x { gvitems = Map.fromList $ zip [0..] it, - gvorders = GvoItems : (gvorders x) } - modifyIORef gvref fn - -setGvDrawables2 :: GraphvizRef a b -> ([a],[String]) -> IO () -setGvDrawables2 gvref (it,lb) = - do let fn x = x { gvlabels = lb } - modifyIORef gvref fn - setGvDrawables gvref it - --- | Helper function for making selection handlers (see 'addGvHandler') --- Note that this was designed for cases where the contents is a Maybe -gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt (Maybe a) b -> IO () -gvOnSelect onNothing onJust gvSt = - let sel = gvsel gvSt - things = gvitems gvSt - in case Map.lookup sel things of - Just (Just s) -> onJust s - _ -> onNothing - -setGvHandler :: GraphvizRef a b -> Maybe (GraphvizGuiSt a b -> IO ()) -> IO () -setGvHandler gvref mh = - do gvSt <- readIORef gvref - modifyIORef gvref (\x -> x { gvhandler = mh }) - case mh of - Nothing -> return () - Just fn -> fn gvSt - --- | add a selection handler - if there already is a handler --- this handler will be called before the new one -addGvHandler :: GraphvizRef a b -> (GraphvizGuiSt a b -> IO ()) -> IO () -addGvHandler gvref h = - do gvSt <- readIORef gvref - let newH = case gvhandler gvSt of - Nothing -> Just h - Just oldH -> Just (\g -> oldH g >> h g) - setGvHandler gvref newH -\end{code} - -\paragraph{graphvizGui} returns a layout (wxhaskell container) and a -function for updating the contents of this GUI. - -Arguments: -\begin{enumerate} -\item f - (parent window) the GUI is provided as a panel within the parent. - Note: we use window in the WxWidget's sense, meaning it could be - anything as simple as a another panel, or a notebook tab. -\item glab - (gui labels) a tuple of strings (tooltip, next button text) -\item cachedir - the cache subdirectory. We intialise this by creating a cache - directory for images which will be generated from the results -\item gvRef - see above -\end{enumerate} - -Returns: a function for updating the GUI. FIXME: it's not entirely clear -what the updater function is for; note that it's not the same as the -handler function! - -\begin{code} -graphvizGui :: (GraphvizShow f d) => - (Window a) -> String -> GraphvizRef d f -> GvIO f d -type GvIO f d = IO (Layout, GraphvizRef d f, GvUpdater) -type GvUpdater = IO () - -graphvizGui f cachedir gvRef = do - initGvSt <- readIORef gvRef - -- widgets - p <- panel f [ fullRepaintOnResize := False ] - split <- splitterWindow p [] - (dtBitmap,sw) <- scrolledBitmap split - rchoice <- singleListBox split [tooltip := gvtip initGvSt] - -- set handlers - let openFn = openImage sw dtBitmap - -- pack it all together - let lay = fill $ container p $ margin 1 $ fill $ - vsplit split 5 200 (widget rchoice) (widget sw) - set p [ on closing := closeImage dtBitmap ] - -- bind an action to rchoice - let showItem = do createAndOpenImage cachedir p gvRef openFn - `catch` \e -> errorDialog f "" (show e) - ------------------------------------------------ - -- create an updater function - ------------------------------------------------ - let updaterFn = do - gvSt <- readIORef gvRef - let orders = gvorders gvSt - labels = gvlabels gvSt - sel = gvsel gvSt - initCacheDir cachedir - Monad.when (GvoItems `elem` orders) $ - set rchoice [ items :~ (\_ -> labels) ] - Monad.when (GvoSel `elem` orders) $ - set rchoice [ selection :~ (\_ -> sel) ] - modifyIORef gvRef (\x -> x { gvorders = []}) - -- putStrLn "updaterFn called" - showItem - ------------------------------------------------ - -- enable the tree selector - -- FIXME: not sure that this is correct - ------------------------------------------------ - let selectAndShow = do - -- putStrLn "selectAndShow called" - sel <- get rchoice selection - -- note: do not use setGvSel (infinite loop) - modifyIORef gvRef (\x -> x { gvsel = sel }) - -- call the handler if there is one - gvSt <- readIORef gvRef - case (gvhandler gvSt) of - Nothing -> return () - Just h -> h gvSt - -- now do the update - updaterFn - ------------------------------------------------ - set rchoice [ on select := selectAndShow ] - -- call the updater function for the first time - -- setGvSel gvRef 1 - updaterFn - -- return the layout, the gvRef, and an updater function - -- The gvRef is to make it easier for users to muck around with the - -- state of the gui. Here, it's trivial, but when people combine guis - -- together, it might be easier to keep track of when returned - return (lay, gvRef, updaterFn) -\end{code} - -\subsection{Scroll bitmap} - -Bitmap with a scrollbar - -\begin{code} -scrolledBitmap :: Window a -> IO(VarBitmap, ScrolledWindow ()) -scrolledBitmap p = do - dtBitmap <- variable [value := Nothing] - sw <- scrolledWindow p [scrollRate := sz 10 10, bgcolor := white, - on paint := onPaint dtBitmap, - fullRepaintOnResize := False ] - return (dtBitmap, sw) -\end{code} - -\subsection{Bitmap functions} - -The following helper functions were taken directly from the WxHaskell -sample code. - -\begin{code} -type OpenImageFn = FilePath -> IO () -type VarBitmap = Var (Maybe (Bitmap ())) - -openImage :: Window a -> VarBitmap -> OpenImageFn -openImage sw vbitmap fname = do - -- load the new bitmap - bm <- bitmapCreateFromFile fname -- can fail with exception - closeImage vbitmap - set vbitmap [value := Just bm] - -- reset the scrollbars - bmsize <- get bm size - set sw [virtualSize := bmsize] - repaint sw - `catch` \_ -> repaint sw - -closeImage :: VarBitmap -> IO () -closeImage vbitmap = do - mbBitmap <- swap vbitmap value Nothing - case mbBitmap of - Nothing -> return () - Just bm -> objectDelete bm - -onPaint :: VarBitmap -> DC a -> b -> IO () -onPaint vbitmap dc _ = do - mbBitmap <- get vbitmap value - case mbBitmap of - Nothing -> return () - Just bm -> do dcClear dc - drawBitmap dc bm pointZero False [] -\end{code} - -\subsection{Drawing stuff} -\label{sec:draw_item} - -\paragraph{createAndOpenImage} Attempts to draw an image -(or retrieve it from cache) and opens it if we succeed. Otherwise, it -does nothing at all; the creation function will display an error message -if it fails. - -\begin{code} -createAndOpenImage :: (GraphvizShow f b) => - FilePath -> Window a -> GraphvizRef b f -> OpenImageFn -> IO () -createAndOpenImage cachedir f gvref openFn = do - let errormsg g = "The file " ++ g ++ " was not created!\n" - ++ "Is graphviz installed?" - r <- createImage cachedir f gvref - case r of - Just graphic -> do exists <- doesFileExist graphic - if exists - then openFn graphic - else fail (errormsg graphic) - Nothing -> return () - --- | Creates a graphical visualisation for anything which can be displayed --- by graphviz. -createImage :: (GraphvizShow f b) - => FilePath -- ^ cache directory - -> Window a -- ^ parent window - -> GraphvizRef b f -- ^ stuff to display - -> IO (Maybe FilePath) -createImage cachedir f gvref = do - gvSt <- readIORef gvref - -- putStrLn $ "creating image via graphviz" - let drawables = gvitems gvSt - sel = gvsel gvSt - config = gvparams gvSt - dotFile <- createDotPath cachedir (show sel) - graphicFile <- createImagePath cachedir (show sel) - let create x = do toGraphviz config x dotFile graphicFile - return (Just graphicFile) - handler err = do errorDialog f "Error calling graphviz" (show err) - return Nothing - exists <- doesFileExist graphicFile - -- we only call graphviz if the image is not in the cache - if exists - then return (Just graphicFile) - else case Map.lookup sel drawables of - Nothing -> return Nothing - Just it -> create it `catch` handler -\end{code} - -\subsection{Cache directory} - -We create a directory to put image files in so that we can avoid regenerating -images. If the directory already exists, we can just delete all the files -in it. - -\begin{code} -initCacheDir :: String -> IO() -initCacheDir cachesubdir = do - mainCacheDir <- gv_CACHEDIR - cmainExists <- doesDirectoryExist mainCacheDir - Monad.when (not cmainExists) $ createDirectory mainCacheDir - -- - let cachedir = mainCacheDir /// cachesubdir - cExists <- doesDirectoryExist cachedir - if (cExists) - then do let notdot x = (x /= "." && x /= "..") - contents <- getDirectoryContents cachedir - olddir <- getCurrentDirectory - setCurrentDirectory cachedir - mapM removeFile $ filter notdot contents - setCurrentDirectory olddir - return () - else createDirectory cachedir -\end{code} - -\section{Miscellaneous} -\label{sec:gui_misc} - -\begin{code} --- | Save the given string to a file, if the user selets one via the file save --- dialog. Otherwise, don't do anything. -maybeSaveAsFile :: (Window a) -> String -> IO () -maybeSaveAsFile f msg = - do let filetypes = [("Any file",["*","*.*"])] - fsel <- fileSaveDialog f False True "Save to" filetypes "" "" - case fsel of - Nothing -> return () - Just file -> writeFile file msg - --- | A message panel for use by the Results gui panels. -messageGui :: (Window a) -> String -> IO Layout -messageGui f msg = do - p <- panel f [] - -- sw <- scrolledWindow p [scrollRate := sz 10 10 ] - t <- textCtrl p [ text := msg, enabled := False ] - return (fill $ container p $ column 1 $ [ fill $ widget t ]) -\end{code} - -\begin{code} -gv_CACHEDIR :: IO String -gv_CACHEDIR = do - home <- getHomeDirectory - return $ home /// ".gvcache" - -createImagePath :: String -> String -> IO String -createImagePath subdir name = do - cdir <- gv_CACHEDIR - return $ cdir /// subdir /// name ++ ".png" - -createDotPath :: String -> String -> IO String -createDotPath subdir name = do - cdir <- gv_CACHEDIR - return $ cdir /// subdir /// name ++ ".dot" -\end{code} - - diff --git a/NLP/GenI/Simple/SimpleGui.lhs b/NLP/GenI/Simple/SimpleGui.lhs deleted file mode 100644 --- a/NLP/GenI/Simple/SimpleGui.lhs +++ /dev/null @@ -1,201 +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. - -\chapter{Simple GUI} - -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.Simple.SimpleGui where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX -import Graphics.UI.WXCore - -import Data.IORef -import qualified Data.Map as Map - -import NLP.GenI.Statistics (Statistics) - -import NLP.GenI.Btypes (GNode(gnname, gup), emptyGNode, GeniVal(GConst)) -import NLP.GenI.Configuration ( Params(..) ) -import NLP.GenI.General ( snd3 ) -import NLP.GenI.Geni ( ProgStateRef, runGeni, GeniResult ) -import NLP.GenI.Graphviz ( GraphvizShow(..), gvNewline, gvUnlines ) -import NLP.GenI.GuiHelper - ( messageGui, tagViewerGui, - debuggerPanel, DebuggerItemBar, setGvParams, GvIO, newGvRef, - viewTagWidgets, XMGDerivation(getSourceTrees), - ) -import NLP.GenI.Tags (tsemantics, TagElem(idname, ttree), TagItem(..), emptyTE) -import NLP.GenI.GraphvizShow ( graphvizShowDerivation ) - -import qualified NLP.GenI.Builder as B -import qualified NLP.GenI.BuilderGui as BG -import NLP.GenI.Polarity -import NLP.GenI.Simple.SimpleBuilder - ( simpleBuilder, SimpleStatus, SimpleItem(..), SimpleGuiItem(..) - , unpackResult - , theResults, theAgenda, theAuxAgenda, theChart, theTrash) -\end{code} -} - -% -------------------------------------------------------------------- -\section{Interface} -% -------------------------------------------------------------------- - -\begin{code} -simpleGui_2p, simpleGui_1p :: BG.BuilderGui -simpleGui_2p = simpleGui True -simpleGui_1p = simpleGui False - -simpleGui :: Bool -> BG.BuilderGui -simpleGui twophase = BG.BuilderGui { - BG.resultsPnl = resultsPnl twophase - , BG.debuggerPnl = simpleDebuggerTab twophase } - -resultsPnl :: Bool -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) -resultsPnl twophase pstRef f = - do (sentences, stats, st) <- runGeni pstRef (simpleBuilder twophase) - (lay, _, _) <- realisationsGui pstRef f (theResults st) - return (sentences, stats, lay) -\end{code} - -% -------------------------------------------------------------------- -\section{Results} -\label{sec:results_gui} -% -------------------------------------------------------------------- - -\subsection{Derived Trees} - -Browser for derived/derivation trees, except if there are no results, we show a -message box - -\begin{code} -realisationsGui :: ProgStateRef -> (Window a) -> [SimpleItem] - -> GvIO Bool (Maybe SimpleItem) -realisationsGui _ f [] = - do m <- messageGui f "No results found" - g <- newGvRef False [] "" - return (m, g, return ()) -realisationsGui pstRef f resultsRaw = - do let tip = "result" - itNlabl = map (\t -> (Just t, siToSentence t)) resultsRaw - -- - pst <- readIORef pstRef - -- FIXME: have to show the semantics again - tagViewerGui pst f tip "derived" itNlabl -\end{code} - -% -------------------------------------------------------------------- -\section{Debugger} -\label{sec:simple_debugger_gui} -\label{fn:simpleDebugGui} -% -------------------------------------------------------------------- - -\begin{code} -simpleDebuggerTab :: Bool -> (Window a) -> Params -> B.Input -> String -> IO Layout -simpleDebuggerTab twophase x1 (pa@x2) = - debuggerPanel (simpleBuilder twophase) False stToGraphviz (simpleItemBar pa) - x1 x2 - -stToGraphviz :: SimpleStatus -> ([Maybe SimpleItem], [String]) -stToGraphviz st = - let agenda = section "AGENDA" $ theAgenda st - auxAgenda = section "AUXILIARY" $ theAuxAgenda st - trash = section "TRASH" $ theTrash st - chart = section "CHART" $ theChart st - results = section "RESULTS" $ theResults st - -- - section n i = hd : (map tlFn i) - where hd = (Nothing, "___" ++ n ++ "___") - tlFn x = (Just x, siToSentence x ++ (showPaths $ siPolpaths x)) - showPaths t = " (" ++ showPolPaths t ++ ")" - in unzip $ agenda ++ auxAgenda ++ chart ++ trash ++ results - -simpleItemBar :: Params -> DebuggerItemBar Bool SimpleItem -simpleItemBar pa f gvRef updaterFn = - do ib <- panel f [] - detailsChk <- checkBox ib [ text := "Show features" - , checked := False ] - viewTagLay <- viewTagWidgets ib gvRef pa - -- handlers - let onDetailsChk = - do isDetailed <- get detailsChk checked - setGvParams gvRef isDetailed - updaterFn - set detailsChk [ on command := onDetailsChk ] - -- - return . hfloatCentre . (container ib) . row 5 $ - [ hspace 5 - , widget detailsChk - , hglue - , viewTagLay - , hspace 5 ] -\end{code} - -% -------------------------------------------------------------------- -\section{Miscellaneous} -% ------------------------------------------------------------------- - -\begin{code} -instance TagItem SimpleItem where - tgIdName = siIdname.siGuiStuff - tgIdNum = siId - tgSemantics = siFullSem.siGuiStuff - -instance XMGDerivation SimpleItem where - -- Note: this is XMG-related stuff - getSourceTrees it = tgIdName it : (map snd3 . siDerivation $ it) -\end{code} - -\begin{code} -instance GraphvizShow Bool SimpleItem where - graphvizLabel f c = - graphvizLabel f (toTagElem c) ++ gvNewline ++ (gvUnlines $ siDiagnostic $ siGuiStuff c) - - graphvizParams f c = graphvizParams f (toTagElem c) - graphvizShowAsSubgraph f p it = - let isHiglight n = gnname n `elem` (siHighlight.siGuiStuff) it - info n | isHiglight n = (n, Just "red") - | otherwise = (n, Nothing) - in "\n// ------------------- elementary tree --------------------------\n" - ++ graphvizShowAsSubgraph (f, info) (p ++ "TagElem") (toTagElem it) - ++ "\n// ------------------- derivation tree --------------------------\n" - -- derivation tree is displayed without any decoration - ++ (graphvizShowDerivation . siDerivation $ it) - -toTagElem :: SimpleItem -> TagElem -toTagElem si = - emptyTE { idname = tgIdName si - , tsemantics = tgSemantics si - , ttree = fmap lookupOrBug (siDerived si) } - where - nodes = siNodes.siGuiStuff $ si - nodeMap = Map.fromList $ zip (map gnname nodes) nodes - lookupOrBug k = case Map.lookup k nodeMap of - Nothing -> emptyGNode { gup = [ ("cat",GConst ["error looking up " ++ k]) ] } - Just x -> x -\end{code} - -\begin{code} -siToSentence :: SimpleItem -> String -siToSentence si = case unpackResult si of - [] -> siIdname.siGuiStuff $ si - (h:_) -> unwords . map fst . fst $ h -\end{code} diff --git a/NLP/GenI/SysGeni.lhs b/NLP/GenI/SysGeni.lhs deleted file mode 100644 --- a/NLP/GenI/SysGeni.lhs +++ /dev/null @@ -1,110 +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. - -\chapter{SysGeni} - -The SysGeni module mainly exists for running GenI as an application bundle -under MacOS X. We mostly re-export stuff from System.Process, but if we -are in a MacOS X application bundle, then we add \verb!../Resources/bin! -to the path for all the random crap that we ship with with GenI. - -\begin{code} -{-# LANGUAGE ForeignFunctionInterface #-} -module NLP.GenI.SysGeni -where -\end{code} - -\ignore{ -\begin{code} -import qualified System.Process as S - -#ifdef darwin_TARGET_OS -import Data.List(isSuffixOf) -import NLP.GenI.General((///)) -#endif - -import System.IO (Handle) -import System.Exit (ExitCode) - -#ifdef __GLASGOW_HASKELL__ -import Foreign -import Foreign.C -import Control.Monad -#include "ghcconfig.h" -#endif -\end{code} -} - -\section{Running a process} - -\begin{code} -waitForProcess :: S.ProcessHandle -> IO ExitCode -waitForProcess = S.waitForProcess -\end{code} - -But one thing special we need to do for Macs is to detect if we're -running from an application bundle. If we are, we assume that any -processes we want to run are in \texttt{../Resources/bin}. - -\begin{code} -runInteractiveProcess :: String -> [String] - -> Maybe FilePath - -> Maybe [(String, String)] - -> IO (Handle, Handle, Handle, S.ProcessHandle) -#ifdef darwin_TARGET_OS -runInteractiveProcess cmd args x y = do - dirname <- getProgDirName - -- detect if we're in an .app bundle, i.e. if - -- we are running from something.app/Contents/MacOS - let appBundle = ".app/Contents/MacOS/" - resBinCmd = "../Resources/bin" /// cmd - -- if we're in an .app bundle, we should prefix the - -- path with ../Resources/bin - let cmd2 = if appBundle `isSuffixOf` dirname - then resBinCmd else cmd - S.runInteractiveProcess cmd2 args x y -#else --- if not on a Mac -runInteractiveProcess = S.runInteractiveProcess -#endif -\end{code} - -\paragraph{Process helpers} - -\begin{code} -foreign import ccall unsafe "getProgArgv" - getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - -getProgDirName :: IO String -getProgDirName = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - getProgArgv p_argc p_argv - argv <- peek p_argv - s <- peekElemOff argv 0 >>= peekCString - return $ dirname s - where - dirname :: String -> String - dirname f = reverse $ dropWhile (not.isPathSeparator) $ reverse f - isPathSeparator :: Char -> Bool - isPathSeparator '/' = True -#ifdef mingw32_TARGET_OS - isPathSeparator '\\' = True -#endif - isPathSeparator _ = False -\end{code} - diff --git a/NLP/GenI/unused/Predictors.lhs b/NLP/GenI/unused/Predictors.lhs deleted file mode 100644 --- a/NLP/GenI/unused/Predictors.lhs +++ /dev/null @@ -1,315 +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. - -\chapter{Predictor Optimisation} - -One optimisation is to annotate the macros with a set of -\jargon{predictors}. This allows macros to predict that they will -combine with certain (usually) null-semantic trees. For example, a -common noun would predict that it needs a determiner. - -\begin{code} -module Predictors -where -\end{code} - -\begin{code} -import Debug.Trace -import qualified Data.Map as Map -import Data.List (nub, sortBy, groupBy, intersect) -import Monad (when, ap, foldM) -import MonadState (get, put) - -import Bfuncs (Sem, Flist, AvPair, showSem, showAv, isVar) -import Tags (TagElem(TE), emptyTE, idname, tsemantics, substnodes, - derivation, tpredictors, drawTagTrees) -import Configuration (defaultParams) -import Mstate (MS, Gstats, initGstats, addGstats, initMState, - runState, genstats, - incrNumcompar, incrSzchart, incrGeniter, - renameTagElem, - addToInitRep, - getGenRep, lookupGenRep, genRepToList, addListToGenRep, - iapplySubstNode, - nullInitRep, getInitRep, genrep, getSem, selectGiven) - -import Polarity (showLite) -\end{code} - -% ---------------------------------------------------------------------- -\section{Optimisation} -% ---------------------------------------------------------------------- - -We attempt substitution between macro and any predictors that it has. -Whenever we succeed, we can pass the combined tree as a candidate. -Whenever we fail, we have to pass both the macro and its predictors. -This is basically an indirect means of adding some kind of indexing to -the generator's chart. - -Note: there are actually two cases here. For those predictors that -we can substitute into the macro, we return the resulting tree and -discard the predictor. - -\begin{code} -optimisePredictors :: [[TagElem]] -> PredictorMap -> ([[TagElem]], Gstats) -optimisePredictors cands predictmap = - let trees = nub $ concat cands - -- calculate predicted trees - sumup = foldr addGstats initGstats - optTree t = optimisePredictors' predictmap t - optPath p = (r, sumup s) - where (r,s) = unzip $ map optTree p - (res, stats) = optPath trees - treemap = Map.fromList $ zip trees res - -- replace trees with their predicted equivalents - repTree t = lookupWithDefaultFM treemap [t] t - repPath p = concatMap repTree p - {- repPath p = trace ("\n==============\npath\n=============\n" ++ drawTagTrees l) l - where l = repPath' p -} - in (map repPath cands, stats) -\end{code} - -\paragraph{optimisePredictors'} is a helper function that tries to -fulfill as many of a tree's predictors as possible. Any predictors -it cannot use are also returned so that they can be passed to the -generator proper. - -\begin{code} -optimisePredictors' :: PredictorMap -> TagElem -> ([TagElem], Gstats) -optimisePredictors' predictmap te = - let -- grab the predictors (helper fns) - isneg _ e = e < 0 - predictors t = Map.keys $ filterFM isneg $ tpredictors t - ptrees t = concatMap fn (predictors t) - where fn = lookupWithDefaultFM predictmap [] - -- generate - tePtrees = ptrees te - initSt = initMState tePtrees [te] (tsemantics te) defaultParams - (res', st) = runState miniGenerate initSt - -- pick the trees with the largest derivation history - derSz = length.snd.derivation - cmpDerSz t1 t2 = compare (derSz t2) (derSz t1) -- note the inversion - sameDerSz t1 t2 = (derSz t2) == (derSz t1) - groupedres = groupBy sameDerSz $ sortBy cmpDerSz res' - -- return the results - result = head groupedres -- trace ("\n==============\nresults for " ++ idname te ++ "\n=============\n" ++ drawTagTrees res) $ - rejects = concatMap ptrees result - stats = genstats st - -- - debugstr = "\n===================" - ++ "\noptimising " ++ showLite te - ++ "\nptrees: " ++ showLite (tePtrees) - ++ "\n==================== " - errormsg = "Geni: Predictors.optimisePredictors' is broken" - in case () of _ | null tePtrees -> ([te], stats) - | null groupedres -> error errormsg - | otherwise -> (result ++ rejects, stats) -\end{code} - -% ---------------------------------------------------------------------- -\subsection{miniGenerate} -% ---------------------------------------------------------------------- - -miniGenerate is a lightweight version of the generator which operates -on the following principles: - -\begin{enumerate} -\item There is one primary tree (chart) and some secondary trees - (agenda), which should not be confused with auxiliary trees -\item All operations are performed between the primary - tree and the secondary trees, that is, you won't - have any interaction between secondary trees -\item The primary tree may substitute with or be - substituted any number of secondary trees -\item Secondary trees may only be used once -\end{enumerate} - -It is used as a helper function for optimisePredictors. - -\begin{code} -miniGenerate :: MS [TagElem] -miniGenerate = do - nir <- nullInitRep - gr <- getGenRep - if nir then return (concat $ elems gr) else do - incrGeniter 1 - tsem <- getSem - -- choose a secondary tree from the agenda - given <- selectGiven - -- perform any substitutions - chart <- lookupGenRep given - let (res', cost') = unzip $ map (timidSubstitution given) chart - res = concat res' - cost = foldr (+) 0 cost' - incrSzchart (length res) - incrNumcompar cost - -- add any succesful results to the chart - st <- get - put st { genrep = addListToGenRep gr res } - miniGenerate -\end{code} - -\paragraph{timidSubstitution} attempts to perform substitution between -input trees $te_1$ and $te_2$. This is meant strictly to be a helper -function for optimisePredictors, so we'll have a somewhat conservative -and quirky behaviour: -\begin{itemize} -\item If there are no ways to perform substitution, we return the empty -list -\item If there is exactly one way to perform substitution -(either $te_1$ into $te_2$ or vice versa), we -return that substitution. -\item If there is more than one way to do it, we return the empty list. -This is because the situation is ambiguous and could lead to unpredictable -results (see section \ref{sec:optimisePredictors_tricky}) -\end{itemize} - -This is somewhat similar to MState's applySubstitution, except that we -rule out the case of multiple results, and that we do not require the -substitution nodes to be in any particular order. - -\begin{code} -timidSubstitution :: TagElem -> TagElem -> ([TagElem],Int) -timidSubstitution te1 te2 = - let tesem = tsemantics te1 - -- we only substitute tags with no overlaping semantics - notOverlap = null $ intersect (tsemantics te2) tesem - -- we rename tags to do a proper substitution - rte1 = renameTagElem 'A' te1 - rte2 = renameTagElem 'B' te2 - -- perform the substitution - subst t1 t2 = concatMap (iapplySubstNode t1 t2) $ substnodes t2 - res' = (subst rte1 rte2) ++ (subst rte2 rte1) - res = if (length res' == 1) then res' else [] - -- measuring efficiency - cost = fn te1 + fn te2 - where fn t = length $ substnodes t - in if notOverlap then (res, cost) else ([], 0) -\end{code} - -\subsection{Trickiness in optimisePredictors} -\label{sec:optimisePredictors_tricky} - -Rejecting ambiguous substitutions is crucial to the idea that -secondary trees may only be used once. - -Consider the trees for \textit{the N, enemy of N, friend}. -The idea is that we eventually want to generate \textit {the enemy of the -friend}, so the result of optimisePredictors should ideally be something like: -\textit{the friend, the enemy of N} - -But this isn't so easy to achieve. In fact, if we tried to achieve -the above result, we would instead get a highly undesirable result -like this \textit{the friend, the enemy of the N} - -Do you see why the above result is bad? It is because now there is -no way to substitute friend into that noun-substitution node. To -avoid this sort of over-ambitiousness, we avoid ambiguous cases where a -tree could both substitute into or be substituted into another. So we -get a less optimal, but much safer result \textit{the friend, enemy of, -the}: - -% ---------------------------------------------------------------------- -\section{Cleanup} -% ---------------------------------------------------------------------- - -\paragraph{fillPredictors} This is neccesary when either the -predictor optimisation is disabled or if there are some -predictor substitutions which do not succeed. It takes a list of paths -and inserts all required predictors on the paths. - -\begin{code} -fillPredictors :: [[TagElem]] -> PredictorMap -> [[TagElem]] -fillPredictors paths predictmap = - let isneg _ pol = pol < 0 - getP = lookupWithDefaultFM predictmap [] - predictors te = Map.keys $ filterFM isneg $ tpredictors te - addP te = te : (concatMap getP $ predictors te) - in map (\p -> nub $ concatMap addP p) paths -\end{code} - -% -------------------------------------------------------------------- -\section{Instatiation of predictors} -% -------------------------------------------------------------------- - -We combine the predictors from the lexicon and macros. The idea is -to do this in a way which lets the grammar writer be lazy while having -as simple and predictable a behaviour as possible. Any predictors that -the lexicon has must correspond to some variable predictor in the -macros, so if I say in the lexicon that a tree as predictor -$+vsup:avoir$ there had better be a $+vsup:X$ in the macros to back it -up. - -\begin{code} -combinePredictors tt le = - let -- fn to add an item to the predictors map - addP (fv,c) fm = addToFM_C (+) fm fv c - -- lexicon predictors - lpr = sort $ ipredictors le - -- tree predictors (variable vs constant predictors) - tpr = sort $ ptpredictors tt - isVpr ((f,v),_) = (not $ null v) && isVar v - (varPr,constPr) = partition isVpr tpr - constPrFm = foldr addP Map.empty constPr - -- separating the charges from the fv - (lfv, lc) = unzip lpr - (vfv, vc) = unzip varPr - -- the unification - unify [] [] = [] - unify ((tf,tv):tnext) ((lf,lv):lnext) - | tf /= lf = error errmsg - | isVar lv = error errvlex - | isVar tv = (lf,lv):(unify (substFlist' tnext (tv,lv)) lnext) - | lv == tv = (lf,lv):(unify tnext lnext) - | otherwise = error errmsg - unification = unify vfv lfv - -- error messages in case things don't line up - errmsg = "Word '" ++ (iword le) ++ "' does not correctly " - ++ " instantiate the variable predictors in tree " - ++ (itreename le) - ++ "\n Tree predictors: " ++ (show $ map fst varPr) - ++ "\n Word predictors: " ++ (show $ map fst lpr) - ++ "\n Hint: only the variable predictors should be instantiated" - errvlex = "Word '" ++ (iword le) ++ "' contains variable " - ++ " predictors in " ++ (show $ map fst lpr) - in if (lc == vc) -- note: this implies list equality - then foldr addP constPrFm $ zip unification lc - else error errmsg -\end{code} - - -% ---------------------------------------------------------------------- -\section{PredictorMap} -% ---------------------------------------------------------------------- - -We create a map between predictors and the trees that provide them. - -\begin{code} -type PredictorMap = Map AvPair [TagElem] -\end{code} - -\begin{code} -mapByPredictors :: [TagElem] -> PredictorMap -mapByPredictors trees = foldr mapByPredictors' Map.empty trees - -mapByPredictors' :: TagElem -> PredictorMap -> PredictorMap -mapByPredictors' tree fm = - let ispos _ pol = (pol > 0) - predictors = Map.keys $ filterFM ispos $ tpredictors tree - addp p f = addToFM_C (++) f p [tree] - in foldr addp fm predictors -\end{code} diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,24 @@ +documentation +------------- +make doc # (pdflatex and haddock are needed) + +1. users manual: + http://wiki.loria.fr/wiki/GenI +2. semi-literate source code: + doc/genidoc.pdf +3. API: + doc/api/index.html + +installing GenI +--------------- +(tested on Linux and MacOs X) + +see INSTALL for details + +assuming everything above is installed correctly, +it should possible to just make + +contact us! +----------- +Please let us know if you are using GenI; we'd like to hear about your +experiences, both positive and negative. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -27,7 +27,7 @@ Normally, this should just be "macosx-app" > macosxApp :: String -> macosxApp = "macstuff/macosx-app" +> macosxApp = "etc/macstuff/macosx-app" Nothing to configure from here on --------------------------------- diff --git a/etc/macstuff/Info.plist b/etc/macstuff/Info.plist new file mode 100644 --- /dev/null +++ b/etc/macstuff/Info.plist @@ -0,0 +1,36 @@ + + + + + CFBundleDevelopmentRegion + English + CFBundleExecutable + geni + CFBundleGetInfoString + GenI unstable 0.8 + CFBundleIconFile + wxmac.icns + CFBundleIdentifier + fr.loria.geni + CFBundleInfoDictionaryVersion + 6.0 + CFBundleLongVersionString + 0.8, (c) 2005 LORIA + CFBundleName + GenI + CFBundlePackageType + APPL + CFBundleShortVersionString + 0.8 + CFBundleSignature + ???? + CFBundleVersion + 0.8 + CSResourcesFileMapped + + LSRequiresCarbon + + NSHumanReadableCopyright + Copyright 2005 LORIA + + diff --git a/etc/macstuff/macosx-app b/etc/macstuff/macosx-app new file mode 100644 --- /dev/null +++ b/etc/macstuff/macosx-app @@ -0,0 +1,114 @@ +#!/bin/sh +icnsfile=etc/macstuff/wxmac.icns +infofile=etc/macstuff/Info.plist +bundlename=GenI +rezcomp="/Developer/Tools/Rez -t APPL Carbon.r $rezfile -o" + +#------------------------------------------------------------------------ +# Helper script to create a MacOS X application from a binary. +# Hacked up with lots of GenI-specific stuff. +# Meant to be run from the bin directory directly. +# +# Daan Leijen and Arthur Baars. +# +# Copyright (c) 2003,2004 Daan Leijen, Arthur Baars +#------------------------------------------------------------------------ + +# $Id: macosx-app-template,v 1.4 2005/04/29 14:16:51 dleijen Exp $ +arg="" + +# variables +program="" +verbose="yes" + + +# Parse command-line arguments +while : ; do + # put optional argument in the $arg variable + case "$1" in + -*=*) arg=`echo "$1" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) arg= ;; + esac + + # match on the arguments + case "$1" in + "") break;; + -\?|--help) + echo "usage:" + echo " macosx-app [options] " + echo "" + echo "options: [defaults in brackets]" + echo " --help | -? show this information" + echo " --verbose | -v be verbose" + echo "" + exit 1;; + -v|--verbose) + verbose="yes";; + -*) echo "error: Unknown option \"$1\". Use \"--help\" to show valid options." 1>&2 + echo "" 1>&2 + exit 2;; + *) if test "$program"; then + echo "error: [program] is specified twice. Use \"--help\" to show valid options." 1>&2 + echo ""1>&2 + exit 2 + fi + program="$1";; + esac + shift +done + +# default program +if test -z "$program"; then + echo "error: you need to specify a program. Use \"--help\" to show valid options." 1>&2 + echo "" 1>&2 + exit 2 +fi + +# show when verbose is true. +show() +{ + if test "$verbose" = "yes"; then + echo "$1" + fi +} + +# link with default resources +# this is neccesary only to run the GUI from the command line +if test "$rezcomp"; then + show "creating resource:" + show " > $rezcomp $program" + $rezcomp $program +fi + +# create a bundle +bundle="$program.app/Contents" + +# create bundle directories +show "creating app directories:" +show " - $program.app" +mkdir -p $program.app +show " - $bundle" +mkdir -p $bundle +show " - $bundle/MacOS" +mkdir -p $bundle/MacOS +show " - $bundle/Resources" +mkdir -p $bundle/Resources + +cp -f $program $bundle/MacOS/ + +# copy the icon +cp -f ${icnsfile} $bundle/Resources + +# package info +show "creating package info:" +show " - $bundle/PkgInfo" +echo -n "APPL????" > $bundle/PkgInfo + +# create program information file +cp ${infofile} $bundle/Info.plist + +# tell finder that there's an icon +/Developer/Tools/SetFile -a C $bundle + +show "done." +show "" diff --git a/etc/macstuff/wxmac.icns b/etc/macstuff/wxmac.icns new file mode 100644 Binary files /dev/null and b/etc/macstuff/wxmac.icns differ diff --git a/examples/artificial/lexicon b/examples/artificial/lexicon new file mode 100644 --- /dev/null +++ b/examples/artificial/lexicon @@ -0,0 +1,56 @@ +_a yi1 () +semantics: [a()] + +_b er2 () +semantics: [b()] + +_t1 term (t1 bar1) +semantics: [t1()] + +_t2bar2 term (t2 bar2) +semantics: [t2()] + +_t1 term (t1 ?X) +semantics: [t1(?X)] + +_t2 term (t2 ?X) +semantics: [t2(?X)] + +_xb aux-bad () +semantics: [xb()] + +_xg aux-good () +semantics: [xg()] + +ne aux-nepas () +semantics: [xnepas()] + +_xg2 aux-good () +semantics: [xg2()] + +_d wu5 () +semantics: [d()] + +_d-b wu5-bad() +semantics: [db()] + +_e liu6-good () semantics:[eg()] +_e-b1 liu6-bad1 () semantics:[eb1()] +_e-b2 liu6-bad2 () semantics:[eb2()] + +whatever k2p-trivial () semantics:[k2p()] +iaf-g iaf-killer-good (?X) semantics:[iaf(?X)] + +whatever aconstr-with-anchor () semantics:[aconstr-with-anchor()] + +tb-unification-noadj tb-unification-noadj () semantics:[tb-unification-noadj()] +tb-unification-bot tb-unification-bot () semantics:[tb-unification-bot()] +tb-unification-adj tb-unification-adj () semantics:[tb-unification-adj()] + +no-thing no-thing () semantics:[no-thing()] +thing-good thing-good () semantics:[thing-good()] +thing-bad thing-bad () semantics:[thing-bad()] + +"string-literal-in-lemma" term () semantics:["string-lit'+!|"(foo)] + +lemanchor lemanchor() semantics:[lemanchor()] diff --git a/examples/artificial/macros b/examples/artificial/macros new file mode 100644 --- /dev/null +++ b/examples/artificial/macros @@ -0,0 +1,126 @@ +% trivial example of the kid to parent rule +k2p-trivial() initial +Mother [cat:a]![] { Anchor anchor [ cat:x ]![] } + +% note: the alphabetical names below are meaningless - they are just +% chinese numbers (which is why i follow them by the equivalent +% arabic numerals) +% +% why do i name them this way? dunno... figured they'd be easier +% to see or something + + +yi1() initial +YiMo [cat:a tb:?T]![tb:?B] { + YiLe anchor [ cat:x ]![] + YiRi type:subst [ cat:b ]![] +} + +er2() initial +Mother [cat:b]![] { + Left anchor [ cat:x ]![] + Right type:subst [ cat:t1 ]![] +} + +term(?C ?X) initial +T anchor [cat:?C foo:?X]![] + +aux-bad() auxiliary +Mother [cat:t1 tb:foo]![] { + Left anchor [ cat:x ]![] + Foot type:foot [cat:t1]![tb:bar] +} + +aux-good() auxiliary +MothA [cat:t1 tb:ping]![] { + LeftA anchor [cat:x]![] + FootA type:foot [cat:t1]![tb:ping] +} + +aux-nepas () auxiliary +Mother [cat:t1 tb:ping]![] { + Left anchor [cat:x]![] + Foot type:foot [cat:t1]![tb:ping] + Right type:lex "pas" +} + + + +% meant to receive substitution from san3 +% if it works - ?A should be set to bar +wu5 () initial +WuM [cat:a foo:?A]![] { + WuL anchor [cat:x]![] + WuR type:subst [cat:t1 foo:?A]![] +} + +% a simple tb unification which ought to work +liu6-good () initial +Mother [cat:a]![cat:a] { Anchor anchor [cat:x]![] } + +% unification + subst should work, but this should NOT propagate up! +% this should NOT propagate up +wu5-bad () initial +Mother [cat:a foo:?A]![] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 foo:?A]![] + Right type:subst [cat:t2 foo:?A]![] +} + + + +% top-bot unification failure (simple) +liu6-bad1 () initial +Mother [cat:a]![cat:b] { Anch anchor [cat:x]![] } + +% top-bot unification (complex) +liu6-bad2 () initial +Mother [cat:a tb:?X]![tb:?Y] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 foo:?X]![] + Right type:subst [cat:t2 foo:?Y]![] +} + +% this should still be passed +iaf-killer-good (?X) initial +Mother [cat:a]![cat:a] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 idx:?X]![] + Right type:subst [cat:t2 idx:?X]![] +} + +aconstr-with-anchor () initial +Anch anchor aconstr:noadj [cat:a]![] + +% this succeeds iff thing is good or left unset +tb-unification-noadj () initial +M [cat:a]![] { + X type:subst [cat:x thing:?X]![thing:good] + Y anchor [cat:b]![] +} + +tb-unification-bot() initial +M anchor [cat:a]![] + +tb-unification-adj() auxiliary +M [cat:a]![idx:b] { + X anchor [cat:b]![] + Y type:foot [cat:a]![] +} + +no-thing () initial +X anchor [cat:x]![] + +thing-good () initial +X anchor [cat:x thing:good]![] + +thing-bad () initial +X anchor [cat:x thing:bad]![] + +lemanchor () initial +M [cat:x]![] { + X anchor [cat:x]![] + Y type:subst [cat:y]![lemanchor:hello] + Z type:subst [cat:y]![lemanchor:world] +} + diff --git a/examples/artificial/suite b/examples/artificial/suite new file mode 100644 --- /dev/null +++ b/examples/artificial/suite @@ -0,0 +1,29 @@ +% there should be exactly one way to produce the answer here +% (as opposed to two) - the idea is that GenI enforces the +% condition that only trees with empty subst nodes list may +% subst up +abc semantics:[a() b() t1()] +sub semantics:[b() t1()] + +% adjunction +adj semantics:[t1() xg()] +adj-nepas semantics:[t1() xnepas()] +adj-multi semantics:[t1() xg() xg2()] + +% kidsToParents rule +k2p semantics:[t1() d()] +k2p-trivial semantics:[k2p()] + +% this should still work +iaf-killer-good semantics:[t1(x) t2(x) iaf(x)] + +tb-success semantics:[eg()] + +aconstr-with-anchor semantics:[aconstr-with-anchor()] + +tb-noadj-good-1 semantics:[tb-unification-noadj() no-thing()] +tb-noadj-good-2 semantics:[tb-unification-noadj() thing-good()] +tb-unification-1 semantics:[tb-unification-bot()] +tb-unification-2 semantics:[tb-unification-bot() tb-unification-adj()] + +lemanchor semantics:[lemanchor()] diff --git a/examples/artificial/suite-bad b/examples/artificial/suite-bad new file mode 100644 --- /dev/null +++ b/examples/artificial/suite-bad @@ -0,0 +1,11 @@ +% these should all fail + +k2p-conflict semantics:[t1() t2() db()] +adj-failure semantics:[a() xb()] % top/bot conflict + +tb-failure1 semantics:[eb1()] +tb-failure2 semantics:[eb2() t1() t2()] + +% aconstr:noadj nodes +tb-noadj-bad semantics:[tb-unification-noadj() thing-bad()] + diff --git a/examples/chatnoir/lexicon b/examples/chatnoir/lexicon new file mode 100644 --- /dev/null +++ b/examples/chatnoir/lexicon @@ -0,0 +1,65 @@ +%% 05 mai 2004 +%% Modifiers (adjectives, relatives and pp) + + +%% Determinants + +un Det(?I) +semantics:[indef(?I)] + +le Det(?I) +semantics:[def(?I)] + +%% Noms communs + +chat nC(?I) +semantics:[cat(?I)] + +souris nC(?I) +semantics:[mouse(?I)] + +%% Noms Propres + +marie nP(?I) +semantics:[marie(?I)] + +claire nP(?I) +semantics:[claire(?I)] + +olivier nP(?I) +semantics:[olivier(?I)] + +pierre nP(?I) +semantics:[pierre(?I)] + +jean nP(?I) +semantics:[jean(?I)] + +paul nP(?I) +semantics:[paul(?I)] + +%% --------------------------------------------------------------------- +%% Adjectives +%% --------------------------------------------------------------------- + +noir adj_post(?I) +semantics:[black(?I)] + +%noir2 (?I) +noir adj_post(?I) +semantics:[black(?I)] + +petit adj_pre(?I) +semantics:[little(?I)] + +mechant adj_pre(?I) +semantics:[fierce(?I)] + + +%% --------------------------------------------------------------------- +%% chasse +%% --------------------------------------------------------------------- + +chasser vArity2(?E ?X ?Y) +semantics:[chase(?E ?X ?Y)] + diff --git a/examples/chatnoir/macros b/examples/chatnoir/macros new file mode 100644 --- /dev/null +++ b/examples/chatnoir/macros @@ -0,0 +1,132 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% DETERMINERS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +Det(?I) auxiliary +n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] +{ + n2 anchor [cat:det]![] + n4 type:foot [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:?_] +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% NOUNS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% Common Nouns: voyage +nC(?I) initial +n1 anchor [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] + +% Proper Nouns: Jean +nP(?I) initial +n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% ADJECTIVES +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +adj_post(?I) auxiliary +n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] +{ + n1 type:foot [cat:n idx:?I det:minus qu:minus]! + [cat:n idx:?I det:minus qu:?_ ] + n2 anchor [cat:a]![] +} + +adj_pre(?I) auxiliary +n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] +{ + n1 anchor [cat:a]![] + n3 type:foot [cat:n idx:?I det:minus qu:minus]! + [cat:n idx:?I det:minus qu:?_ ] +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% TRANSITIVE VERBS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%infinitive + % chasser une souris vinfn1 +vArity2:vinfn1(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:?_ sujidx:?_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:?_ qu:?_ ] +} + +% declarative + % le chat chasse la souris +vArity2:n0vn1(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]! + [cat:n idx:?X det:?_ qu:?_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:?_ qu:?_ ] +} + +% question sujet + % qui chasse une souris ? +vArity2:qu0vn1(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]! + [cat:n idx:?Y det:?_ qu:?_ ] +} + +% question objet + % que chasse le chat ? +vArity2:qu1vn0(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Y det:plus qu:plus]! + [cat:n idx:?Y det:?_ qu:plus ] + n3[cat:p idx:?E]![] + { + % FIXME: EYK - the bottom node was cat:p, i set it to cat:v + % to validate + n4 anchor [cat:v idx:?E]![cat:v idx:?E] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X + det:?_ qu:?_ ] + } +} + +% relative sujet +% le chat qui chasse la souris + +vArity2:rel0vn1(?E ?X ?Y) auxiliary +n0[cat:n idx:?X det:plus qu:?_]![cat:n idx:?X det:?_ qu:?_ ] +{ + n1 type:foot [cat:n idx:?X det:?_ qu:?_]![cat:n idx:?X det:?_ qu:?_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]! + [cat:n idx:?Y det:?_ qu:?_ ] + }} + +% relative objet +% la souris que chasse le chat + +vArity2:rel1vn0(?E ?X ?Y) auxiliary +n0[cat:n idx:?Y det:plus qu:?_]![cat:n idx:?Y det:?_ qu:?_ ] +{ + n1 type:foot [cat:n idx:?Y det:?_ qu:?_]! + [cat:n idx:?Y det:?_ qu:?_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?X det:plus qu:minus]! + [cat:n idx:?X det:?_ qu:?_ ] + } +} + +% vi: set cinoptions=0,p0: diff --git a/examples/chatnoir/suite b/examples/chatnoir/suite new file mode 100644 --- /dev/null +++ b/examples/chatnoir/suite @@ -0,0 +1,36 @@ +le_mechant_chat_noir_chasser_le_souris +semantics : [ chase(e1 a b) + cat(a) + black(a) + fierce(a) + def(a) + def(b) + mouse(b) + ] +[ le mechant chat noir chasser le souris ] + +le_chat_noir_chasser_le_souris +semantics : [ chase(e1 a b) + cat(a) + def(a) + black(a) + def(b) + mouse(b) + ] +[ le chat noir chasser le souris ] + +le_chat_chasser_le_souris +semantics : [ chase(e1 a b) + cat(a) + def(a) + def(b) + mouse(b) + ] +[ le chat chasser le souris ] + +le_chat_noir +semantics : [ cat(a) + def(a) + black(a) + ] +[ le chat noir ] diff --git a/examples/demo/README b/examples/demo/README new file mode 100644 --- /dev/null +++ b/examples/demo/README @@ -0,0 +1,48 @@ +--------------------------------------------- +How to do a live demo of GenI with polarities +--------------------------------------------- + +(this is a simplified version of the promettre grammar) + +1) first donnersem; launch the debugger + + 0 - lexical selection - note multiple trees for donner + now we are in the substitution loop + note trees moving from agenda to chart (leap 1 x 3) + 3 - substitution with livre and donner (leap 1 x 2) + 5 - and again with livre - with this newly created tree (leap 1 x 3) + 8 - note the result where all substitutions are done (leap 1) + 9 - now that substitution is finished, we switch to the adjunction + phase (leap 1 x 3) + + 12 - now we try to insert the tree "un" into the trees of the + agenda (leap 1) + 13 - un livre (leap 1 x 3) + 16 - jean donner livre a paul (leap 1) + 17 - and now this is semantically complete so we output the + realisation "Jean donne livre à Paul" + + KEEP THIS DEBUGGER OPEN! + +2) enable the polarity optimisation; + hit generate; + show automaton tab (tiny automota); + launch the debugger + + 0 - notice fewer trees (compare with other debugger; close old debugger) + (leap 2 x 13) + +3) load promettredonnersem; + hit generate + show automaton tab (big automata q vs q pruned) + launch debugger (keep it open) - show few trees + disable optimisation + launch debugger - show many trees + + + + + + + + diff --git a/examples/demo/lexicon b/examples/demo/lexicon new file mode 100644 --- /dev/null +++ b/examples/demo/lexicon @@ -0,0 +1,96 @@ +%% 21 april 2004 +%% French TAG +%% X promet Y a Z +%% Canonique, interrogatives, relatives + + +%% Determinants + +un Det(?I) +semantics:[indef(?I)] + +%% Noms communs + +livre nC(?I) +semantics:[book(?I)] + +%% Noms Propres + +Marie nP(?I) +semantics:[marie(?I)] + +Claire nP(?I) +semantics:[claire(?I)] + +Olivier nP(?I) +semantics:[olivier(?I)] + +Pierre nP(?I) +semantics:[pierre(?I)] + +Jean nP(?I) +semantics:[jean(?I)] + +Paul nP(?I) +semantics:[paul(?I)] + +%% --------------------------------------------------------------------- +%% Verbs +%% --------------------------------------------------------------------- + +donner vinfn1sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner n0vn1sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner qu0vn1sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner qu1vn0sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner qu2n0vn1(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner rel0vn1sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner rel1vn0sp2(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] +donner rel2n0vn1(?E ?X ?Y ?Z) +semantics:[give(?E ?X ?Y ?Z)] + +promettre n0vn1sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre vinfn1sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre qu0vn1sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre qu1vn0sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre qu2n0vn1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre rel0vn1sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre rel1vn0sp2(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre rel2n0vn1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre n0vsp2pinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre vinfsp2pinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre qu0vsp2pinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre qu2n0vpinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre rel0vsp2pinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] +promettre rel2n0vpinf1(?E ?X ?Y ?Z) +semantics:[promise(?E ?X ?Y ?Z)] + +persuade n0vn2pinf1(?E ?X ?Y ?Z) +semantics:[convince(?E ?X ?Y ?Z)] +persuade qu0vn2pinf1(?E ?X ?Y ?Z) +semantics:[convince(?E ?X ?Y ?Z)] +persuade qu2n0vpinf1(?E ?X ?Y ?Z) +semantics:[convince(?E ?X ?Y ?Z)] +persuade rel0vn2pinf1(?E ?X ?Y ?Z) +semantics:[convince(?E ?X ?Y ?Z)] +persuade rel1n0vn2(?E ?X ?Y ?Z) +semantics:[convince(?E ?X ?Y ?Z)] diff --git a/examples/demo/macros b/examples/demo/macros new file mode 100644 --- /dev/null +++ b/examples/demo/macros @@ -0,0 +1,439 @@ +%% 02 april 2004 +%% 1. Jean promet un cadeau a Marie +%% 2. Jean promet a Marie de partir +%% 3. Qui promet un cadeau a Marie? +%% 4. Que promet Jean a Marie? +%% 5. A qui Jean promet-il un cadeau? +%% 6. la personne qui promet un cadeau a Marie +%% 7. le cadeau que Jean promet a Marie +%% 8. la personne a qui Jean promet un cadeau +%% 9. promettre un cadeau a Marie +%% 10. promettant un cadeau a Marie +%% 11. donner un livre a marie + +Det(?I) auxiliary +n1[cat:n idx:?I det:_ qu:minus]![cat:n idx:?I det:_ qu:minus] +{ + n2 anchor [cat:det]![] + n4 type:foot [cat:n idx:?I det:_ qu:_ ]![cat:n idx:?I det:minus qu:_ ] +} + + % Common Nouns: voyage +nC(?I) initial + n1 anchor [cat:n idx:?I det:_ qu:?W ]![cat:n idx:?I det:minus qu:minus ] +% Proper Nouns: Jean + +nP(?I) initial + n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] + + %1 declarative gn promet gn sp_a +n0vn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n6[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } +} + + %2 infinitive V GN SP_a +vinfn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n5[cat:sp idx:?Z det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } +} + + %3 question sujet qui V GN GP_a ? +qu0vn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n6[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + } +} + + %4 question objet +qu1vn0sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y det:_ qu:plus ] + n3[cat:p idx:?E]![] + { + n4 anchor [cat:v idx:?E]![idx:?E] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X + det:_ qu:_ ] + n7[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_] + } + } +} + + %5 question objet indirect +qu2n0vn1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2[cat:sp idx:?Z det:plus]![det:_ ] + { n3[cat:prep]![] + { + n4 type:lex "a" + } + n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n6[cat:p idx:?E]![] + { + n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n8 anchor [cat:v idx:?E]![idx:?E] + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + } +} + +%6 relative sujet qui V gn sp_a +rel0vn1sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n7[cat:sp idx:?Z ]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }}} + +%7 relative objet +rel1vn0sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n7[cat:sp idx:?Z ]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + } +} + +%8 relative objet indirect +rel2n0vn1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![det:_ ] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n9 anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + } + } +} + + %9 declarative GN V GN_a Pinf_de +n0vsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Y det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] + } +} + + %10 infinitive V SP_a Inf_de +vinfsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![idx:?Y mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4[cat:sp idx:?Z det:plus]![det:_ ] + { n5[cat:prep]![] + { + n6 type:lex "a" + } + n7 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } + n8[cat:p]![] + {n9[cat:prep]![] + { + n10 type:lex "de" + } + n11 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + } +} + + %11 question sujet qui V GP_a Pinf_de ? +qu0vsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Z det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }} + + %12 question objet indirect +qu2n0vpinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2[cat:sp idx:?Z det:plus]![det:_ ] + { n3[cat:prep]![] + { + n4 type:lex "a" + } + n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n6[cat:p idx:?E]![] + { + n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n8 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] +} + +%13 relative sujet qui V sp_a pinf_de +rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6[cat:sp idx:?Z ]![] + { n7[cat:prep]![] + { + n8 type:lex "a" + } + n9 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }}} + +%14 relative objet indirect a qui GN v Pinf_de +rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![det:_ ] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n9 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] + } + }} + + + %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 +n0vn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] + } +} + + %15 infinitive persuader gn pinf_de vinfn2pinf1 +vinfn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?Y mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:_ qu:_] + n5[cat:p]![] + {n6[cat:prep]![] + { + n7 type:lex "de" + } + n8 type:subst [cat:p idx:?Z mode:inf sujidx:?Y]![cat:p idx:?Z + mode:_ sujidx:_] + } +} + + %16 qu-sujet qui persuade gn pinf_de ? qu0vn2pinf1 +qu0vn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }} + + %17 qu-obj qui gn persuade-il pinf_de ? qu2n0vpinf1 +qu2n0vpinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + n3[cat:p idx:?E]![] + { + n4 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n5 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] +} + +%18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 +rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + n7[cat:p]![] + {n8[cat:prep]![] + { + n9 type:lex "de" + } + n10 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] + }}} + +%19 rel-obj n dont gn persuade gn rel1n0vn2 +rel1n0vn2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?Y det:plus qu:_]![cat:c idx:?Y det:_ qu:_] + n4[cat:p idx:?E]![] + { + n5 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n6 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:_ qu:minus ] + } +} + diff --git a/examples/demo/suite b/examples/demo/suite new file mode 100644 --- /dev/null +++ b/examples/demo/suite @@ -0,0 +1,19 @@ +donner + semantics : [ jean(a) + give(e2 a c d) + indef(c) + book(c) + paul(d) + ] + +promettre_donner + semantics : [ promise(e1 a b e2) + jean(a) + marie(b) + give(e2 a c d) + indef(c) + book(c) + paul(d) + ] + + diff --git a/examples/ej/lexicon b/examples/ej/lexicon new file mode 100644 --- /dev/null +++ b/examples/ej/lexicon @@ -0,0 +1,100 @@ +%% +%% The LEXICON +%% +%% +%% Nouns +%% common nouns +%% (hat, man, rabbit, woman) +%% proper names +%% (mia, vincent) +%% Verbs +%% intransitive verbs +%% (runs, sleeps) +%% transitive verbs +%% (loves, removes) +%% Modifiers +%% adjectives +%% (big, tall, white) +%% adverbs +%% (fast) +%% Determiners +%% (a, the) + + +%% Nouns +%% common nouns + +hat Cn(?Entity ! agr:sg3) +semantics:[hat(_ ?Entity)] + +man Cn(?Entity ! agr:sg3) +semantics:[man(_ ?Entity)] + +rabbit Cn(?Entity ! agr:sg3) +semantics:[rabbit(_ ?Entity)] + +woman Cn(?Entity ! agr:sg3) +semantics:[woman(_ ?Entity)] + + +%% proper names + +Mia Pn(?Entity ! agr:sg3) +semantics:[name(_ ?Entity mia)] + +Vincent Pn(?Entity ! agr:sg3) +semantics:[name(_ ?Entity vincent)] + +Vinny Pn(?Entity ! agr:sg3) +semantics:[name(_ ?Entity vincent)] + +Émilie Pn(?Entity ! agr:sg3) +semantics:[name(_ ?Entity émilie)] + + +%% Verbs +%% intransitive verbs + +runs vArity1(?Event ?Agent ! agr:sg3) +semantics:[run(?Event ?Agent)] + +gallops vArity1(?Event ?Agent ! agr:sg3) +semantics:[run(?Event ?Agent)] + +sleeps vArity1(?Event ?Agent ! agr:sg3) +semantics:[sleep(?Event ?Agent)] + +%% transitive verbs + +loves vArity2(?Event ?Agent ?Experiencer ! agr:sg3) +semantics:[love(?Event ?Agent ?Experiencer)] + +removes vArity3(?Event ?Agent ?Theme ?Loc ! agr:sg3) +semantics:[remove(?Event ?Agent ?Theme ?Loc)] + + +%% Modifiers +%% adjectives + +big Adj(?Entity) +semantics:[big(_ ?Entity)] + +tall Adj(?Entity) +semantics:[tall(_ ?Entity)] + +white Adj(?Entity) +semantics:[white(_ ?Entity)] + + +%% adverbs + +fast Adv(?Event) +semantics:[fast(_ ?Event)] + + +%% ?Determiners + +%a Dp(?Entity ! agr:sg3) + +the Dp(?Entity) +semantics:[def(?Entity)] diff --git a/examples/ej/macros b/examples/ej/macros new file mode 100644 --- /dev/null +++ b/examples/ej/macros @@ -0,0 +1,92 @@ +%% +%% Tree Templates +%% +%% +%% INITIAL TREES +%% s trees +%% (IntrV, TrV, TrVPP) +%% np trees +%% (Dp, Pn) +%% n trees +%% (Cn) +%% +%% AUXILIARY TREES +%% n trees +%% (Adj) +%% vp trees +%% (Adv) + + +%% INITIAL TREES + +vArity1:IntrV(?Event ?Agent ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent]![] + n3 [cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + } + } + +vArity2:TrV(?Event ?Agent ?Experiencer ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent ]![] + n3[cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + n6 type:subst [cat:np idx:?Experiencer ]![] + } + } + +vArity3:TrVPP(?Event ?Agent ?Theme ?Loc ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent ]![] + n3[cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + n6 type:subst [cat:np idx:?Theme ]![] + n7 aconstr:noadj [cat:pp]![] + { + n8[cat:p]![] + { + n9 type:lex "from" + } + n10 type:subst [cat:np idx:?Loc ]![] + } + } + } + +Dp(?Entity ! agr:?A) initial + n1[cat:np idx:?Entity]![] + { + n2 anchor [cat:det]![] + n4 type:subst [cat:n idx:?Entity ]![] + } + +Pn(?Entity ! agr:?A) initial + n1[cat:np idx:?Entity]![] + { + n2 anchor [cat:pn idx:?Entity]![] + } + +Cn(?Entity ! agr:?A) initial + n1 anchor [cat:n idx:?Entity]![] + +%% ?AUXILIARY ?TREES + +Adj(?Entity) auxiliary + n1[cat:n idx:?Entity]![] + { + n2 anchor [cat:adj]![] + n4 type:foot [cat:n idx:?Entity ]![] + } + +Adv(?Event) auxiliary + n1[cat:vp idx:?Event]![] + { + n2 type:foot [cat:vp idx:?Event]![] + n3 anchor [cat:adv]![] + } diff --git a/examples/ej/suite b/examples/ej/suite new file mode 100644 --- /dev/null +++ b/examples/ej/suite @@ -0,0 +1,88 @@ +v_runs +semantics: [ name(s1 a vincent) + run(e a) ] +[Vincent runs] +[Vincent gallops] +[Vinny runs] +[Vinny gallops] + +v_loves_m +semantics: [ name(s1 a vincent) + love(e a ex) + name(s2 ex mia)] +[Vincent loves Mia] + +v_loves_e +semantics: [ name(s1 a vincent) + love(e a ex) + name(s2 ex émilie)] +[Vincent loves Émilie] + +v_loves_m_f +semantics : [name(s1 a vincent) + love(e a ex) + fast(s3 e) + name(s2 ex mia)] +[Vincent loves Mia fast] % loves fast?! + +big_tall_man_run +semantics : [def(a) + man(s1 a) + run(e a) + big(s3 a) + tall(s3 a) + ] +[the big tall man runs] + +man_love_m +semantics: [man(s1 a) + def(a) + love(e a ex) + name(s2 ex mia)] +[the man loves Mia] + +man_remove_rabbit +semantics : [man(s1 a) + def(a) + remove(e a ex h) + def(ex) + rabbit(s2 ex) + hat(s3 h) + def(h)] +[the man removes the rabbit from the hat] + +man_remove_white_rabbit_fast +semantics : [man(s1 a) + def(a) + remove(e a ex h) + rabbit(s2 ex) + def(ex) + white(s6 ex) + fast (s5 e) + hat(s3 h) + def(h)] +[the man removes the white rabbit from the hat fast] + +man_remove_rabbit_fast +semantics : [man(s1 a) + remove(e a ex h) + def(a) + fast(s4 e) + rabbit(s2 ex) + def(ex) + hat(s3 h) + def(h)] +[the man removes the rabbit from the hat fast] + +man_remove_rabbit_fast_def +semantics : [man(s1 a) + def(a) + remove(e a ex h) + fast(s4 e) + rabbit(s2 ex) + def(ex) + white(s4 ex) + def(h) + hat(s3 h)] +[the man removes the white rabbit from the hat fast] + diff --git a/examples/nosemantics/README.txt b/examples/nosemantics/README.txt new file mode 100644 --- /dev/null +++ b/examples/nosemantics/README.txt @@ -0,0 +1,19 @@ +in order to make geni work without semantics, +the Geni/.genirc file must set IgnoreSemantics +to true. here is an example .genirc: + +Grammar = examples/media/index + +% True or False +Graphical = True +IgnoreSemantics = True +MaxTrees = 3 + +% Optimisations should be a comma delimited list containing any +% number of the following items: +% Polarised, PolSig, ChartSharing, +% SemFiltered, FootConstraint +% There is also PolOpts (all polarity optimisations) +% and AdjOpts (all adjunction optimisations) + +Optimisations = FootConstraint diff --git a/examples/nosemantics/lexicon b/examples/nosemantics/lexicon new file mode 100644 --- /dev/null +++ b/examples/nosemantics/lexicon @@ -0,0 +1,20 @@ + +reserver n0_v() +reserver n0_v_n1() +dernier adj_substantif() +trop adv_adj() +absolument mod_adv_right() +mercredi enum_n() +six det_det() +la n_la() +soixante-dix-neuf det_n() +type n() +il pro() +cher n_adj() +invalide n_adj() +fort adj_n() +americain n() +auberge n() +Loire np() +Luneville np() +Lyon np() diff --git a/examples/nosemantics/macros b/examples/nosemantics/macros new file mode 100644 --- /dev/null +++ b/examples/nosemantics/macros @@ -0,0 +1,363 @@ +%% +%% GENI Macro +%% This macro was automatically generated by +%% a tagml->macro script, tagml2genimacro.xsl +%% 2005 +%% contact: kow@loria.fr lai@loria.fr + +n() initial +n1 anchor + +{ +} + +pro() initial +n1 anchor + +{ +} + +pro_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +det_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +n_la() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +det_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +det_det() auxiliary +n1 [cat:det]![cat:det] +{ +n1.1 type:foot [cat:det]![cat:det] +n1.2 anchor +} + +np() initial +n1 anchor + +{ +} + +np_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +n_np() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_con_n() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +enum_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_pred() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +compl_n() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 [cat:cdn]![cat:cdn] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +adj() initial +n1 anchor + +{ +} + +adj_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +adv_adj() auxiliary +n1 [cat:adj]![cat:adj] +{ +n1.1 anchor +n1.2 type:foot [cat:adj]![cat:adj] +} + +adj_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +n_adj() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_gp() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +s_gp() auxiliary +n1 [cat:sen]![cat:sen] +{ +n1.1 type:foot [cat:sen]![cat:sen] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +gp_s() auxiliary +n1 [cat:sen]![cat:sen] +{ +n1.1 type:foot [cat:sen]![cat:sen] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +gp() initial +n1 [cat:gp]![cat:gp] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +gpro() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +gpro_n_right() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +n0_v() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +} + +n0_v_n1() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +pro_v() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +} + +pro_v_n1() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +v_inf() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +} + +v_n1_inf() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +n0_v_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:sen]![cat:sen] +} + +pro_v_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +n1.3 type:subst [cat:sen]![cat:sen] +} + +mod_v() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +il_faut_n0() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:lex "il" +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +mod_pro_left() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +qu_est_ce_que() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:sen]![cat:sen] +} + +v_pro() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +} + +v_pro_n() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +n1.3 type:subst [cat:nom]![cat:nom] +} + +v_pro_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +n1.3 type:subst [cat:sen]![cat:sen] +} + +mod_adv_left() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +mod_adv_right() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 type:foot [cat:ver]![cat:ver] +n1.2 anchor +} + +mod_adv() auxiliary +n1 [cat:adv]![cat:adv] +{ +n1.1 anchor +n1.2 type:foot [cat:adv]![cat:adv] +} + +mod_adv_n_left() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +mod_adv_n_right() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +adv() initial +n1 anchor + +{ +} + +entre_np_et_np() initial +n1 [cat:gp]![cat:gp] +{ +n1.1 anchor +n1.2 type:subst [cat:nompropre]![cat:nompropre] +n1.3 type:lex "et" +n1.4 type:subst [cat:nompropre]![cat:nompropre] +} + +int() initial +n1 anchor + +{ +} + diff --git a/examples/promettre/lexicon b/examples/promettre/lexicon new file mode 100644 --- /dev/null +++ b/examples/promettre/lexicon @@ -0,0 +1,78 @@ +%% 21 april 2004 +%% French TAG +%% X promet Y a Z +%% Canonique, interrogatives, relatives + +il pronoun(?H ?X) +semantics:[?H:il(+?X)] + +se clitic(?H ?X) +semantics:[] + +le clitic(?H ?X) +semantics:[] + +%% Determinants + +un Det(?I) +semantics:[_:indef(?I)] + +le Det(?I) +semantics:[_:def(?I)] + +quel DetQ(?I) +semantics:[_:qu(?I)] + +%% Noms communs + +livre nC(?I) +semantics:[book(+?I)] + +cadeau nC(?I) +semantics:[present(+?I)] + +%% Noms Propres + +Claire nP(?I) +semantics:[claire(+?I)] + +Marie nP(?I) +semantics:[mary(+?I)] + +Jean nP(?I) +semantics:[john(+?I)] + +Paul nP(?I) +semantics:[paul(+?I)] + +Pierre nP(?I) +semantics:[peter(+?I)] + +Olivier nP(?I) +semantics:[oliver(+?I)] + + + + +%% --------------------------------------------------------------------- +%% Verbs +%% --------------------------------------------------------------------- +promettre vArity3(?E ?X ?Y ?Z) +semantics:[+?E:promise(-?X -?Y -?Z)] + +promettre vArity3control(?E ?X ?Y ?Z) +semantics:[+?E:promise( ?X -?Y -?Z)] + +persuader vArity3(?E ?X ?Y ?Z) +semantics:[+?E:convince(-?X -?Y -?Z)] + +persuader vArity3controlObj(?E ?X ?Y ?Z) +semantics:[+?E:convince(-?X -?Y ?Z)] + +donner vArity3(?E ?X ?Y ?Z) +semantics:[+?E:give(-?X -?Y -?Z)] + +aimer vArity2(?E ?X ?Y) +semantics:[+?E:love(-?X -?Y)] + + diff --git a/examples/promettre/macros b/examples/promettre/macros new file mode 100644 --- /dev/null +++ b/examples/promettre/macros @@ -0,0 +1,450 @@ +%% 02 april 2004 +%% 1. Jean promet un cadeau a Marie +%% 2. Jean promet a Marie de partir +%% 6. la personne qui promet un cadeau a Marie +%% 7. le cadeau que Jean promet a Marie +%% 8. la personne a qui Jean promet un cadeau +%% 9. promettre un cadeau a Marie +%% 10. promettant un cadeau a Marie +%% 11. donner un livre a marie + +% FIXME: eric the non-linguist set all cat:p nodes with unspecified mode to FIXME + +Det(?I) auxiliary +n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I qu:minus] +{ + n2 type:anchor [cat:det]![] + n4 type:foot [cat:n idx:?I]![cat:n idx:?I det:minus] +} + +clitic:cl(?H ?X ! idx:?X ) initial +n1 type:anchor [cat:cl idx:?X]![cat:cl idx:?X] {} + +pronoun:pn(?H ?X ! idx:?X num:?Num gen:?Gen pers:?Pers) initial +n1 [cat:n idx:?X num:?Num gen:?Gen pers:?Pers]![cat:n idx:?X] +{ + n2 type:anchor [cat:pn num:?Num gen:?Gen pers:?Pers]![] +} + +% Common Nouns: voyage +nC(?I!num:?Num gen:?Gen) initial +n1 [cat:n num:?Num gen:?Gen idx:?I]![cat:n num:?Num gen:?Gen idx:?I det:minus qu:minus] +{ + n2 type:anchor [cat:n num:?Num gen:?Gen]![] +} + +% Proper Nouns: Jean +nP(?I!pers:?Pers num:?Num gen:?Gen) initial +n1 type:anchor [cat:n num:?Num pers:?Pers gen:?Gen idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] {} + + + +% jean se aimer -- note: we rely on top/bottom unification +% for this to work +vArity2:n0v(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?Y] + n5 [cat:se idx:?X det:plus qu:minus]![cat:se idx:?Y] + n3 type:anchor [cat:v idx:?E]![] +} + +vArity2:n0cl1v(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] + n3 type:anchor [cat:v idx:?E]![] +} + +vArity2:n0vn1(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + +% aimer N (jean espere [aimer Marie]) +vArity2:vinfn1(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + +% le aimer (jean espere [le aimer]) +cl0vinf(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] + n2 type:anchor [cat:v idx:?E]![] +} + +% infinitive: le donner un livre (je promets de le donner un livre) +vArity3:cl2vinfn0(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n5 type:subst [cat:cl idx:?Z det:plus qu:minus]![cat:cl idx:?Z] + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + + %1 declarative gn promet gn sp_a +vArity3:n0vn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n6[cat:sp idx:?Z det:plus]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } +} + + + %2 infinitive ?V GN SP_a +vArity3:vinfn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } +} + +vArity3:n0vn1inf2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X pers:?Pers num:?Num det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:p]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + ] + } + n9 type:subst [cat:p idx:?Y mode:inf]![cat:p idx:?Y] +} + +%8 relative objet indirect +vArity3:rel2n0vn1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus]![cat:n idx:?Z] +{ + n1 type:foot [cat:n idx:?Z]![cat:n idx:?Z] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + } + } +} + + %9 declarative GN V GN_a Pinf_de +vArity3control:n0vsp2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + } +} + + %10 infinitive V SP_a Inf_de +vArity3control:vinfsp2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4[cat:sp idx:?Y det:plus]![] + { n5[cat:prep]![] + { + n6 type:lex "a" + } + n7 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + ] + } + n8[cat:p]![] + {n9[cat:prep]![] + { + n10 type:lex "de" + } + n11 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + + } +} + + % kowey: promettre a marie de faire... +vArity3control:vinfn2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + } +} + + %13 relative sujet qui V sp_a pinf_de +vArity3control:rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6[cat:sp idx:?Y]![] + { n7[cat:prep]![] + { + n8 type:lex "a" + } + n9 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n + ] + } + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + }}} + + +%14 relative objet indirect a qui GN v Pinf_de +vArity3control:rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] +{ + n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] + n2[cat:p]![] + { + n3[cat:sp idx:?Y det:plus]![] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] + } + }} + + +vArity3control:rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n + ] + n7[cat:p]![] + {n8[cat:prep]![] + { + n9 type:lex "de" + } + n10 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] + }}} + +% relative sujet +vArity3control:rel0vn1sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n7[cat:sp idx:?Y]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] + } + } +} + +% relative objet +vArity3control:rel1vn0sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n7[cat:sp idx:?Y]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] + } + } +} + + % relative objet indirect +rel2vn0n1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] +{ + n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] + n2[cat:p]![] + { + n3[cat:sp idx:?Y det:plus]![] + { n4[cat:p]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + } +} + + % kowey: for persuader instead of promettre + % (sujidx is set differently) +vArity3controlObj:n0vsp2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 +vArity3controlObj:n0vn2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %15 infinitive persuader gn pinf_de vinfn2pinf1 +vArity3controlObj:vinfn2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n5[cat:p]![] + {n6[cat:prep]![] + { + n7 type:lex "de" + } + n8 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 +vArity3controlObj:n0vn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n6[cat:sp idx:?Z det:plus]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + ] + } +} + +% vi: set cinoptions=0,p0: + + diff --git a/examples/promettre/morphinfo b/examples/promettre/morphinfo new file mode 100644 --- /dev/null +++ b/examples/promettre/morphinfo @@ -0,0 +1,33 @@ +% associates predicates with feature structures which will be +% unified with the anchor node +% +% Note: if you want to specify features for certain lexical entries +% via the syntactic lexicon, you should do it through the +% interface. This means you'll have to modify your trees so +% that they export the relevant features through their +% interface +% +% john [gender:m] +% mary [gender:f] +% +% since we already have a mechanism for applying fs via the +% syntactic lexicon, i figured we could just keep things +% consistent +% +% the idea is that if you have plural(p) +% then this applies to any tree for which p is the first index + +male [gen:m] +female [gen:f] + +plural [num:pl] +singular [num:sg] + +past [tense:past] +future [tense:future] + +% -------------------------------------------------------------------- +% output features +% -------------------------------------------------------------------- +% + diff --git a/examples/promettre/suite b/examples/promettre/suite new file mode 100644 --- /dev/null +++ b/examples/promettre/suite @@ -0,0 +1,113 @@ +il_aime_marie +semantics:[h2:mary(m) + h1:il(j) + e1:love(j m)] +[ il aimer Marie ] + +jean_aime_marie +semantics:[h1:john(j) + h2:mary(m) + e1:love(j m)] +[ Jean aimer Marie ] + +jean_aime_le_livre +semantics:[h1:john(j) + h2:book(l) h2:def(l) + e1:love(j l)] +[ Jean aimer le livre ] + +jean_s_aime +semantics:[h1:john(j) + e1:love(j j)] +[ Jean se aimer ] + +%jean_promet_marie_de_l'aimer +%semantics:[h1:john(j) +% h2:mary(m) +% e1:love(j m) +% e2:promise(j e1 m)] +%[ Jean promettre a Marie de le aimer ] +%[ Jean promettre Marie de le aimer ] + +jean_donne_un_livre_a_marie +semantics:[john(j) + mary(m) + book(b) indef(b) + give(j b m)] +%[ Jean donner a Marie un livre ] +[ Jean donner un livre a Marie ] + +jean_promet_a_marie_de_donner_un_livre_a_Claire +semantics:[john(j) + mary(m) + book(b) indef(b) + claire(c) + e1:give(j b c) + promise(j e1 m) ] +[ Jean promettre a Marie de donner un livre a Claire ] + +jean_promet_a_Marie_de_le_donner_un_livre +semantics:[john(j) + mary(m) + book(b) indef(b) + e1:give(j b m) + promise(j e1 m) ] +[ Jean promettre a Marie de le donner un livre ] + +%semantics:[h1:john(j) +% h2:mary(m) +% h3:book(b) h3:indef(b) +% h4:paul(p) +% e1:give(j b p) +% e2:promise(j e1 m) +% e3:convince(p e2 j) ] +%[ Paul persuader Jean de promettre a Marie de le donner un livre ] + +promettre +semantics : [ h1:def(b) + h1:present(b) + e:promise(a b c) + mary(a) + john(c) + ] + +promettre_donner +semantics : [ e1:promise(a e2 b) + john(a) + mary(b) + e2:give(a c d) + h1:indef(c) + h1:book(c) + paul(d) + ] + +promettre_donner_persuader +semantics : [ e1:promise(a e2 b) + john(a) + mary(b) + e2:convince(a e3 d) + e3:give(d c e) + h3:indef(c) + h3:book(c) + paul(d) + claire(e) + ] + +% "Jean promet a Marie de persuader Paul de persuader Pierre de +% persuader Olivier de donner +% un livre a Claire" +pr_per_per_per_do +semantics : [ e1:promise(a e2 b) + john(a) + mary(b) + e2:convince(a e3 d) + paul(d) + e3:convince(d e4 e) + peter(e) + e4:convince(e e5 o) + oliver(o) + e5:give(o l f) + h1:indef(l) + h1:book(l) + claire(f) + ] diff --git a/examples/xmg-example/Makefile b/examples/xmg-example/Makefile new file mode 100644 --- /dev/null +++ b/examples/xmg-example/Makefile @@ -0,0 +1,138 @@ +SHELL=/bin/sh +GENI:=geni + +COMPILED_GRAMMAR_DIR:=compiled-grammar +GRAMMAR_DIR:=grammar +GRAMMAR:=Evaluations +GRAMMAR_RAW_MG:=$(GRAMMAR_DIR)/$(GRAMMAR).mg + +LEXICON_DIR:=lexicon +FULL_LEXICON_PREFIX:=demo-lemma-latin1 +MORPH_PREFIX:=demo-morph-latin1 + +MACROS_FILE:=macros.mac + +SUITE_LEXICON:=$(LEXICON_DIR)/$(FULL_LEXICON_PREFIX).lex +SUITE_MORPH:=$(LEXICON_DIR)/$(MORPH_PREFIX).mph + +GENI_GRAMMAR:=$(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).genib +GENI_LEXICON:=$(LEXICON_DIR)/$(FULL_LEXICON_PREFIX).glex +GENI_MORPH:=$(LEXICON_DIR)/$(MORPH_PREFIX).gmorph +GENI_SUITE:=suite + +GENI_OPTIMISATIONS:='pol f-sem f-root' + +GENI_LEX_FLAGS:=-l $(GENI_LEXICON) -s $(GENI_SUITE) +ifdef ENABLE_MORPH +GENI_LEX_FLAGS+=--morphlexicon $(GENI_MORPH) +endif +GENI_FLAGS:=$(GENI_LEX_FLAGS) --opt=$(GENI_OPTIMISATIONS) + +# -------------------------------------------------------------------- +# main targets, etc +# -------------------------------------------------------------------- + +all: run + +ECHO_STATUS:=@echo "[XMG/GenI demo]" +ifndef VERBOSE +SILENTLY:=@ +endif + +mg_files := $(wildcard $(GRAMMAR_DIR)/*.mg) + +.PHONY: all macros run grammar morph clean + +grammar: $(GENI_GRAMMAR) +lexicon: $(GENI_LEXICON) +morph: $(GENI_MORPH) +macros: $(LEXICON_DIR)/$(MACROS_FILE) + + +# -------------------------------------------------------------------- +# demo stuff +# -------------------------------------------------------------------- + +NEW_SUMMARY:=new-summary +OLD_DERIVATIONS:=old-derivations +NEW_DERIVATIONS_ORIG:=tmp-derivations +NEW_DERIVATIONS:=new-derivations + +run: $(GENI_GRAMMAR) lexicon morph + $(GENI) -m $< $(GENI_FLAGS) --nogui --batchdir=results + +# -------------------------------------------------------------------- +# running GenI +# -------------------------------------------------------------------- + +run-geni: $(GENI_GRAMMAR) lexicon morph + $(GENI) -m $< $(GENI_FLAGS) + +$(SUITE_DIR_GENI)/.geni-input: + $(NO_SUITE_ERROR) + +# -------------------------------------------------------------------- +# cleaning +# -------------------------------------------------------------------- + +clean: + rm -rf $(COMPILED_GRAMMAR_DIR)/* + rm -rf $(LEXICON_DIR)/*.gmorph $(LEXICON_DIR)/*.glex $(LEXICON_DIR)/macros.mac $(LEXICON_DIR)/macros.lin $(GRAMMAR_DIR)/macros.mac $(GRAMMAR_DIR)/macros.lin + rm -rf results/* + +# -------------------------------------------------------------------- +# grammar +# -------------------------------------------------------------------- + +# remove double entries +%.rec: %.tmprec + $(ECHO_STATUS) removing double-entries to produce $@ + $(SILENTLY) CheckTAG $< --all -c $@ -o $(basename $@).xml + +# compile the grammar +$(COMPILED_GRAMMAR_DIR)/%.tmprec: $(GRAMMAR_DIR)/%.mg + $(ECHO_STATUS) compiling metagrammar $< + $(SILENTLY) MetaTAG $< --chk -c $@ + +$(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).rec: $(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).tmprec +$(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).tmprec: $(mg_files) + +# -------------------------------------------------------------------- +# grammar converted to geni format +# -------------------------------------------------------------------- + +%.xml : %.rec + : + +$(COMPILED_GRAMMAR_DIR): + mkdir $@ + +%.geni : %.xml + $(ECHO_STATUS) "converting to geni text format: $(basename $<)" + $(SILENTLY) geniconvert -f tagml -t geni $< -o $@ + +%.genib : %.geni + $(ECHO_STATUS) "converting to geni binary format: $<" + $(SILENTLY) geniconvert -f geni -t genib $< -o $@ + +# -------------------------------------------------------------------- +# lexicon +# -------------------------------------------------------------------- +# compile semantic macros from SemVal.mg +# see the GNU make manual on implicit rules/automatic variables +# for $( $@ diff --git a/examples/xmg-example/README b/examples/xmg-example/README new file mode 100644 --- /dev/null +++ b/examples/xmg-example/README @@ -0,0 +1,8 @@ +This is a small demo using GenI with the rest of the SemTAG toolkit. +You'll need to install: + XMG + the various XMG-TOOLS (namely CHECKER) + lexConverter + +But otherwise, it should just be a matter of running: + make diff --git a/examples/xmg-example/grammar/Arguments.mg b/examples/xmg-example/grammar/Arguments.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/Arguments.mg @@ -0,0 +1,146 @@ +class VerbalArgument +export + ?xS ?xV +declare + ?xS ?xV +{ + { + node ?xS(color=white)[cat = s]{ + node ?xV(color=white)[cat = v] + } + } +} + +class SubjectAgreement +export + ?xSubjAgr ?xVAgr +declare + ?xSubjAgr ?xVAgr ?fX ?fY ?fZ +{ + { + node ?xSubjAgr[top=[num = ?fX, gen = ?fY, pers = ?fZ]]; + node ?xVAgr[top=[num = ?fX, gen = ?fY, pers = ?fZ]] + } +} + +class CanSubject +import + VerbalArgument[] + SubjectAgreement[] +export + ?xSubj +declare + ?xSubj +{ + { + node ?xS[cat = s]{ + node ?xSubj(color=red)[cat = @{cl,n}] + node ?xV[cat = v] + }; + ?xSubj = ?xSubjAgr; + ?xV = ?xVAgr + } +} + +class CanonicalSubject +import + CanSubject[] + SubjectSem[] +{ + { + node ?xSubj(color=red,mark=subst)[cat = n] + }; + ?xSubj = ?xSem +} + +class CliticSubject +import + CanSubject[] + SubjectSem[] +{ + { + node ?xSubj(color=red,mark=subst)[cat = cl] + }; + ?xSubj = ?xSem +} + +class RelativeSubject +import + VerbalArgument[] + SubjectAgreement[] + SubjectSem[] +declare + ?xSubj ?xfoot ?xRel ?fU ?fY ?fZ ?xQui +{ + { + node ?xRel(color=red)[cat = n,bot=[num = ?fY,gen = ?fZ,pers = ?fU]]{ + node ?xfoot(color=red,mark=foot)[cat=n,top=[num = ?fY,gen = ?fZ,pers = ?fU]] + node ?xS(mark=nadj){ + node ?xSubj(color=red,extracted = +)[cat=c]{ + node ?xQui(color=red,mark=flex)[cat=qui] + } + node ?xV + } + } + }; + ?xfoot = ?xSubjAgr; + ?xV = ?xVAgr; + ?xfoot = ?xSem +} + +class CanonicalObject +import + VerbalArgument[] + ObjectSem[] +export + ?xObj +declare + ?xObj +{ + { + node ?xS{ + node ?xV + node ?xObj(mark=subst, color=red)[cat = n] + } + }; + ?xObj = ?xSem +} + +class CanonicalCAgent +import + VerbalArgument[] + CAgentSem[] +export + ?xtop ?xArg ?xX +declare + ?xtop ?xArg ?xX ?xPrep +{ + { + node ?xtop[cat = pp](color=red){ + node ?xX (color=red)[cat = p] { + node ?xPrep(mark=flex,color=red)[cat=par] + } + node ?xArg(mark=subst,color=red)[cat = n] + } + } ; + ?xArg = ?xSem ; + { ?xS -> ?xtop ; ?xV >> ?xtop } +} + + +class Subject[I,L] +{ + CanonicalSubject[]*=[subjectI = I, subjectL = L] + | RelativeSubject[]*=[subjectI = I, subjectL = L] + | CliticSubject[]*=[subjectI = I, subjectL = L] +} + +class Object[I,L] +{ + CanonicalObject[]*=[objectI = I, objectL = L] +} + +class CAgent[I,L] +{ + CanonicalCAgent[]*=[cagentI = I, cagentL = L] +} diff --git a/examples/xmg-example/grammar/Entete.mg b/examples/xmg-example/grammar/Entete.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/Entete.mg @@ -0,0 +1,65 @@ +% ------------------------------------------------------- +% A FRENCH TOY METAGRAMMAR +% ------------------------------------------------------- +% +% date = january 2007 +% +% +% Demo MetaGrammar inspired by B. Crabbe and C. Gardent French TAG +% +% +% ASSOCIATED FILES (for SemConst): +% demo.lex : lemma database +% demo.mph : morphological database +% +% +% Contact: parmenti@loria.fr +% +% ------------------------------------------------------- + + +%% Principles instanciation + +use color with () dims (syn) +use unicity with (extracted = +) dims (syn) + +%% Type declarations + +type CAT={n,np,v,vn,s,pp,c,p,cl,par,qui} +type PERSON=[1..3] +type GENDER={m,f} +type NUMBER={sg,pl} +type MODE={ind,subj} + +type MARK={subst,foot,none,nadj,anchor,coanchor,flex} +type COLOR ={red,black,white} + +type LABEL ! +type IDX ! + +%% Property declarations + +property color : COLOR +property mark : MARK +property extracted : bool + +%% Feature declarations + +feature cat : CAT +feature gen : GENDER +feature num : NUMBER +feature pers : PERSON +feature mode : MODE + +feature idx : IDX +feature label: LABEL + +%%%%%%%%%%%%%%%%%%% +% MUTUAL EXCLUSION +%%%%%%%%%%%%%%%%%%% +% +% (functionality not used in this toy metagrammar) +% +% mutex MUTEX-SET1 %% Mutex declaration +% mutex MUTEX-SET1 += Class1 %% Mutex filling +% mutex MUTEX-SET1 += Class2 diff --git a/examples/xmg-example/grammar/Evaluations.mg b/examples/xmg-example/grammar/Evaluations.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/Evaluations.mg @@ -0,0 +1,21 @@ +%%%%%%% Included files + +include Entete.mg +extern rel theta1 theta2 theta3 + +include VerbMorph.mg +include Arguments.mg +include Misc.mg +include Sem.mg + +semantics basicProperty unaryRel binaryRel SubjectSem ObjectSem CAgentSem nSem + +%%%%%%% Valuations + +value n0V +value n0Vn1 + +value Copule +value propername +value Clitic + diff --git a/examples/xmg-example/grammar/Misc.mg b/examples/xmg-example/grammar/Misc.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/Misc.mg @@ -0,0 +1,32 @@ +class propername +import + nSem[] +declare + ?xN +{ + { + node xN(color=red,mark=anchor)[cat = n,bot=[pers = 3]] + }; + ?xN = ?xSem +} + +class Copule +declare + ?xV +{ + { + node xV(color=red,mark=anchor)[cat = v] + } +} + +class Clitic +import + nSem[] +declare + ?xCl +{ + { + node xCl(color=red,mark=anchor)[cat = cl] + }; + ?xCl = ?xSem +} diff --git a/examples/xmg-example/grammar/Sem.mg b/examples/xmg-example/grammar/Sem.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/Sem.mg @@ -0,0 +1,80 @@ +%% Semantic classes +class basicProperty +export ?E ?L0 ?Rel +declare ?E ?L0 ?Rel + { + { + L0:Rel(E) + } + *=[label0 = L0, rel =Rel,arg0=E] + } + +% unary relation with event variable +class unaryRel +import basicProperty[] +declare ?X ?Theta1 + { + { + L0:Theta1(E,X) + } + *=[arg1=X,theta1 =Theta1] + } + +% binary relation with event variable +class binaryRel +import unaryRel[] +declare ?X ?Theta2 + { + { + L0:Theta2(E,X) + } + *=[arg2=X,theta2 =Theta2] + } + +% Verb arguments +class SubjectSem +export + ?xSem +declare + ?xSem ?X ?L +{ + { + node xSem[top=[idx=X,label=L]] + }*=[subjectI = X,subjectL = L] +} + +class ObjectSem +export + ?xSem +declare + ?xSem ?X ?L +{ + { + node xSem[top=[idx=X,label=L]] + }*=[objectI = X,objectL = L] +} + +class CAgentSem +export + ?xSem +declare + ?xSem ?X ?L +{ + { + node xSem[top=[idx=X,label=L]] + }*=[cagentI = X,cagentL = L] +} + +%% Noun semantics +class nSem +export + ?xSem +declare + ?xSem ?X ?L +{ + { + node ?xSem[cat=@{cl,n},top=[idx=X, label=L]] + }; + basicProperty[]*=[arg0=X] +} + diff --git a/examples/xmg-example/grammar/VerbMorph.mg b/examples/xmg-example/grammar/VerbMorph.mg new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/VerbMorph.mg @@ -0,0 +1,78 @@ +class VerbalMorphology +export + ?xS ?xVN ?xV +declare + ?xS ?xVN ?xV ?I ?L +{ + { + node ?xS(color=black)[cat = s, top = [mode=ind]]{ + node ?xVN(color=black)[cat = v]{ + node ?xV(mark=anchor,color=black)[cat = v,top = [idx=I,label=L]] + } + } + }*=[vbI=I,vbL = L] +} + +class activeVerbMorphology +import + VerbalMorphology[] +declare + ?fY ?fZ ?fW +{ + { + node ?xVN[bot=[num = ?fY,gen = ?fZ,pers=?fW]]{ + node ?xV[top=[num = ?fY,gen = ?fZ,pers=?fW]] + } + } +} + +class passiveVerbMorphology +import + VerbalMorphology[] +export + ?xInfl +declare + ?xInfl ?fX ?fY ?fZ +{ + { + node ?xVN[bot=[num = ?fX, gen = ?fY, pers = ?fZ]]{ + node ?xInfl(color=black,mark=subst)[cat = v,top=[num = ? +fX, gen = ?fY, pers = ?fZ]] + node ?xV(color=black)[cat = v] + } + } +} + +class dian0Vactive[L,E,X] +{ + Subject[X,L] + ; activeVerbMorphology[]*=[vbI=E,vbL = L] +} + +class dian0Vn1Active[L,E,X,Y] +{ + dian0Vactive[L,E,X] + ; Object[Y,L] +} + +class dian0Vn1Passive[L,E,X,Y] +{ + Subject[Y,L] + ; CAgent[X,L] + ; passiveVerbMorphology[]*=[vbI=E,vbL = L] +} + +class n0V[L,E,X] +{ + unaryRel[]*=[label0=L,arg0=E,arg1=X]; + dian0Vactive[L,E,X] +} + +class n0Vn1[L,E,X,Y] +{ + binaryRel[]*=[label0=L,arg0=E,arg1=X,arg2=Y] ; + { + dian0Vn1Active[L,E,X,Y] + | dian0Vn1Passive[L,E,X,Y] + } +} diff --git a/examples/xmg-example/grammar/demo-corpus-latin1.txt b/examples/xmg-example/grammar/demo-corpus-latin1.txt new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/demo-corpus-latin1.txt @@ -0,0 +1,6 @@ +Jean aime Marie. +Jean est appelé par Marie. +Marie aime Jean. +Marie appelle. +Jean qui appelle aime Marie. +ils appellent. diff --git a/examples/xmg-example/grammar/parse-corpus.sh b/examples/xmg-example/grammar/parse-corpus.sh new file mode 100644 --- /dev/null +++ b/examples/xmg-example/grammar/parse-corpus.sh @@ -0,0 +1,16 @@ +#!/bin/sh +# shell script containing the command line options +# to use the SemConst in interactive mode +# february 2007 +# contact: parmenti@loria.fr + +PWD=`pwd` +RESOURCE_DIR=`dirname $PWD` + +cd $RESOURCE_DIR +./SemConst.exe --interactive\ + -g ${RESOURCE_DIR}/demo/Evaluations.mg\ + -l ${RESOURCE_DIR}/demo/demo-lemma-latin1.lex\ + -m ${RESOURCE_DIR}/demo/demo-morph-latin1.mph\ + -c ${RESOURCE_DIR}/demo/demo-corpus-latin1.txt\ + -w diff --git a/examples/xmg-example/lexicon/demo-lemma-latin1.lex b/examples/xmg-example/lexicon/demo-lemma-latin1.lex new file mode 100644 --- /dev/null +++ b/examples/xmg-example/lexicon/demo-lemma-latin1.lex @@ -0,0 +1,113 @@ +include macros.mac + +*ENTRY: aimer +*CAT: v +*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient] +*ACC: 1 +*FAM: n0Vn1 +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> aux = avoir +anc -> aux-refl = - +*COANCHORS: + +*ENTRY: aimer +*CAT: v +*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient] +*ACC: 1 +*FAM: n0Vn1 +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> aux = etre +anc -> aux-refl = + +*COANCHORS: + +*ENTRY: appeler +*CAT: v +*SEM: unaryRel[theta1=agent,rel=appeler] +*ACC: 1 +*FAM: n0V +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> aux = avoir +anc -> aux-refl = - +*COANCHORS: + +*ENTRY: appeler +*CAT: v +*SEM: binaryRel[theta1=agent,rel=appeler,theta2=patient] +*ACC: 1 +*FAM: n0Vn1 +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> aux = avoir +anc -> aux-refl = - +*COANCHORS: + +*ENTRY: etre +*CAT: v +*SEM: +*ACC: 1 +*FAM: Copule +*FILTERS: [] +*EX: {} +*EQUATIONS: +*COANCHORS: + +*ENTRY: il +*CAT: cl +*SEM: basicProperty[rel=il] +*ACC: 1 +*FAM: Clitic +*FILTERS: [] +*EX: {} +*EQUATIONS: +*COANCHORS: + +*ENTRY: jean +*CAT: n +*SEM: basicProperty[rel=jean] +*ACC: 1 +*FAM: propername +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> gen = m +anc -> det = + +*COANCHORS: + +*ENTRY: marie +*CAT: n +*SEM: basicProperty[rel=marie] +*ACC: 1 +*FAM: propername +*FILTERS: [] +*EX: {} +*EQUATIONS: +anc -> gen = f +anc -> det = + +*COANCHORS: + +*ENTRY: par +*CAT: p +*SEM: +*ACC: 1 +*FAM: void +*FILTERS: [] +*EX: {} +*EQUATIONS: +*COANCHORS: + +*ENTRY: qui +*CAT: c +*SEM: +*ACC: 1 +*FAM: void +*FILTERS: [] +*EX: {} +*EQUATIONS: +*COANCHORS: diff --git a/examples/xmg-example/lexicon/demo-morph-latin1.mph b/examples/xmg-example/lexicon/demo-morph-latin1.mph new file mode 100644 --- /dev/null +++ b/examples/xmg-example/lexicon/demo-morph-latin1.mph @@ -0,0 +1,24 @@ +aime aimer [pos = v; mode = ind; pers = 1; num = sg;] +aime aimer [pos = v; mode = ind; pers = 3; num = sg;] +aiment aimer [pos = v; mode = ind; pers = 3; num = pl;] +aimé aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = m;] +aimée aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = f;] +appelle appeler [pos = v; mode = ind; pers = 1; num = sg;] +appelle appeler [pos = v; mode = ind; pers = 3; num = sg;] +appellent appeler [pos = v; mode = ind; pers = 3; num = pl;] +appelé appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = m;] +appelée appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = f;] +elle il [pos = cl; refl = -; pers = 3; gen = f; num = sg;] +elle lui [pos = cl; refl = -; pers = 3; gen = f; num = sg;] +elle moi [pos = n; gen = f; num = sg;] +elles il [pos = cl; refl = -; pers = 3; gen = f; num = pl;] +elles lui [pos = cl; refl = -; pers = 3; gen = f; num = pl;] +elles moi [pos = n; pers = 3; gen = f; num = pl] +est etre [pos = v; mode = ind; pers = 3; num = sg;] +es etre [pos = v; mode = ind; pers = 2; num = sg;] +il il [pos = cl; refl = -; pers = 3; gen = m; num = sg;] +ils il [pos = cl; refl = -; pers = 3; gen = m; num = pl;] +jean jean [pos = n; det = +; gen = m; num = sg;] +marie marie [pos = n; pers = 3; gen = f; num = sg;] +par par [pos = p;] +qui qui [pos = c;] diff --git a/examples/xmg-example/suite b/examples/xmg-example/suite new file mode 100644 --- /dev/null +++ b/examples/xmg-example/suite @@ -0,0 +1,39 @@ +%% Generated by ../semconst2geni.pl at Thu May 31 18:00:44 2007 +%% Input file : results/demo.geni + +%% 1. jean aime marie +t10 +semantics:[A:aimer(B) A:agent(B C) A:patient(B D) E:jean(C) F:marie(D)] +sentence:[jean aime marie] + + +%% 2. jean est appelé par marie +t20 +semantics:[A:appeler(B) A:agent(B C) A:patient(B D) E:marie(C) F:jean(D)] +sentence:[jean est appelé par marie] + + +%% 3. marie aime jean +t30 +semantics:[A:aimer(B) A:agent(B C) A:patient(B D) E:marie(C) F:jean(D)] +sentence:[marie aime jean] + + +%% 4. marie appelle +t40 +semantics:[A:appeler(B) A:agent(B C) D:marie(C)] +sentence:[marie appelle] + + +%% 5. jean qui appelle aime marie +t50 +semantics:[A:aimer(B) A:agent(B C) A:patient(B D) E:jean(C) F:appeler(G) F:agent(G C) H:marie(D)] +sentence:[jean qui appelle aime marie] + + +%% 6. ils appellent +t60 +semantics:[A:appeler(B) A:agent(B C) D:il(C)] +sentence:[ils appellent] + + diff --git a/macstuff/macosx-app b/macstuff/macosx-app deleted file mode 100644 --- a/macstuff/macosx-app +++ /dev/null @@ -1,114 +0,0 @@ -#!/bin/sh -icnsfile=macstuff/wxmac.icns -infofile=macstuff/Info.plist -bundlename=GenI -rezcomp="/Developer/Tools/Rez -t APPL Carbon.r $rezfile -o" - -#------------------------------------------------------------------------ -# Helper script to create a MacOS X application from a binary. -# Hacked up with lots of GenI-specific stuff. -# Meant to be run from the bin directory directly. -# -# Daan Leijen and Arthur Baars. -# -# Copyright (c) 2003,2004 Daan Leijen, Arthur Baars -#------------------------------------------------------------------------ - -# $Id: macosx-app-template,v 1.4 2005/04/29 14:16:51 dleijen Exp $ -arg="" - -# variables -program="" -verbose="yes" - - -# Parse command-line arguments -while : ; do - # put optional argument in the $arg variable - case "$1" in - -*=*) arg=`echo "$1" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) arg= ;; - esac - - # match on the arguments - case "$1" in - "") break;; - -\?|--help) - echo "usage:" - echo " macosx-app [options] " - echo "" - echo "options: [defaults in brackets]" - echo " --help | -? show this information" - echo " --verbose | -v be verbose" - echo "" - exit 1;; - -v|--verbose) - verbose="yes";; - -*) echo "error: Unknown option \"$1\". Use \"--help\" to show valid options." 1>&2 - echo "" 1>&2 - exit 2;; - *) if test "$program"; then - echo "error: [program] is specified twice. Use \"--help\" to show valid options." 1>&2 - echo ""1>&2 - exit 2 - fi - program="$1";; - esac - shift -done - -# default program -if test -z "$program"; then - echo "error: you need to specify a program. Use \"--help\" to show valid options." 1>&2 - echo "" 1>&2 - exit 2 -fi - -# show when verbose is true. -show() -{ - if test "$verbose" = "yes"; then - echo "$1" - fi -} - -# link with default resources -# this is neccesary only to run the GUI from the command line -if test "$rezcomp"; then - show "creating resource:" - show " > $rezcomp $program" - $rezcomp $program -fi - -# create a bundle -bundle="$program.app/Contents" - -# create bundle directories -show "creating app directories:" -show " - $program.app" -mkdir -p $program.app -show " - $bundle" -mkdir -p $bundle -show " - $bundle/MacOS" -mkdir -p $bundle/MacOS -show " - $bundle/Resources" -mkdir -p $bundle/Resources - -cp -f $program $bundle/MacOS/ - -# copy the icon -cp -f ${icnsfile} $bundle/Resources - -# package info -show "creating package info:" -show " - $bundle/PkgInfo" -echo -n "APPL????" > $bundle/PkgInfo - -# create program information file -cp ${infofile} $bundle/Info.plist - -# tell finder that there's an icon -/Developer/Tools/SetFile -a C $bundle - -show "done." -show "" diff --git a/src/EnableGUI.hs b/src/EnableGUI.hs new file mode 100644 --- /dev/null +++ b/src/EnableGUI.hs @@ -0,0 +1,38 @@ +-- this is just to get the GUI running on my mac, no big deal +-- note: for Observe.lhs: -fglasgow-exts -cpp -package concurrent + +module EnableGUI(enableGUI) where + +import Data.Int +import Foreign +import qualified Main as Main2 + +{- +import Posix +import Concurrent +import Control.Exception +catchCtrlC = do + main_thread <- myThreadId + installHandler sigINT (Catch (hupHandler main_thread)) Nothing + where + hupHandler :: ThreadId -> IO () + hupHandler main_thread + = throwTo main_thread (ErrorCall "Control-C") +-} + +main = do (enableGUI >> Main2.main) + +type ProcessSerialNumber = Int64 + +foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 +foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () +foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () + +enableGUI = alloca $ \psn -> do + getCurrentProcess psn + cgsDefaultConnection + cpsEnableForegroundOperation psn + cpsSignalAppReady psn + cpsSetFrontProcess psn diff --git a/src/MainGeni.lhs b/src/MainGeni.lhs new file mode 100644 --- /dev/null +++ b/src/MainGeni.lhs @@ -0,0 +1,88 @@ +% 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. + +\chapter{Main} + +Welcome to the GenI source code. The main module is where everything +starts from. If you're trying to figure out how GenI works, the main +action is in Geni and Tags +(chapters \ref{cha:Geni} and \ref{cha:Tags}). + +\begin{code} +module Main (main) where +\end{code} + +\ignore{ +\begin{code} +import Data.IORef(newIORef) +import System.Environment(getArgs) + +import NLP.GenI.Geni(emptyProgState) +import NLP.GenI.Console(consoleGeni) +import NLP.GenI.Configuration (treatStandardArgs, processInstructions, + hasFlagP, BatchDirFlg(..), DisableGuiFlg(..), FromStdinFlg(..), + RegressionTestModeFlg(..), RunUnitTestFlg(..), + ) + +#ifndef DISABLE_GUI +import NLP.GenI.Gui(guiGeni) +#else +guiGeni = consoleGeni +#endif +\end{code} +} + +In figure \ref{fig:code-outline-main} we show what happens from main: First, we +hand control off to either the console or the graphical user interface. These +functions then do all the business stuff like loading files and figuring out +what to generate. From there, they invoke the the generation step +\fnref{runGeni} which does surface realisation from A-Z. Alternately, the +graphical interface could invoke a graphical debugger which also does surface +realisation from A-Z but allows you to intervene, inspect and stop at each +step. + +\begin{figure} +\begin{center} +\includegraphics[scale=0.25]{images/code-outline-main} +\label{fig:code-outline-main} +\caption{How the GenI entry point is used} +\end{center} +\end{figure} + +\begin{code} +main :: IO () +main = do + args <- getArgs + confArgs <- treatStandardArgs args >>= processInstructions + let pst = emptyProgState confArgs + pstRef <- newIORef pst + let batch = hasFlagP BatchDirFlg confArgs + console = hasFlagP DisableGuiFlg confArgs + fromstdin = hasFlagP FromStdinFlg confArgs + regression = hasFlagP RegressionTestModeFlg confArgs + unit = hasFlagP RunUnitTestFlg confArgs + if (fromstdin || console || batch || regression || unit) + then consoleGeni pstRef + else guiGeni pstRef +\end{code} + +% TODO +% Define what is and what is not exported from the modules. +% In particular in BTypes take care to export the inspection function +% but not the types. +% Re-write functions in Main as needed. +% Change input in Lexicon and Grammar to allow more than one anchor. diff --git a/src/NLP/GenI/Automaton.lhs b/src/NLP/GenI/Automaton.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Automaton.lhs @@ -0,0 +1,140 @@ +% 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. + +\chapter{Automaton} +\label{cha:Automaton} + +\begin{code} +module NLP.GenI.Automaton + ( NFA(..), + finalSt, + addTrans, lookupTrans, + automatonPaths, automatonPathSets, + numStates, numTransitions ) +where + +import qualified Data.Map as Map +import Data.Maybe (catMaybes) + +import NLP.GenI.General (combinations) +\end{code} + +This module provides a simple, naive implementation of nondeterministic +finite automata (NFA). The transition function consists of a Map, but +there are also accessor function which help you query the automaton +without worrying about how it's implemented. + +\begin{enumerate} +\item The states are a list of lists, not just a simple flat list as + you might expect. This allows you to optionally group your + states into ``columns'' (which is something we use in the + GenI polarity automaton optimisation). If you don't want + columns, you can just make one big group out of all your states. +\item We model the empty an empty transition as the transition on + Nothing. All other transitions are Just something. +\item I'd love to reuse some other library out there, but Leon P. Smith's + Automata library requires us to know before-hand the size of our alphabet, + which is highly unacceptable for this task. +\end{enumerate} + +\begin{code} +-- | Note: there are two ways to define the final states. +-- 1. you may define them as a list of states in finalStList +-- 2. you may define them via the isFinalSt function +-- The state list is ignored if you define 'isFinalSt' +data NFA st ab = NFA + { startSt :: st + , isFinalSt :: Maybe (st -> Bool) + , finalStList :: [st] + -- + , transitions :: Map.Map st (Map.Map st [Maybe ab]) + -- see chapter comments about list of list + , states :: [[st]] + } +\end{code} + +% ---------------------------------------------------------------------- +\section{Building automata} +% ---------------------------------------------------------------------- + +\fnlabel{finalSt} returns all the final states of an automaton + +\begin{code} +finalSt :: NFA st ab -> [st] +finalSt aut = + case isFinalSt aut of + Nothing -> finalStList aut + Just fn -> concatMap (filter fn) (states aut) +\end{code} + +\fnlabel{lookupTrans} takes an automaton, a state \fnparam{st1} and an +element \fnparam{ab} of the alphabet; and returns the state that +\fnparam{st1} transitions to via \fnparam{a}, if possible. + +\begin{code} +lookupTrans :: (Ord ab, Ord st) => NFA st ab -> st -> (Maybe ab) -> [st] +lookupTrans aut st ab = Map.keys $ Map.filter (elem ab) subT + where subT = Map.findWithDefault Map.empty st (transitions aut) +\end{code} + +\begin{code} +addTrans :: (Ord ab, Ord st) => NFA st ab -> st -> Maybe ab -> st -> NFA st ab +addTrans aut st1 ab st2 = + aut { transitions = Map.insert st1 newSubT oldT } + where oldT = transitions aut + oldSubT = Map.findWithDefault Map.empty st1 oldT + newSubT = Map.insertWith (++) st2 [ab] oldSubT +\end{code} + +% ---------------------------------------------------------------------- +\section{Exploiting automata} +% ---------------------------------------------------------------------- + +\fnlabel{automatonPaths} returns all possible paths through an +automaton. Each path is represented as a list of labels. + +We assume that the automaton does not have any loops +in it. Maybe it would still work if there were loops, with lazy +evaluation, but I haven't had time to think this through, so only +try it unless you're feeling adventurous. + +FIXME: we should write some unit tests and quickchecks for this +\begin{code} +automatonPaths :: (Ord st, Ord ab) => (NFA st ab) -> [[ab]] +automatonPaths aut = concatMap combinations $ map (filter (not.null)) $ automatonPathSets aut + +-- | Not quite the set of all paths, but the sets of all transitions +--- FIXME: explain later +automatonPathSets :: (Ord st, Ord ab) => (NFA st ab) -> [[ [ab] ]] +automatonPathSets aut = helper (startSt aut) + where + transFor st = Map.lookup st (transitions aut) + helper st = case transFor st of + Nothing -> [] + Just subT -> concat [ (next (catMaybes tr) st2) | (st2, tr) <- Map.toList subT ] + next tr st2 = case helper st2 of + [] -> [[tr]] + res -> map (tr :) res +\end{code} + +\begin{code} +numStates, numTransitions :: NFA st ab -> Int +numStates = sum . (map length) . states +numTransitions = sum . (map subTotal) . (Map.elems) . transitions + where subTotal = sum . (map length) . (Map.elems) +\end{code} + diff --git a/src/NLP/GenI/Btypes.lhs b/src/NLP/GenI/Btypes.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Btypes.lhs @@ -0,0 +1,987 @@ +% 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. + +\chapter{Btypes} +\label{cha:Btypes} + +This module provides basic datatypes like GNode, as well as operations +on trees, nodes and semantics. Things here are meant to be relatively +low-level and primitive (well, with the exception of feature structure +unification, that is). + +\begin{code} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-} +module NLP.GenI.Btypes( + -- Datatypes + GNode(..), GType(Subs, Foot, Lex, Other), NodeName, + Ttree(..), MTtree, SemPols, TestCase(..), + Ptype(Initial,Auxiliar,Unspecified), + Pred, Flist, AvPair, GeniVal(..), + Lexicon, ILexEntry(..), MorphLexEntry, Macros, Sem, LitConstr, SemInput, Subst, + emptyLE, emptyGNode, emptyMacro, + + -- GNode stuff + gCategory, showLexeme, lexemeAttributes, gnnameIs, + + -- Functions from Tree GNode + plugTree, spliceTree, + root, rootUpd, foot, setLexeme, setAnchor, + + -- Functions from Sem + toKeys, subsumeSem, sortSem, showSem, showPred, + emptyPred, + + -- Functions from Flist + sortFlist, unify, unifyFeat, mergeSubst, + showFlist, showPairs, showAv, + + -- Other functions + Replacable(..), replaceOneAsMap, + Collectable(..), Idable(..), + alphaConvert, alphaConvertById, + fromGConst, fromGVar, + isConst, isVar, isAnon, + + -- Polarities + + -- Tests + prop_unify_anon, prop_unify_self, prop_unify_sym +) where +\end{code} + +\ignore{ +\begin{code} +-- import Debug.Trace -- for test stuff +import Control.Monad (liftM) +import Data.List +import Data.Maybe (fromMaybe, isJust, mapMaybe) +import Data.Generics (Data) +import Data.Typeable (Typeable) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Tree +import Test.QuickCheck hiding (collect) -- needed for testing via ghci + +import NLP.GenI.General(map', filterTree, listRepNode, snd3, geniBug, comparing) +--instance Show (IO()) where +-- show _ = "" +\end{code} +} + +% ---------------------------------------------------------------------- +\section{Grammar} +% ---------------------------------------------------------------------- + +A grammar is composed of some unanchored trees (macros) and individual +lexical entries. The trees are grouped into families. Every lexical +entry is associated with a single family. See section section +\ref{sec:combine_macros} for the process that combines lexical items +and trees into a set of anchored trees. + +\begin{code} +type MTtree = Ttree GNode +type Macros = [MTtree] + +data Ttree a = TT + { params :: [GeniVal] + , pfamily :: String + , pidname :: String + , pinterface :: Flist + , ptype :: Ptype + , psemantics :: Maybe Sem + , ptrace :: [String] + , tree :: Tree a } + deriving (Show, Data, Typeable) + +data Ptype = Initial | Auxiliar | Unspecified + deriving (Show, Eq, Data, Typeable) + +instance (Replacable a) => Replacable (Ttree a) where + replaceMap s mt = + mt { params = replaceMap s (params mt) + , tree = replaceMap s (tree mt) + , pinterface = replaceMap s (pinterface mt) + , psemantics = replaceMap s (psemantics mt) } + replaceOne = replaceOneAsMap + +instance (Collectable a) => Collectable (Ttree a) where + collect mt = (collect $ params mt) . (collect $ tree mt) . + (collect $ psemantics mt) . (collect $ pinterface mt) + +-- | A null tree which you can use for various debugging or display purposes. +emptyMacro :: MTtree +emptyMacro = TT { params = [], + pidname = "", + pfamily = "", + pinterface = [], + ptype = Unspecified, + psemantics = Nothing, + ptrace = [], + tree = Node emptyGNode [] + } +\end{code} + +\paragraph{Lexical entries} + +\begin{code} +-- | A lexicon maps semantic predicates to lexical entries. +type Lexicon = Map.Map String [ILexEntry] +type SemPols = [Int] +data ILexEntry = ILE + { -- normally just a singleton, useful for merging synonyms + iword :: [String] + , ifamname :: String + , iparams :: [GeniVal] + , iinterface :: Flist + , ifilters :: Flist + , iequations :: Flist + , iptype :: Ptype + , isemantics :: Sem + , isempols :: [SemPols] } + deriving (Show, Eq, Data, Typeable) + +instance Replacable ILexEntry where + replaceMap s i = + i { iinterface = replaceMap s (iinterface i) + , iequations = replaceMap s (iequations i) + , isemantics = replaceMap s (isemantics i) + , iparams = replaceMap s (iparams i) } + replaceOne = replaceOneAsMap + +instance Collectable ILexEntry where + collect l = (collect $ iinterface l) . (collect $ iparams l) . + (collect $ ifilters l) . (collect $ iequations l) . + (collect $ isemantics l) + +emptyLE :: ILexEntry +emptyLE = ILE { iword = [], + ifamname = "", + iparams = [], + iinterface = [], + ifilters = [], + iptype = Unspecified, + isemantics = [], + iequations = [], + isempols = [] } +\end{code} + +\begin{code} +type MorphLexEntry = (String,String,Flist) +\end{code} + +% ---------------------------------------------------------------------- +\section{GNode} +% ---------------------------------------------------------------------- + +A GNode is a single node of a syntactic tree. It has a name (gnname), +top and bottom feature structures (gup, gdown), a lexeme +(ganchor, glexeme: False and empty string if n/a), and some flags +information (gtype, gaconstr). + +\begin{code} +data GNode = GN{gnname :: NodeName, + gup :: Flist, + gdown :: Flist, + ganchor :: Bool, + glexeme :: [String], + gtype :: GType, + gaconstr :: Bool, + gorigin :: String -- ^ for TAG, this would be the elementary tree + -- that this node originally came from + } + deriving (Eq, Data, Typeable) + +-- Node type used during parsing of the grammar +data GType = Subs | Foot | Lex | Other + deriving (Show, Eq, Data, Typeable) + +type NodeName = String + +-- | A null 'GNode' which you can use for various debugging or display purposes. +emptyGNode :: GNode +emptyGNode = GN { gnname = "", + gup = [], gdown = [], + ganchor = False, + glexeme = [], + gtype = Other, + gaconstr = False, + gorigin = "" } + +gnnameIs :: NodeName -> GNode -> Bool +gnnameIs n = (== n) . gnname +\end{code} + +A TAG node may have a category. In the core GenI algorithm, there is nothing +which distinguishes the category from any other attributes. But for some +other uses, such as checking if it is a result or for display purposes, we +do treat this attribute differently. We take here the convention that the +category of a node is associated to the attribute ``cat''. +\begin{code} +-- | Return the value of the "cat" attribute, if available +gCategory :: Flist -> Maybe GeniVal +gCategory top = + case [ v | (a,v) <- top, a == "cat" ] of + [] -> Nothing + [c] -> Just c + _ -> geniBug $ "Impossible case: node with more than one category" +\end{code} + +A TAG node might also have a lexeme. If we are lucky, this is explicitly +set in the glexeme field of the node. Otherwise, we try to guess it from +a list of distinguished attributes (in order of preference). +\begin{code} +-- | Attributes recognised as lexemes, in order of preference +lexemeAttributes :: [String] +lexemeAttributes = [ "lex", "phon", "cat" ] +\end{code} + +\paragraph{show (GNode)} the default show for GNode tries to +be very compact; it only shows the value for cat attribute +and any flags which are marked on that node. + +\begin{code} +instance Show GNode where + show gn = + let cat_ = case gCategory.gup $ gn of + Nothing -> [] + Just c -> show c + lex_ = showLexeme $ glexeme gn + -- + stub = concat $ intersperse ":" $ filter (not.null) [ cat_, lex_ ] + extra = case (gtype gn) of + Subs -> " !" + Foot -> " *" + _ -> if (gaconstr gn) then " #" else "" + in stub ++ extra + +-- FIXME: will have to think of nicer way - one which involves +-- unpacking the trees :-( +showLexeme :: [String] -> String +showLexeme [] = "" +showLexeme [l] = l +showLexeme xs = concat $ intersperse "|" xs +\end{code} + +A Replacement on a GNode consists of replacements on its top and bottom +feature structures + +\begin{code} +instance Replacable GNode where + replaceOne s gn = + gn { gup = replaceOne s (gup gn) + , gdown = replaceOne s (gdown gn) } + replaceMap s gn = + gn { gup = replaceMap s (gup gn) + , gdown = replaceMap s (gdown gn) } +\end{code} + +% ---------------------------------------------------------------------- +\section{Tree manipulation} +% ---------------------------------------------------------------------- + +\begin{code} +instance (Replacable a) => Replacable (Tree a) where + replaceOne s t = fmap (replaceOne s) t + replaceMap s t = fmap (replaceMap s) t +\end{code} + +Projector and Update function for Tree + +\begin{code} +root :: Tree a -> a +root (Node a _) = a + +rootUpd :: Tree a -> a -> Tree a +rootUpd (Node _ l) b = (Node b l) + +foot :: Tree GNode -> GNode +foot t = case filterTree (\n -> gtype n == Foot) t of + [x] -> x + _ -> geniBug $ "foot returned weird result" +\end{code} + +\begin{code} +-- | Given a lexical item @s@ and a Tree GNode t, returns the tree t' +-- where l has been assigned to the anchor node in t' +setAnchor :: [String] -> Tree GNode -> Tree GNode +setAnchor s t = + let filt (Node a []) = (gtype a == Lex && ganchor a) + filt _ = False + in case listRepNode (setLexeme s) filt [t] of + ([r],True) -> r + _ -> geniBug $ "setLexeme " ++ show s ++ " returned weird result" + +-- | Given a lexical item @l@ and a tree node @n@ (actually a subtree +-- with no children), return the same node with the lexical item as +-- its unique child. The idea is that it converts terminal lexeme nodes +-- into preterminal nodes where the actual terminal is the given lexical +-- item +setLexeme :: [String] -> Tree GNode -> Tree GNode +setLexeme l (Node a []) = Node a [ Node subanc [] ] + where subanc = emptyGNode { gnname = '_' : ((gnname a) ++ ('.' : (concat l))) + , gaconstr = True + , glexeme = l} +setLexeme _ _ = geniBug "impossible case in setLexeme - subtree with kids" +\end{code} + +\subsection{Substitution and Adjunction} + +This module handles the strictly syntactic part of the TAG substitution and +adjunction. We do substitution with a very general \fnreflite{plugTree} +function, whose only job is to plug two trees together at a specified node. +Note that this function is also used to implement adjunction. + +\begin{code} +-- | Plug the first tree into the second tree at the specified node. +-- Anything below the second node is silently discarded. +-- We assume the trees are pluggable; it is treated as a bug if +-- they are not! +plugTree :: Tree NodeName -> NodeName -> Tree NodeName -> Tree NodeName +plugTree male n female = + case listRepNode (const male) (nmatch n) [female] of + ([r], True) -> r + _ -> geniBug $ "unexpected plug failure at node " ++ n + +-- | Given two trees 'auxt' and 't', splice the tree 'auxt' into +-- 't' via the TAG adjunction rule. +spliceTree :: NodeName -- ^ foot node of the aux tree + -> Tree NodeName -- ^ aux tree + -> NodeName -- ^ place to adjoin in target tree + -> Tree NodeName -- ^ target tree + -> Tree NodeName +spliceTree f auxT n targetT = + case findSubTree n targetT of -- excise the subtree at n + Nothing -> geniBug $ "Unexpected adjunction failure. " ++ + "Could not find node " ++ n ++ " of target tree." + Just eT -> -- plug the excised bit into the aux + let auxPlus = plugTree eT f auxT + -- plug the augmented aux at n + in plugTree auxPlus n targetT + +nmatch :: NodeName -> Tree NodeName -> Bool +nmatch n (Node a _) = a == n + +findSubTree :: NodeName -> Tree NodeName -> Maybe (Tree NodeName) +findSubTree n n2@(Node x ks) + | x == n = Just n2 + | otherwise = case mapMaybe (findSubTree n) ks of + [] -> Nothing + (h:_) -> Just h +\end{code} + +% ---------------------------------------------------------------------- +\section{Features and variables} +% ---------------------------------------------------------------------- + +\begin{code} +type Flist = [AvPair] +type AvPair = (String,GeniVal) +\end{code} + +\subsection{GeniVal} + +\begin{code} +data GeniVal = GConst [String] + | GVar !String + | GAnon + deriving (Eq,Ord, Data, Typeable) + +instance Show GeniVal where + show (GConst x) = concat $ intersperse "|" x + show (GVar x) = '?':x + show GAnon = "?_" + +isConst :: GeniVal -> Bool +isConst (GConst _) = True +isConst _ = False + +isVar :: GeniVal -> Bool +isVar (GVar _) = True +isVar _ = False + +isAnon :: GeniVal -> Bool +isAnon GAnon = True +isAnon _ = False + +-- | (assumes that it's a GConst!) +fromGConst :: GeniVal -> [String] +fromGConst (GConst x) = x +fromGConst x = error ("fromGConst on " ++ show x) + +-- | (assumes that it's a GVar!) +fromGVar :: GeniVal -> String +fromGVar (GVar x) = x +fromGVar x = error ("fromGVar on " ++ show x) +\end{code} + +\subsection{Collectable} + +A Collectable is something which can return its variables as a set. +By variables, what I most had in mind was the GVar values in a +GeniVal. This notion is probably not very useful outside the context of +alpha-conversion task, but it seems general enough that I'll keep it +around for a good bit, until either some use for it creeps up, or I find +a more general notion that I can transform this into. + +\begin{code} +class Collectable a where + collect :: a -> Set.Set String -> Set.Set String + +instance Collectable a => Collectable (Maybe a) where + collect Nothing s = s + collect (Just x) s = collect x s + +instance (Collectable a => Collectable [a]) where + collect l s = foldr collect s l + +instance (Collectable a => Collectable (Tree a)) where + collect = collect.flatten + +-- Pred is what I had in mind here +instance ((Collectable a, Collectable b, Collectable c) + => Collectable (a,b,c)) where + collect (a,b,c) = collect a . collect b . collect c + +instance Collectable GeniVal where + collect (GVar v) s = Set.insert v s + collect _ s = s + +instance Collectable (String,GeniVal) where + collect (_,b) = collect b + +instance Collectable GNode where + collect n = (collect $ gdown n) . (collect $ gup n) +\end{code} + +\subsection{Replacable} +\label{sec:replacable} +\label{sec:replacements} + +The idea of replacing one variable value with another is something that +appears all over the place in GenI. So we try to smooth out its use by +making a type class out of it. + +\begin{code} +class Replacable a where + replace :: Subst -> a -> a + replace = replaceMap + + replaceMap :: Map.Map String GeniVal -> a -> a + + replaceOne :: (String,GeniVal) -> a -> a + + -- | Here it is safe to say (X -> Y; Y -> Z) because this would be crushed + -- down into a final value of (X -> Z; Y -> Z) + replaceList :: [(String,GeniVal)] -> a -> a + replaceList = replaceMap . foldl update Map.empty + where + update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m + +-- | Default implementation for replaceOne but not a good idea for the +-- core stuff; which is why it is not a typeclass default +replaceOneAsMap :: Replacable a => (String, GeniVal) -> a -> a +replaceOneAsMap s = replaceMap (uncurry Map.singleton s) + +instance (Replacable a => Replacable (Maybe a)) where + replaceMap s = liftM (replaceMap s) + replaceOne s = liftM (replaceOne s) +\end{code} + +GeniVal is probably the simplest thing you would one to apply a +substitution on + +\begin{code} +instance Replacable GeniVal where + replaceMap m v@(GVar v_) = {-# SCC "replaceMap" #-} Map.findWithDefault v v_ m + replaceMap _ v = {-# SCC "replaceMap" #-} v + + replaceOne (s1, s2) (GVar v_) | v_ == s1 = {-# SCC "replaceOne" #-} s2 + replaceOne _ v = {-# SCC "replaceOne" #-} v +\end{code} + +Substitution on list consists of performing substitution on +each item. Each item, is independent of the other, +of course. + +\begin{code} +instance (Replacable a => Replacable [a]) where + replaceMap s = {-# SCC "replaceMap" #-} map' (replaceMap s) + replaceOne s = {-# SCC "replaceOne" #-} map' (replaceOne s) +\end{code} + +Substitution on an attribute/value pairs consists of ignoring +the attribute and performing substitution on the value. + +\begin{code} +instance Replacable AvPair where + replaceMap s (a,v) = {-# SCC "replaceMap" #-} (a, replaceMap s v) + replaceOne s (a,v) = {-# SCC "replaceOne" #-} (a, replaceOne s v) + +instance Replacable (String, ([String], Flist)) where + replaceMap s (n,(a,v)) = {-# SCC "replaceMap" #-} (n,(a, replaceMap s v)) + replaceOne s (n,(a,v)) = {-# SCC "replaceOne" #-} (n,(a, replaceOne s v)) +\end{code} + +\subsection{Idable} + +An Idable is something that can be mapped to a unique id. +You might consider using this to implement Ord, but I won't. +Note that the only use I have for this so far (20 dec 2005) +is in alpha-conversion. + +\begin{code} +class Idable a where + idOf :: a -> Integer +\end{code} + +\subsection{Other feature and variable stuff} + +Our approach to $\alpha$-conversion works by appending a unique suffix +to all variables in an object. See section \ref{sec:fs_unification} for +why we want this. + +\begin{code} +alphaConvertById :: (Collectable a, Replacable a, Idable a) => a -> a +alphaConvertById x = {-# SCC "alphaConvertById" #-} + alphaConvert ('-' : (show . idOf $ x)) x + +alphaConvert :: (Collectable a, Replacable a) => String -> a -> a +alphaConvert suffix x = {-# SCC "alphaConvert" #-} + let vars = Set.elems $ collect x Set.empty + convert v = GVar (v ++ suffix) + subst = Map.fromList $ map (\v -> (v, convert v)) vars + in replaceMap subst x +\end{code} + +\begin{code} +-- | Sort an Flist according with its attributes +sortFlist :: Flist -> Flist +sortFlist = sortBy (comparing fst) + +showFlist :: Flist -> String +showFlist f = "[" ++ showPairs f ++ "]" + +showPairs :: Flist -> String +showPairs = unwords . map showAv + +showAv :: AvPair -> String +showAv (y,z) = y ++ ":" ++ show z +\end{code} + +% ---------------------------------------------------------------------- +\section{Semantics} +\label{btypes_semantics} +% ---------------------------------------------------------------------- + +\begin{code} +-- handle, predicate, parameters +type Pred = (GeniVal, GeniVal, [GeniVal]) +type Sem = [Pred] +type LitConstr = (Pred, [String]) +type SemInput = (Sem,Flist,[LitConstr]) +type Subst = Map.Map String GeniVal + +data TestCase = TestCase + { tcName :: String + , tcSemString :: String -- ^ for gui + , tcSem :: SemInput + , tcExpected :: [String] -- ^ expected results (for testing) + , tcOutputs :: [(String, Map.Map (String,String) [String])] + -- ^ results we actually got, and their traces (for testing) + } deriving Show + +emptyPred :: Pred +emptyPred = (GAnon,GAnon,[]) +\end{code} + +A replacement on a predicate is just a replacement on its parameters + +\begin{code} +instance Replacable Pred where + replaceMap s (h, n, lp) = (replaceMap s h, replaceMap s n, replaceMap s lp) + replaceOne s (h, n, lp) = (replaceOne s h, replaceOne s n, replaceOne s lp) +\end{code} + +\begin{code} +showSem :: Sem -> String +showSem l = + "[" ++ (unwords $ map showPred l) ++ "]" + +showPred :: Pred -> String +showPred (h, p, l) = showh ++ show p ++ "(" ++ unwords (map show l) ++ ")" + where + hideh (GConst [x]) = "genihandle" `isPrefixOf` x + hideh _ = False + -- + showh = if (hideh h) then "" else (show h) ++ ":" +\end{code} + +\begin{code} +-- | Given a Semantics, return the string with the proper keys +-- (propsymbol+arity) to access the agenda +toKeys :: Sem -> [String] +toKeys l = map (\(_,prop,par) -> show prop ++ (show $ length par)) l +\end{code} + +\subsection{Semantic subsumption} +\label{fn:subsumeSem} + +FIXME: comment fix + +Given tsem the input semantics, and lsem the semantics of a potential +lexical candidate, returns a list of possible ways that the lexical +semantics could subsume the input semantics. We return a pair with +the semantics that would result from unification\footnote{We need to +do this because there may be anonymous variables}, and the +substitutions that need to be propagated throughout the rest of the +lexical item later on. + +Note: we return more than one possible substitution because s could be +different subsets of ts. Consider, for example, \semexpr{love(j,m), + name(j,john), name(m,mary)} and the candidate \semexpr{name(X,Y)}. + +TODO WE ASSUME BOTH SEMANTICS ARE ORDERED and that the input semantics is +non-empty. + +\begin{code} +subsumeSem :: Sem -> Sem -> [(Sem,Subst)] +subsumeSem tsem lsem = + subsumeSemHelper ([],Map.empty) (reverse tsem) (reverse lsem) +\end{code} + +This is tricky because each substep returns multiple results. We solicit +the help of accumulators to keep things from getting confused. + +\begin{code} +subsumeSemHelper :: (Sem,Subst) -> Sem -> Sem -> [(Sem,Subst)] +subsumeSemHelper _ [] _ = + error "input semantics is non-empty in subsumeSemHelper" +subsumeSemHelper acc _ [] = [acc] +subsumeSemHelper acc tsem (hd:tl) = + let (accSem,accSub) = acc + -- does the literal hd subsume the input semantics? + pRes = subsumePred tsem hd + -- toPred reconstructs the literal hd with new parameters p. + -- The head of the list is taken to be the handle. + toPred p = (head p, snd3 hd, tail p) + -- next adds a result from predication subsumption to + -- the accumulators and goes to the next recursive step + next (p,s) = subsumeSemHelper acc2 tsem2 tl2 + where tl2 = replace s tl + tsem2 = replace s tsem + acc2 = (toPred p : accSem, mergeSubst accSub s) + in concatMap next pRes +\end{code} + +\fnlabel{subsumePred} +The first Sem s1 and second Sem s2 are the same when we start we circle on s2 +looking for a match for Pred, and meanwhile we apply the partical substitutions +to s1. Note: we treat the handle as if it were a parameter. + +\begin{code} +subsumePred :: Sem -> Pred -> [([GeniVal],Subst)] +subsumePred [] _ = [] +subsumePred ((h1, p1, la1):l) (pred2@(h2,p2,la2)) = + -- if we found the proper predicate + if ((p1 == p2) && (length la1 == length la2)) + then let mrs = unify (h1:la1) (h2:la2) + next = subsumePred l pred2 + in maybe next (:next) mrs + else if (p1 < p2) -- note that the semantics have to be reversed! + then [] + else subsumePred l pred2 +\end{code} + +\subsection{Other semantic stuff} + +\begin{code} +-- | Sort semantics first according to its predicate, and then to its handles. +sortSem :: Sem -> Sem +sortSem = sortBy (\(h1,p1,a1) (h2,p2,a2) -> compare (p1, h1:a1) (p2, h2:a2)) +\end{code} + +% -------------------------------------------------------------------- +\subsection{Unification} +\label{sec:fs_unification} +% -------------------------------------------------------------------- + +Feature structure unification takes two feature lists as input. If it +fails, it returns Nothing. Otherwise, it returns a tuple with: + +\begin{enumerate} +\item a unified feature structure list +\item a list of variable replacements that will need to be propagated + across other feature structures with the same variables +\end{enumerate} + +Unification fails if, at any point during the unification process, the +two lists have different constant values for the same attribute. +For example, unification fails on the following inputs because they have +different values for the \textit{number} attribute: + +\begin{quotation} +\fs{\it cat:np\\ \it number:3\\} +\fs{\it cat:np\\ \it number:2\\} +\end{quotation} + +Note that the following input should also fail as a result on the +coreference on \textit{?X}. + +\begin{quotation} +\fs{\it cat:np\\ \it one: 1\\ \it two:2\\} +\fs{\it cat:np\\ \it one: ?X\\ \it two:?X\\} +\end{quotation} + +On the other hand, any other pair of feature lists should unify +succesfully, even those that do not share the same attributes. +Below are some examples of successful unifications: + +\begin{quotation} +\fs{\it cat:np\\ \it one: 1\\ \it two:2\\} +\fs{\it cat:np\\ \it one: ?X\\ \it two:?Y\\} +$\rightarrow$ +\fs{\it cat:np\\ \it one: 1\\ \it two:2\\}, +\end{quotation} + +\begin{quotation} +\fs{\it cat:np\\ \it number:3\\} +\fs{\it cat:np\\ \it case:nom\\} +$\rightarrow$ +\fs{\it cat:np\\ \it case:nom\\ \it number:3\\}, +\end{quotation} + +\fnlabel{unifyFeat} is an implementation of feature structure +unification. It makes the following assumptions: + +\begin{itemize} +\item Features are ordered + +\item The Flists do not share variables!!! + + More precisely, if the two Flists have the same variable, they + will have the same value. Though this behaviour may not be + desirable, we don't really care because we never encounter the + situation (see page \pageref{par:lexSelection}). +\end{itemize} + +\begin{code} +unifyFeat :: (Monad m) => Flist -> Flist -> m (Flist, Subst) +unifyFeat f1 f2 = + {-# SCC "unification" #-} + let (att, val1, val2) = alignFeat f1 f2 + in att `seq` + do (res, subst) <- unify val1 val2 + return (zip att res, subst) +\end{code} + +\fnlabel{alignFeat} + +The less trivial case is when neither list is empty. If we are looking +at the same attribute, then we transfer control to the helper function. +Otherwise, we remove the (alphabetically) smaller att-val pair, add it +to the results, and move on. This only works if the lists are +alphabetically sorted beforehand! + +\begin{code} +alignFeat :: Flist -> Flist -> ([String], [GeniVal], [GeniVal]) +alignFeat [] [] = ([], [], []) + +alignFeat [] ((f,v):x) = + case alignFeat [] x of + (att, left, right) -> (f:att, GAnon:left, v:right) + +alignFeat x [] = + case alignFeat [] x of + (att, left, right) -> (att, right, left) + +alignFeat fs1@((f1, v1):l1) fs2@((f2, v2):l2) + | f1 == f2 = case alignFeat l1 l2 of + (att, left, right) -> (f1:att, v1:left, v2:right) + | f1 < f2 = case alignFeat l1 fs2 of + (att, left, right) -> (f1:att, v1:left, GAnon:right) + | f1 > f2 = case alignFeat fs1 l2 of + (att, left, right) -> (f2:att, GAnon:left, v2:right) + | otherwise = error "Feature structure unification is badly broken" +\end{code} + +\subsection{Unification} + +\fnlabel{unify} performs unification on two lists of GeniVal. If +unification succeeds, it returns \verb!Just (r,s)! where \verb!r! is +the result of unification and \verb!s! is a list of substitutions that this +unification results in. + +Notes: +\begin{itemize} +\item there may be multiple results because of disjunction +\item we need to return \verb!r! because of anonymous variables +\item the lists need not be same length; we just assume you want + the longer of the two +\end{itemize} + +The core unification algorithm follows these rules in order: + +\begin{enumerate} +\item if either h1 or h2 are anonymous, we add the other to the result, + and we don't add any replacements. +\item if h1 is a variable then we replace it by h2, + regardless of whether or not h2 is a variable +\item if h2 is a variable then we replace it by h1 +\item if neither h1 and h2 are variables, but they match, we arbitarily + add one of them to the result, but we don't add any replacements. +\item if neither are variables and they do \emph{not} match, we fail +\end{enumerate} + +\begin{code} +unify :: (Monad m) => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) +unify [] l2 = {-# SCC "unification" #-} return (l2, Map.empty) +unify l1 [] = {-# SCC "unification" #-} return (l1, Map.empty) +unify (h1:t1) (h2:t2) | h1 == h2 = {-# SCC "unification" #-} unifySansRep h1 t1 t2 +unify (GAnon:t1) (h2:t2) = {-# SCC "unification" #-} unifySansRep h2 t1 t2 +unify (h1:t1) (GAnon:t2) = {-# SCC "unification" #-} unifySansRep h1 t1 t2 +unify (h1@(GVar _):t1) (h2:t2) = {-# SCC "unification" #-} unifyWithRep h1 h2 t1 t2 +unify (h1:t1) (h2@(GVar _):t2) = {-# SCC "unification" #-} unifyWithRep h2 h1 t1 t2 +-- special cases for efficiency only +unify ((GConst [_]):_) ((GConst [_]):_) = {-# SCC "unification" #-} + fail "unification failure" +-- end special efficiency-only cases +unify ((GConst h1v):t1) ((GConst h2v):t2) = {-# SCC "unification" #-} + case h1v `intersect` h2v of + [] -> fail "unification failure" + newH -> unifySansRep (GConst newH) t1 t2 +{-# INLINE unifySansRep #-} +{-# INLINE unifyWithRep #-} +unifySansRep :: (Monad m) => GeniVal -> [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) +unifySansRep x2 t1 t2 = {-# SCC "unification" #-} + do (res,subst) <- unify t1 t2 + return (x2:res, subst) + +unifyWithRep :: (Monad m) => GeniVal -> GeniVal -> [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) +unifyWithRep (GVar h1) x2 t1 t2 = {-# SCC "unification" #-} + let s = (h1,x2) + t1_ = replaceOne s t1 + t2_ = replaceOne s t2 + ustep = unify t1_ t2_ + in s `seq` t1_ `seq` t2_ `seq` ustep `seq` + (ustep >>= \(res,subst) -> return (x2:res, prependToSubst s subst)) +unifyWithRep _ _ _ _ = geniBug "unification error" +\end{code} + +\begin{code} +-- | Note that the first Subst is assumed to come chronologically +-- before the second one; so merging @{ X -> Y }@ and @{ Y -> 3 }@ +-- should give us @{ X -> 3; Y -> 3 }@; +-- +-- See 'prependToSubst' for a warning! +mergeSubst :: Subst -> Subst -> Subst +mergeSubst sm1 sm2 = Map.foldWithKey (curry prependToSubst) sm2 sm1 + +-- | Add to variable replacement to a 'Subst' that logical comes before +-- the other stuff in it. So for example, if we have @Y -> foo@ +-- and we want to insert @X -> Y@, we notice that, in fact, @Y@ has +-- already been replaced by @foo@, so we add @X -> foo@ instead +-- +-- Note that it is undefined if you try to append something like +-- @Y -> foo@ to @Y -> bar@, because that would mean that unification +-- is broken +prependToSubst :: (String,GeniVal) -> Subst -> Subst +prependToSubst (v, gr@(GVar r)) sm + | isJust $ Map.lookup v sm = geniBug $ "prependToSubst: Eric broke unification. Prepending " ++ v ++ " twice." + | otherwise = Map.insert v gr2 sm + where gr2 = fromMaybe gr $ Map.lookup r sm +prependToSubst (v, gr) sm = Map.insert v gr sm +\end{code} + +\subsubsection{Unification tests} The unification algorithm should satisfy +the following properties: + +Unifying something with itself should always succeed + +\begin{code} +prop_unify_self :: [GeniVal] -> Property +prop_unify_self x = + (all qc_not_empty_GConst) x ==> + case unify x x of + Nothing -> False + Just unf -> (fst unf == x) +\end{code} + +Unifying something with only anonymous variables should succeed. + +\begin{code} +prop_unify_anon :: [GeniVal] -> Bool +prop_unify_anon x = + case (unify x y) of + Nothing -> False + Just unf -> (fst unf == x) + where -- + y = take (length x) $ repeat GAnon +\end{code} + +Unification should be symmetrical. We can't guarantee these if there +are cases where there are variables in the same place on both sides, so we +normalise the sides so that this doesn't happen. + +\begin{code} +prop_unify_sym :: [GeniVal] -> [GeniVal] -> Property +prop_unify_sym x y = + let u1 = (unify x y) :: Maybe ([GeniVal],Subst) + u2 = unify y x + -- + notOverlap (GVar _, GVar _) = False + notOverlap _ = True + in (all qc_not_empty_GConst) x && + (all qc_not_empty_GConst) y && + all (notOverlap) (zip x y) ==> u1 == u2 +\end{code} + +\ignore{ +\begin{code} +-- Definition of Arbitrary GeniVal for QuickCheck +newtype GTestString = GTestString String +newtype GTestString2 = GTestString2 String + +fromGTestString :: GTestString -> String +fromGTestString (GTestString s) = s + +fromGTestString2 :: GTestString2 -> String +fromGTestString2 (GTestString2 s) = s + +instance Arbitrary GTestString where + arbitrary = + oneof $ map (return . GTestString) $ + [ "a", "apple" , "b", "banana", "c", "carrot", "d", "durian" + , "e", "eggplant", "f", "fennel" , "g", "grape" ] + coarbitrary = error "no implementation of coarbitrary for GTestString" + +instance Arbitrary GTestString2 where + arbitrary = + oneof $ map (return . GTestString2) $ + [ "X", "Y", "Z", "H", "I", "J", "P", "Q", "R", "S", "T", "U" ] + coarbitrary = error "no implementation of coarbitrary for GTestString2" + +instance Arbitrary GeniVal where + arbitrary = oneof [ return $ GAnon, + liftM (GVar . fromGTestString2) arbitrary, + liftM (GConst . nub . sort . map fromGTestString) arbitrary ] + coarbitrary = error "no implementation of coarbitrary for GeniVal" + +qc_not_empty_GConst :: GeniVal -> Bool +qc_not_empty_GConst (GConst []) = False +qc_not_empty_GConst _ = True +\end{code} +} diff --git a/src/NLP/GenI/BtypesBinary.hs b/src/NLP/GenI/BtypesBinary.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/BtypesBinary.hs @@ -0,0 +1,54 @@ +{-# OPTIONS -fno-warn-orphans #-} +module NLP.GenI.BtypesBinary where + +import Data.Binary +import NLP.GenI.Btypes + +-- auto-generated by the Data.Binary BinaryDerive tool +instance Binary NLP.GenI.Btypes.Ptype where + put Initial = putWord8 0 + put Auxiliar = putWord8 1 + put Unspecified = putWord8 2 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return Initial + 1 -> return Auxiliar + 2 -> return Unspecified + _ -> fail "no parse" +instance Binary NLP.GenI.Btypes.GeniVal where + put (GConst a) = putWord8 0 >> put a + put (GVar a) = putWord8 1 >> put a + put GAnon = putWord8 2 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (GConst a) + 1 -> get >>= \a -> return (GVar a) + 2 -> return GAnon + _ -> fail "no parse" +instance Binary NLP.GenI.Btypes.GNode where + put (GN a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h + get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (GN a b c d e f g h) + +instance Binary NLP.GenI.Btypes.GType where + put Subs = putWord8 0 + put Foot = putWord8 1 + put Lex = putWord8 2 + put Other = putWord8 3 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return Subs + 1 -> return Foot + 2 -> return Lex + 3 -> return Other + _ -> fail "no parse" +instance (Binary a) => Binary (NLP.GenI.Btypes.Ttree a) where + put (TT a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h + get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (TT a b c d e f g h) + +instance Binary NLP.GenI.Btypes.ILexEntry where + put (ILE a b c d e f g h i) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h >> put i + get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> get >>= \i -> return (ILE a b c d e f g h i) + diff --git a/src/NLP/GenI/Builder.lhs b/src/NLP/GenI/Builder.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Builder.lhs @@ -0,0 +1,480 @@ +% 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. + +\chapter{Builder} +\label{cha:Builder} + +The heavy lifting of GenI, the whole chart/agenda mechanism, can be +implemented in many ways. To make it easier to write different +algorithms for GenI and compare them, we provide a single interface +for what we call Builders. + +This interface is then used called by the Geni module and by the +graphical interface. Note that each builder has its own graphical +interface and that we do a similar thing in the graphical interface +code to make it possible to use these GUIs. Maybe a little dose of +UML might help. See figure \ref{fig:builderUml}. + +\begin{figure} +\begin{center} +\includegraphics[scale=0.5]{images/builderUml.pdf} +\label{fig:builderUml} +\caption{Essentially what the Builder interface provides} +\end{center} +\end{figure} + +\ignore{ +\begin{code} +module NLP.GenI.Builder +where + +import Control.Monad.State +import Data.Bits ( (.&.), (.|.), bit, xor ) +import Data.List ( (\\), maximum ) +import qualified Data.Map as Map +import Data.Maybe ( mapMaybe, fromMaybe ) +import qualified Data.Set as Set +import Data.Tree ( flatten ) +import Prelude hiding ( init ) + +import NLP.GenI.Automaton (NFA, automatonPaths, automatonPathSets, numStates, numTransitions) +import NLP.GenI.Configuration + ( getListFlagP, getFlagP, hasFlagP, Params, + ExtraPolaritiesFlg(..), MetricsFlg(..), + IgnoreSemanticsFlg(..), RootFeatureFlg(..), + polarised ) +import NLP.GenI.General (geniBug, BitVector, multiGroupByFM, fst3, snd3, thd3) +import NLP.GenI.Btypes + ( ILexEntry, SemInput, Sem, Pred, showPred, showSem, + Flist, gtype, GType(Subs, Foot), + Collectable(collect), alphaConvertById, + GeniVal(GConst) + ) +import NLP.GenI.Polarity (PolResult, buildAutomaton, detectPolPaths) +import NLP.GenI.Statistics (Statistics, incrIntMetric, + Metric(IntMetric), updateMetrics, + mergeMetrics, addIntMetrics, + queryMetrics, queryIntMetric, + addMetric, emptyStats, + ) +import NLP.GenI.Tags ( TagElem(idname,tsemantics,ttree), setTidnums, TagDerivation ) +\end{code} +} + +\section{The interface} + +All backends provide the same essential functionality: +\begin{description} +\item [run] calls init and stepAll and potentially wraps it with some + other functionality. +\item [init] initialise the machine from the semantics and lexical selection +\item [step] run a realisation step +\item [stepAll] run all realisations steps until completion +\item [finished] determine if realisation is finished +\item [stats] extract various statistics from it +\item [setStats] set the statistical information +\item [unpack] unpack chart results into a list of sentences +\end{description} + +FIXME: need to update this comment + +\begin{code} +data Builder st it pa = Builder + { init :: Input -> pa -> (st, Statistics) + -- + , step :: BuilderState st () + , stepAll :: BuilderState st () + -- + , finished :: st -> Bool + , unpack :: st -> [Output] + , partial :: st -> [Output] } + +type Output = (UninflectedSentence, Derivation) +type Derivation = TagDerivation +\end{code} + +To simplify interaction with the backend, we provide a single data +structure which represents all the inputs a backend could take. + +\begin{code} +data Input = + Input { inSemInput :: SemInput + , inLex :: [ILexEntry] -- ^ for the debugger + , inCands :: [(TagElem, BitVector)] -- ^ tag tree + } +\end{code} + +\section{Uninflected words and sentences} + +Each word of an uninflected sentence consists of a lemma and some +feature structures. + +\paragraph +A SentenceAut represents a set of sentences in the form of an automaton. +The labels of the automaton are the words of the sentence. But note! +``word'' in the sentence is in fact a tuple (lemma, inflectional feature +structures). Normally, the states are defined as integers, with the +only requirement being that each one, naturally enough, is unique. + +\begin{code} +type UninflectedWord = (String, Flist) +type UninflectedSentence = [ UninflectedWord ] +type UninflectedDisjunction = ([String], Flist) +type SentenceAut = NFA Int UninflectedWord +\end{code} + +\section{BuilderState} + +To cleanly seperate the tracking of statistics from the core functionality of a +builder, we use a State transformer to thread a Statistics state monad inside of +our main monad. + +\begin{code} +type BuilderState s a = StateT s (State Statistics) a +\end{code} + +\section{Helper functions for Builders} + +\subsection{Initialisation} +\label{fn:Builder:preInit} + +There's a few things that need to be run before even initialising the builder. +One of these is running some of the optimisations (namely the polarity stuff), +which is made complicated by the fact that they are optional. Another of these +to assign each of the trees with a unique ID. Note that this has to be done +after the polarity optimisation because this optimisation may introduce new +items into the lexical selection. Finally, we must also make sure we perform +alpha conversion so that unification does not do the wrong thing when two trees +have the same variables. + +\begin{code} +preInit :: Input -> Params -> (Input, (Int,Int,Int), PolResult) +preInit input config = + let (cand,_) = unzip $ inCands input + seminput = inSemInput input + -- + extraPol = fromMaybe (Map.empty) $ getFlagP ExtraPolaritiesFlg config + rootFeat = getListFlagP RootFeatureFlg config + -- do any optimisations + isPol = polarised config + -- polarity optimisation (if enabled) + autstuff = buildAutomaton seminput cand rootFeat extraPol + (_, seedAut, aut, sem2) = autstuff + autpaths = map concat $ automatonPathSets aut + combosPol = if isPol then autpaths else [cand] + -- chart sharing optimisation + (cands2, pathIds) = unzip $ detectPolPaths combosPol + -- the number of paths explored vs possible + polcount = (length autpaths, length $ automatonPaths aut, length $ automatonPaths seedAut) + -- + fixate ts ps = zip (map alphaConvertById $ setTidnums ts) ps + input2 = input { inCands = fixate cands2 pathIds + , inSemInput = (sem2, snd3 seminput, thd3 seminput) } + -- note: autstuff is only useful for the graphical debugger + in (input2, polcount, autstuff) +\end{code} + +\begin{code} +-- | Equivalent to 'id' unless the input contains an empty or uninstatiated +-- semantics +unlessEmptySem :: Input -> Params -> a -> a +unlessEmptySem input config = + let (cands,_) = unzip $ inCands input + nullSemCands = [ idname t | t <- cands, (null.tsemantics) t ] + unInstSemCands = [ idname t | t <- cands, not $ Set.null $ collect (tsemantics t) Set.empty ] + nullSemErr = "The following trees have a null semantics: " ++ (unwords nullSemCands) + unInstSemErr = "The following trees have an uninstantiated semantics: " ++ (unwords unInstSemCands) + semanticsErr = (if null nullSemCands then "" else nullSemErr ++ "\n") ++ + (if null unInstSemCands then "" else unInstSemErr) + in if (null semanticsErr || hasFlagP IgnoreSemanticsFlg config) + then id + else error semanticsErr +\end{code} + +\subsection{Running a surface realiser} + +\begin{code} +-- | Performs surface realisation from an input semantics and a lexical selection. +run :: Builder st it Params -> Input -> Params -> (st, Statistics) +run builder input config = + let -- 1 run the setup stuff + (input2, polcount, autstuff) = preInit input config + auts = (\(x,_,_,_) -> map snd3 x) autstuff + -- 2 call the init stuff + (iSt, iStats) = init builder input2 config + -- 3 step through the whole thing + stepAll_ = do incrCounter "pol_used_bundles" $ fst3 polcount + incrCounter "pol_used_paths" $ snd3 polcount + incrCounter "pol_seed_paths" $ thd3 polcount + incrCounter "pol_total_states" $ sum $ map numStates auts + incrCounter "pol_total_trans" $ sum $ map numTransitions auts + incrCounter "pol_max_states" $ maximum $ map numStates auts + incrCounter "pol_max_trans" $ maximum $ map numTransitions auts + stepAll builder + in runState (execStateT stepAll_ iSt) iStats +\end{code} + +\subsection{Semantics and bit vectors} + +\begin{code} +type SemBitMap = Map.Map Pred BitVector + +-- | assign a bit vector value to each literal in the semantics +-- the resulting map can then be used to construct a bit vector +-- representation of the semantics +defineSemanticBits :: Sem -> SemBitMap +defineSemanticBits sem = Map.fromList $ zip sem bits + where + bits = map bit [0..] -- 0001, 0010, 0100... + +semToBitVector :: SemBitMap -> Sem -> BitVector +semToBitVector bmap sem = foldr (.|.) 0 $ map doLookup sem + where doLookup p = + case Map.lookup p bmap of + Nothing -> geniBug $ "predicate " ++ showPred p ++ " not found in semanticBit map" + Just b -> b + +bitVectorToSem :: SemBitMap -> BitVector -> Sem +bitVectorToSem bmap vector = + mapMaybe tryKey $ Map.toList bmap + where tryKey (p,k) = if (k .&. vector == k) then Just p else Nothing +\end{code} + +\subsection{Index accesibility filtering} +\label{sec:iaf} + +Index accesibility filtering was described in \cite{carroll05her}. This +is my attempt to adapt it to TAG. This filter works as a form of delayed +substitution, basically the exact opposite of delayed adjunction. + +This might be wrong, but we say that an index is originally accesible if +it is the root node's idx attribute (no atomic disjunction; atomic +disjunction is as good as a variable as far I'm concerned) + +FIXME: more about this later. +FIXME: are we sure we got the atomic disjunctions right? + +\begin{code} +type IafMap = Map.Map String Sem + +-- | Return the literals of the semantics (in bit vector form) +-- whose accesibility depends on the given index +dependentSem :: IafMap -> String -> Sem +dependentSem iafMap x = Map.findWithDefault [] x iafMap + +-- | Return the handle and arguments of a literal +literalArgs :: Pred -> [GeniVal] +literalArgs (h,_,args) = h:args + +semToIafMap :: Sem -> IafMap +semToIafMap sem = + multiGroupByFM (concatMap fromUniConst . literalArgs) sem + +-- | Like 'fromGConst' but only for the non-disjoint ones: meant to be used as Maybe or List +fromUniConst :: (Monad m) => GeniVal -> m String +fromUniConst (GConst [x]) = return x +fromUniConst _ = fail "not a unique constant" -- we don't actually expect this failure msg to be used + +getIdx :: Flist -> [GeniVal] +getIdx fs = [ v | (a,v) <- fs, a == "idx" ] + +ts_iafFailure :: [String] -> [Pred] -> String +ts_iafFailure is sem = "index accesibility failure -" ++ (unwords is) ++ "- blocked: " ++ showSem sem + +-- | Calculate the new set of accessibility/inaccesible indices, returning a +-- a tuple of accesible / inaccesible indices +recalculateAccesibility :: (IafAble a) => a -> a +recalculateAccesibility i = + let oldAcc = iafAcc i + newAcc = iafNewAcc i + oldInacc = iafInacc i + newInacc = oldInacc ++ (oldAcc \\ newAcc) + in iafSetInacc newInacc $ iafSetAcc newAcc i + +-- | Return, in bitvector form, the portion of a semantics that is inaccesible +-- from an item +iafBadSem :: (IafAble a) => IafMap -> SemBitMap + -> BitVector -- ^ the input semantics + -> (a -> BitVector) -- ^ the semantics of the item + -> a -> BitVector +iafBadSem iafMap bmap sem semfn i = + let -- the semantics we can't reach + inaccessible = foldr (.|.) 0 $ map (semToBitVector bmap . dependentSem iafMap) $ iafInacc i + -- the semantics we still _need_ to be able to reach + remaining = sem `xor` (semfn i) + -- where we're in trouble + in inaccessible .&. remaining + +class IafAble a where + iafAcc :: a -> [String] + iafInacc :: a -> [String] + iafSetAcc :: [String] -> a -> a + iafSetInacc :: [String] -> a -> a + iafNewAcc :: a -> [String] +\end{code} + +\subsection{Generate step} + +\begin{code} +-- | Default implementation for the 'stepAll' function in 'Builder' +defaultStepAll :: Builder st it pa -> BuilderState st () +defaultStepAll b = + do s <- get + unless (finished b s) $ + do step b + defaultStepAll b +\end{code} + +\subsection{Dispatching new chart items} +\label{sec:dispatching} + +Dispatching consists of assigning a chart item to the right part of the +chart (agenda, trash, results list, etc). This is implemented as a +series of filters which can either fail or succeed. + +Counter-intuitively, success is defined as returning \verb!Nothing!. +Failure is defined as return \verb!Just!, because if a filter fails, it +has the right to modify the item for the next filter. For example, the +top and bottom unification filter succeeds if it \emph{cannot} unify +the top and bottom features of a node. It suceeds by putting the item +into the trash and returning Nothing. If it \emph{can} perform top and +bottom unification, we want to return the item where the top and bottom +nodes are unified. Failure is success, war is peace, freedom is +slavery, erase is backspace. + +\begin{code} +type DispatchFilter s a = a -> s (Maybe a) + +-- | Sequence two dispatch filters. +(>-->) :: (Monad s) => DispatchFilter s a -> DispatchFilter s a -> DispatchFilter s a +f >--> f2 = \x -> f x >>= maybe (return Nothing) f2 + +-- | A filter that always fails (i.e. no filtering) +nullFilter :: (Monad s) => DispatchFilter s a +nullFilter = return.Just + +-- | If the item meets some condition, use the first filter, otherwise +-- use the second one. +condFilter :: (Monad s) => (a -> Bool) + -> DispatchFilter s a -> DispatchFilter s a + -> DispatchFilter s a +condFilter cond f1 f2 = \x -> if cond x then f1 x else f2 x +\end{code} + +\subsection{Statistics} + +\begin{code} +addCounters :: Statistics -> Statistics -> Statistics +addCounters = mergeMetrics addIntMetrics + +modifyStats :: (Metric -> Metric) -> BuilderState st () +modifyStats fn = lift $ modify $ updateMetrics fn + +incrCounter :: String -> Int -> BuilderState st () +incrCounter key n = modifyStats (incrIntMetric key n) + +queryCounter :: String -> Statistics -> Maybe Int +queryCounter key s = + case queryMetrics (queryIntMetric key) s of + [] -> Nothing + [c] -> Just c + _ -> geniBug $ "More than one instance of the metric: " ++ key +\end{code} + +\subsection{Command line configuration} + +\begin{code} +initStats :: Params -> Statistics +initStats pa = + let identifyMs :: [String] -> [Metric] + identifyMs ["default"] = identifyMs defaultMetricNames + identifyMs ms = map namedMetric ms + metrics = identifyMs $ fromMaybe [] $ getFlagP MetricsFlg pa + in execState (mapM addMetric metrics) emptyStats + +namedMetric :: String -> Metric +-- the default case is that it's an int metric +namedMetric n = IntMetric n 0 + +-- Note that the strings here are command-line strings, not metric names! +defaultMetricNames :: [ String ] +defaultMetricNames = [ num_iterations, chart_size, num_comparisons ] +\end{code} + +\subsection{Common counters} + +These numbers allow us to keep track of how efficient our generator is +and where we are in the process (how many steps we've taken, etc) + +\begin{code} +num_iterations, chart_size, num_comparisons :: String + +num_iterations = "iterations" +chart_size = "chart_size" +num_comparisons = "comparisons" +\end{code} + +\section{The null builder} + +For the purposes of tracking certain statistics without interfering with the +lazy evaluation of the real builders. For example, one we would like to be +able to do is count the number of substitution and foot nodes in the lexical +selection. Doing so would in a real builder might cause it to walk entire +trees for ptoentially no good reason. + +\begin{code} +nullBuilder :: Builder () (NullState ()) Params +nullBuilder = Builder + { NLP.GenI.Builder.init = initNullBuilder + , step = return () + , stepAll = return () + , finished = const True + , unpack = return [] + , partial = return [] + } + +type NullState a = BuilderState () a + +initNullBuilder :: Input -> Params -> ((), Statistics) +initNullBuilder input config = + let countsFor ts = (length ts, length nodes, length sn, length an) + where nodes = concatMap (flatten.ttree) ts + sn = [ n | n <- nodes, gtype n == Subs ] + an = [ n | n <- nodes, gtype n == Foot ] + -- + (tsem,_,_) = inSemInput input + cands = map fst $ inCands input + (_,_,(_,_,aut,_)) = preInit input config + cands2 = concatMap concat $ automatonPathSets aut + -- + countUp = do incrCounter "sem_literals" $ length tsem + -- + incrCounter "lex_subst_nodes" snl + incrCounter "lex_foot_nodes" anl + incrCounter "lex_nodes" nl + incrCounter "lex_trees" tl + -- node count after polarities are taken into account + incrCounter "plex_subst_nodes" snl2 + incrCounter "plex_foot_nodes" anl2 + incrCounter "plex_nodes" nl2 + incrCounter "plex_trees" tl2 + where (tl , nl , snl , anl ) = countsFor cands + (tl2, nl2, snl2, anl2) = countsFor cands2 + in runState (execStateT countUp ()) (initStats config) +\end{code} + + diff --git a/src/NLP/GenI/BuilderGui.lhs b/src/NLP/GenI/BuilderGui.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/BuilderGui.lhs @@ -0,0 +1,34 @@ +% 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. + +\begin{code} +module NLP.GenI.BuilderGui +where + +import Graphics.UI.WX + +import qualified NLP.GenI.Builder as B +import NLP.GenI.Geni (ProgStateRef, GeniResult) +import NLP.GenI.Configuration (Params) +import NLP.GenI.Statistics (Statistics) +\end{code} + +\begin{code} +data BuilderGui = BuilderGui + { resultsPnl :: forall a . ProgStateRef -> (Window a) -> IO ([GeniResult],Statistics,Layout) + , debuggerPnl :: forall a . (Window a) -> Params -> B.Input -> String -> IO Layout } +\end{code} diff --git a/src/NLP/GenI/CkyEarley/CkyBuilder.lhs b/src/NLP/GenI/CkyEarley/CkyBuilder.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/CkyEarley/CkyBuilder.lhs @@ -0,0 +1,1243 @@ +% 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. + +\chapter{Cky builder} +\label{cha:CkyBuilder} + +GenI currently has three backends, SimpleBuilder (chapter +\ref{cha:SimpleBuilder}) the CKY and Earley which are both in this +module. This backend does not attempt to build derived trees at all. +We construct packed derivation trees using the CKY/Earley algorithm for +TAGs, and at the very end, we unpack the results directly into an +automaton. No derived trees here! + +\begin{code} +{-# LANGUAGE LiberalTypeSynonyms #-} +module NLP.GenI.CkyEarley.CkyBuilder + ( -- builder + ckyBuilder, earleyBuilder, + CkyStatus(..), + -- chart item + CkyItem(..), ChartId, + ciAdjDone, ciRoot, + extractDerivations, + -- automaton stuff (for the graphical debugger) + mJoinAutomata, mAutomatonPaths, emptySentenceAut, unpackItemToAuts, + -- + bitVectorToSem, findId, + ) +where +\end{code} + +\ignore{ +\begin{code} + +import Control.Monad + (unless, foldM) + +import Control.Monad.State + (State, gets, get, put, modify, runState, execStateT ) +import Data.Bits ( (.&.), (.|.) ) +import Data.List ( delete, find, span, (\\), intersect, union ) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe (catMaybes, mapMaybe, maybeToList) +import Data.Tree + +import NLP.GenI.Btypes + ( unify, collect + , Flist + , Replacable(..), Subst + , GNode(..), GType(Subs, Foot, Other) + , GeniVal(GVar), fromGVar + , Ptype(Auxiliar) + , root, foot + , unifyFeat, mergeSubst ) + +import NLP.GenI.Automaton + ( NFA(NFA, transitions, states), isFinalSt, finalSt, finalStList, startSt, addTrans, automatonPaths ) +import qualified NLP.GenI.Builder as B +import NLP.GenI.Builder + ( SentenceAut, incrCounter, num_iterations, chart_size, + SemBitMap, semToBitVector, bitVectorToSem, defineSemanticBits, + (>-->), DispatchFilter, + semToIafMap, IafAble(..), IafMap, fromUniConst, getIdx, + recalculateAccesibility, iafBadSem, ts_iafFailure + ) +import NLP.GenI.Configuration ( Params, isIaf ) +import NLP.GenI.General + ( fst3, combinations, treeLeaves, BitVector, geniBug ) +import NLP.GenI.Tags + ( TagElem, tidnum, ttree, tsemantics, ttype, + ts_tbUnificationFailure, TagSite(TagSite), detectSites + ) +import NLP.GenI.Statistics ( Statistics ) + +-- -- Debugging stuff +-- import Data.List ( intersperse ) +-- import Debug.Trace +-- import General ( showBitVector ) +-- import Tags ( idname ) +-- +-- ckyShow name item chart = +-- let showChart = show $ length chart +-- pad s n = s ++ (take (n - length s) $ repeat ' ') +-- in concat $ intersperse "\t" $ +-- [ pad name 10, showChart +-- , pad (idname $ ciSourceTree item) 10 +-- , pad (showItemSem item) 5 +-- , show $ ciNode item ] +-- +-- showItems = unlines . (map showItem) +-- showItem i = (idname.ciSourceTree) i ++ " " ++ show (ciNode i) ++ " " ++ (showItemSem i) +-- showItemSem = (showBitVector 5) . ciSemantics +\end{code} +} + +\section{Implementing the Builder interface} + +\begin{code} +type CkyBuilder = B.Builder CkyStatus CkyItem Params + +ckyBuilder, earleyBuilder :: CkyBuilder +ckyBuilder = ckyOrEarleyBuilder False +earleyBuilder = ckyOrEarleyBuilder True + +ckyOrEarleyBuilder :: Bool -> CkyBuilder +ckyOrEarleyBuilder isEarley = B.Builder + { B.init = initBuilder isEarley + , B.step = generateStep isEarley + , B.stepAll = B.defaultStepAll (ckyOrEarleyBuilder isEarley) + , B.finished = null.theAgenda + , B.unpack = \s -> concatMap (unpackItem s) $ theResults s + , B.partial = const [] -- FIXME: not implemented + } +\end{code} + +The rest of the builder interface is implemented below. I just +wanted to put the front-end functions up on top. + +% -------------------------------------------------------------------- +\section{Key types} +% -------------------------------------------------------------------- + +\subsection{CkyState and CkyStatus} + +This terminology might be a bit confusing: \verb!CkyState! is just a +\verb!BuilderState! monad parameterised over \verb!CkyStatus!. So, +status contains the actual data and state handles all the monadic stuff. + +\begin{code} +type CkyState a = B.BuilderState CkyStatus a + +data CkyStatus = S + { theAgenda :: Agenda + , theChart :: Chart + , theTrash :: Trash + , tsemVector :: BitVector -- the semantics in bit vector form + , theIafMap :: IafMap -- for index accessibility filtering + , gencounter :: Integer + , genconfig :: Params + , theRules :: [CKY_InferenceRule] + , theDispatcher :: CkyItem -> CkyState (Maybe CkyItem) + , theResults :: [CkyItem] + , genAutCounter :: Integer -- allocation of node numbers + } + +type Agenda = [CkyItem] +type Chart = [CkyItem] +type Trash = [CkyItem] +\end{code} + +Note the theTrash is not actually essential to the operation of the +generator; it is for pratical debugging of grammars. Instead of +trees dissapearing off the face of the debugger; they go into the +trash where the user can inspect them and try to figure out why they +went wrong. + +\subsubsection{CkyState getters and setters} + +\begin{code} +addToAgenda :: CkyItem -> CkyState () +addToAgenda te = do + modify $ \s -> s{ theAgenda = te : (theAgenda s) } + +addToResults :: CkyItem -> CkyState () +addToResults te = do + modify $ \s -> s{ theResults = te : (theResults s) } + +updateAgenda :: Agenda -> CkyState () +updateAgenda a = do + modify $ \s -> s{ theAgenda = a } + +addToChart :: CkyItem -> CkyState () +addToChart te = do + modify $ \s -> s { theChart = te : (theChart s) } + incrCounter chart_size 1 + +addToTrash :: CkyItem -> String -> CkyState () +addToTrash item err = do + let item2 = item { ciDiagnostic = err:(ciDiagnostic item) } + modify $ \s -> s { theTrash = item2 : (theTrash s) } +\end{code} + +\subsection{Chart items} + +-- TODO: decide if we want this to be an instant of Replacable +\begin{code} +data CkyItem = CkyItem + { ciNode :: GNode + -- things which should never change + , ciSourceTree :: TagElem + , ciOrigVariables :: [GeniVal] + -- + , ciPolpaths :: BitVector + , ciSemantics :: BitVector + , ciAdjPoint :: Maybe ChartId + -- | the semantics of the item when it was first initialised + , ciInitialSem :: BitVector + -- | unique identifier for this item + , ciId :: ChartId + -- names of the sisters of this node in its tree + , ciRouting :: RoutingMap + -- used by the next leaf rule (if active) + , ciPayload :: [CkyItem] + -- a list of genivals which were variables when the node was + -- first initialised + , ciVariables :: [GeniVal] + -- we keep a SemBitMap strictly to help display the semantics + , ciSemBitMap :: SemBitMap + -- what side of the spine are we on? (left if initial tree: no spine) + , ciTreeSide :: TreeSide + -- if there are things wrong with this item, what? + , ciDiagnostic :: [String] + -- what is the set of the ways you can produce this item? + , ciDerivation :: [ ChartOperation ] + -- what indices are accesible/inaccesible from this item? + , ciAccesible :: [ String ] -- it's acc/inacc/undetermined + , ciInaccessible :: [ String ] -- that's why you want both + , ciSubstnodes :: [ TagSite ] -- only used for iaf + } + +type ChartId = Integer + +-- | note that the order is always active item, followed by passive item +data ChartOperation = SubstOp ChartId ChartId + | AdjOp ChartId ChartId + | NullAdjOp ChartId + | KidsToParentOp [ChartId] + | InitOp + deriving Show -- for debugging + +type ChartOperationConstructor = ChartId -> ChartId -> ChartOperation + +ciRoot, ciFoot, ciSubs, ciAdjDone, ciAux, ciInit, ciComplete :: CkyItem -> Bool +ciRoot i = (gnname.ciNode) i == (gnname.root.ttree.ciSourceTree) i +ciFoot i = (gtype.ciNode) i == Foot +ciSubs i = (gtype.ciNode) i == Subs +ciAdjDone = gaconstr.ciNode +ciComplete i = (not.ciSubs $ i) && ciAdjDone i +ciAux i = (ttype.ciSourceTree) i == Auxiliar +ciInit = not.ciAux + +data TreeSide = LeftSide | RightSide | OnTheSpine + deriving (Eq) + +ciLeftSide, ciRightSide, ciOnTheSpine :: CkyItem -> Bool +ciLeftSide i = ciTreeSide i == LeftSide +ciRightSide i = ciTreeSide i == RightSide +ciOnTheSpine i = ciTreeSide i == OnTheSpine + + +-- basically, an inverted tree +-- from node name to a list of its sisters on the left, +-- a list of its sisters on the right, its parent +type RoutingMap = Map.Map String ([String], [String], GNode) +\end{code} + +% -------------------------------------------------------------------- +\section{Initialisation} +% -------------------------------------------------------------------- + +\begin{code} +initBuilder :: Bool -> B.Input -> Params -> (CkyStatus, Statistics) +initBuilder isEarley input config = + let (sem, _, _) = B.inSemInput input + bmap = defineSemanticBits sem + cands = concatMap (initTree isEarley bmap) $ B.inCands input + dispatchFn = ckyDispatch (isIaf config) + initS = S + { theAgenda = [] + , theChart = [] + , theTrash = [] + , theResults = [] + , theRules = map fst ckyRules + , tsemVector = semToBitVector bmap sem + , theIafMap = semToIafMap sem + , theDispatcher = dispatchFn + , gencounter = 0 + , genAutCounter = 0 + , genconfig = config } + in B.unlessEmptySem input config $ + runState (execStateT (mapM dispatchFn cands) initS) (B.initStats config) +\end{code} + +\subsection{Initialising a chart item} +\label{fn:cky:initTree} + +\begin{code} +initTree :: Bool -> SemBitMap -> (TagElem,BitVector) -> [CkyItem] +initTree ordered bmap tepp@(te,_) = + let semVector = semToBitVector bmap (tsemantics te) + createItem l n = item + { ciSemantics = semVector + , ciInitialSem = semVector + , ciSemBitMap = bmap + , ciRouting = decompose te + , ciVariables = map GVar $ Set.toList $ collect te Set.empty + , ciAccesible = iafNewAcc item + } where item = leafToItem l tepp n + -- + (left,right) = span (\n -> gtype n /= Foot) $ treeLeaves $ ttree te + items = map (createItem True) left ++ map (createItem False) right + in if ordered + then foldr (\i p -> [i { ciPayload = p }]) [] items + else items + +leafToItem :: Bool + -- ^ is it on the left of the foot node? (yes if there is none) + -> (TagElem, BitVector) + -- ^ what tree does it belong to + -> GNode + -- ^ the leaf to convert + -> CkyItem +leafToItem left (te,pp) node = CkyItem + { ciNode = node + , ciSourceTree = te + , ciPolpaths = pp + , ciSemantics = 0 -- to be set + , ciInitialSem = 0 -- to be set + , ciId = -1 -- to be set + , ciRouting = Map.empty -- to be set + , ciOrigVariables = [] -- to be set + , ciVariables = [] -- to be set + , ciPayload = [] -- to be set + , ciAdjPoint = Nothing + , ciSemBitMap = Map.empty + , ciTreeSide = spineSide + , ciDiagnostic = [] + , ciAccesible = [] -- to be set + , ciInaccessible = [] + , ciSubstnodes = (fst3.detectSites.ttree) te + , ciDerivation = [ InitOp ] } + where + spineSide | left = LeftSide + | gtype node == Foot = OnTheSpine + | otherwise = RightSide + +-- | explode a TagElem tree into a bottom-up routing map +decompose :: TagElem -> RoutingMap +decompose te = helper (ttree te) Map.empty + where + helper :: Tree GNode -> RoutingMap -> RoutingMap + helper (Node _ []) smap = smap + helper (Node p kidNodes) smap = + let kids = [ gnname x | (Node x _) <- kidNodes ] + addKid k = Map.insert k (left, right, p) + where (left, right') = span (/= k) kids + right = if null right' then [] else tail right' + smap2 = foldr addKid smap kids + in -- recurse to add routing info for child nodes + foldr helper smap2 kidNodes +\end{code} + +% -------------------------------------------------------------------- +\section{Generate} +% -------------------------------------------------------------------- + +Each iteration of the surface realisation step involves picking an item +off the agenda, applying all the relevant inference rules to it, and +dispatching the results. Lather, rinse, repeat. At some point we just +run out of things on the agenda and stop. + +Well, ok, there are ways that this thing could loop infinitely: for +example, having null semantic lexical items would be a very bad thing. + +\begin{code} +generateStep :: Bool -> CkyState () +generateStep isEarley = + do -- this check may seem redundant with generate, but it's needed + -- to protect against a user who calls generateStep on a finished + -- state + isFinished <- gets finished + unless (isFinished) (generateStep2 isEarley) + +generateStep2 :: Bool -> CkyState () +generateStep2 isEarley = + do st <- get + -- incrGeniter 1 + agendaItem <- selectAgendaItem + -- try the inference rules + let chart = theChart st + apply rule = rule agendaItem chart + results = map apply (theRules st) + -- see comments below about ordered substitution + releasePayload = not (null results) || ciComplete agendaItem + payload = if releasePayload && isEarley + then ciPayload agendaItem else [] + -- put all newly generated items into the right pigeon-holes + -- trace (concat $ zipWith showRes ckyRules results) $ + let dispatcher = theDispatcher st + mapM dispatcher $ payload ++ (concat results) + addToChart agendaItem + incrCounter num_iterations 1 + return () + +selectAgendaItem :: CkyState CkyItem +selectAgendaItem = do + a <- gets theAgenda + updateAgenda (tail a) + return (head a) + +finished :: CkyStatus -> Bool +finished = null.theAgenda +\end{code} + +% -------------------------------------------------------------------- +\section{CKY Rules} +% -------------------------------------------------------------------- + +Our surface realiser is defined by a set of inference rules. Since we are +using an agenda-based algorithm, we define our inference rules to take two +arguments: the agenda item and the entire chart. It is up to the inference +rule to filter the chart for the items which can combine with the agenda item. +If a rule is not applicable, it should simply return the empty list. + +\begin{code} +type InferenceRule a = a -> [a] -> [a] +type CKY_InferenceRule = InferenceRule CkyItem + +instance Show CKY_InferenceRule where + show _ = "cky inference rule" +\end{code} + +% FIXME: diagram and comment + +\begin{code} +ckyRules :: [ (CKY_InferenceRule, String) ] +ckyRules = + [ (parentRule, "parent") + , (substRule , "subst") + , (nonAdjunctionRule, "nonAdj") + , (activeAdjunctionRule, "actAdjRule") + , (passiveAdjunctionRule, "psvAdjRule") ] + +parentRule, substRule, nonAdjunctionRule, activeAdjunctionRule, passiveAdjunctionRule :: CKY_InferenceRule + +-- | CKY non adjunction rule - creates items in which +-- we do not apply any adjunction +-- this rule also doubles as top +nonAdjunctionRule item _ = + let node = ciNode item + node2 = node { gaconstr = True } + in if gtype node /= Other || ciAdjDone item then [] + else [ item { ciNode = node2 + , ciPayload = [] + , ciDerivation = [ NullAdjOp $ ciId item ] } ] +\end{code} + +\subsection{Parent rule} + +WARNING: unproven code below! There is a piece of code floating around +here which attempts to make the parent rule go a little bit faster and +could eventually be used to replace \verb!ciSubsts! altogether. But +somebody needs to sit down and prove that this is correct first. + +The basic problem is that you've got some child nodes from a tree and +you want to know if you can use them to climb up to the parent node. +Consider for instance the tree $(P:?X L:?X R:?X)$, that is a +simple tree with two child nodes with a shared variable $?X$ on all +nodes. Your two jobs are to +\begin{enumerate} +\item Make sure that the assignments of $?X$ do not conflict, for +example, if in your instance of $L$, you have $?X \leftarrow a$ and in +$R$, you have $?X \leftarrow b$, that would be bad and you should rule +it out. +\item Propagate any assignments of $?X$ up to the parent node. +\end{enumerate} + +A naïve ``safe'' solution then seems to be that you have to unify +together all instances of the child nodes: that is, in the example +above, you need to unify $L$ with $R$'s idea of what $L$ is and vice +versa, and then somehow propaagate everything up. Keep in mind that +this is not the same thing as unifying $L$ with $R$ (why on earth would +you want to do something like that?). I don't like this solution, +because I get the impression that it makes us do a lot of unification +for nothing. + +Ok, so how do we go about making this cheaper to perform? Here is what +I ended up implementing: in the initialisation phase, you collect a set +of open variables for each tree. This is the initial value of +\verb!ciVariables!. Now, whenever you do anything with a chart item, +for example, unifying some feature structure because of adjunction, you +take care to also apply the variable replacements to the +\verb!ciVariables! list. This way, it always contains the +latest values for what were the open variables of the original tree. +When you apply the parent rule, so goes the unproven idea, all you have +to do is unify \verb!ciVariables! for all the child nodes. In order +to propagate this to the parent node, you have to remember what the +original values for \verb!ciVariables! was and use that to create a +new replacements list. Let's work this out with a concrete example: + +\begin{enumerate} +\item You've got the source tree in figure +\ref{fig:variableCollection-01-04} with two open variables, $?X$ and +$?Y$. +\item Substitution into one of the nodes gives you the replacement +$?Y \leftarrow b$ +\item Our first application of the parent rule: we climb up to the next +node, rather trivially here since there is only one child +\item This parent node $L$ receives adjunction, which sets the variable +$?X \leftarrow a$ +\item (figure \ref{fig:variableCollection-05-06}) Independently of all +this, we substitute something into the other side of the tree. This +sets $?X \leftarrow c$. We don't know yet that this is a conflict with +the previous step because we haven't tried applying the parent rule yet. +\item But when we try to apply the parent rule here between the child +$L$ and this version of the child $R$, we get a failure because their +two instances of \verb!ciVariables! fail to unify ($a \neq c$). +\item (figure \ref{fig:variableCollection-07-09}) We've seen what failure +looks like, so let's try for success. Say we had substituted something +different into $R$ and as a result, we get the assignement $?X +\leftarrow b$. +\item This time, unification between the \verb!ciVariables! from the +children $L$ and $R$ actually succeeds, so we allow the parent rule +to apply. +\item Notice that the same \verb!ciVariables! unification mechanism +also propagates up the assignemnt $?Y \leftarrow a$ +\end{enumerate} + +\begin{figure} +\begin{center} +\includegraphics[scale=0.5]{images/variableCollection-01-04} +\caption{Variable collections example (part 1/3)} +\label{fig:variableCollection-01-04} +\end{center} +\end{figure} +\begin{figure} +\begin{center} +\includegraphics[scale=0.5]{images/variableCollection-05-06} +\caption{Variable collections example (part 2/3)} +\label{fig:variableCollection-05-06} +\end{center} +\end{figure} +\begin{figure} +\begin{center} +\includegraphics[scale=0.5]{images/variableCollection-07-09} +\caption{Variable collections example (part 3/3)} +\label{fig:variableCollection-07-09} +\end{center} +\end{figure} + +\begin{code} +-- | CKY parent rule +parentRule item chart | ciComplete item = + do (leftS,rightS,p) <- maybeToList $ Map.lookup (gnname node) (ciRouting item) + let mergePoints kids = + case mapMaybe ciAdjPoint (item:kids) of + [] -> Nothing + [x] -> Just x + _ -> error "multiple adjunction points in parentRule?!" + combine par kids = do + let unifyOnly (x, _) y = maybeToList $ unify x y + -- IMPORTANT! This blocks the parent rule from applying + -- if the child variables don't unify. + (newVars, _) <- foldM unifyOnly (ciVariables item, Map.empty) $ + map ciVariables kids + let newSubsts = Map.fromList $ zip (map fromGVar $ ciOrigVariables item) newVars + newSide | all ciLeftSide kids = LeftSide + | all ciRightSide kids = RightSide + | any ciOnTheSpine kids = OnTheSpine + | otherwise = geniBug $ "parentRule: Weird situtation involving tree sides" + newItem = item + { ciNode = replace newSubsts par + , ciAdjPoint = mergePoints kids + , ciVariables = newVars + , ciTreeSide = newSide + , ciDerivation = [ KidsToParentOp $ map ciId kids ] + , ciPayload = [] + , ciSubstnodes = foldr intersect (ciSubstnodes item) $ map ciSubstnodes kids + -- does union make sense? + , ciAccesible = foldr union (ciAccesible item) $ map ciAccesible kids + , ciInaccessible = foldr union (ciInaccessible item) $ map ciInaccessible kids + } + return $ foldr combineVectors newItem kids + let leftMatches = map matches leftS + rightMatches = map matches rightS + allMatches = leftMatches ++ ([item] : rightMatches) + -- trace (" relevant chart: (" ++ (show $ length relChart) ++ ") " ++ showItems relChart) $ + -- trace (" routing info: " ++ show (s,p,r)) $ + -- trace (" matches: (" ++ (show $ length allMatches) ++ ") " ++ (concat $ intersperse "-\n" $ map showItems allMatches)) $ + combinations allMatches >>= combine p + where + node = ciNode item + sourceOf = tidnum.ciSourceTree + -- + relevant c = (sourceOf c == sourceOf item) && ciComplete c + -- make sure the semantics only overlap in the initial parts + && (ciSemantics c) .&. (ciSemantics item) == (ciInitialSem item) + relChart = filter relevant chart + -- + matches :: String -> [CkyItem] + matches sis = [ c | c <- relChart, (gnname.ciNode) c == sis ] +parentRule _ _ = [] -- if this rule is not applicable to the item at hand +\end{code} + +\subsection{Substitution} + +The substitution rule has two variants: either the agenda item is active, +meaning it is a root node and is trying to subsitute into something; or it +is passive, meaning that is a substitution node waiting to receive +substitution on something. + +\begin{code} +-- | CKY subst rules +substRule item chart = catMaybes $ + if ciSubs item + then [ attemptSubst item r | r <- chart, compatibleForSubstitution r item ] + else [ attemptSubst s item | s <- chart, compatibleForSubstitution item s ] + +-- | unification for substitution +attemptSubst :: CkyItem -> CkyItem -> Maybe CkyItem +attemptSubst sItem rItem | ciSubs sItem = + do let rNode = ciNode rItem + sNode = ciNode sItem + (up, down, subst) <- unifyGNodes sNode (ciNode rItem) + let newNode = rNode { gnname = gnname sNode + , gup = up, gdown = down } + newItem = combineWithSubst newNode subst rItem sItem + return $ newItem +attemptSubst _ _ = error "attemptSubst called on non-subst node" + +-- | return True if the first item may be substituted into the second +-- as long as unification and all the nasty details work out +compatibleForSubstitution :: CkyItem -- ^ active item + -> CkyItem -- ^ passive item + -> Bool +compatibleForSubstitution a p = + ciRoot a && ciComplete a && ciInit a + && ciSubs p + && compatible a p +\end{code} + +\subsection{Adjunction} + +As with substitution, the adjunction rule has two variants: either the agenda +item is active, meaning it is the root node of an auxliary tree is trying +to adjoin into something; or it is passive, meaning it is a node which is +waiting to receive adjunction. + +Note that unlike the substitution rule, we have to split these two variants +into two actual rules. This is because we also want auxiliary tree nodes +to be able to receive adjunction and not just perform it! + +\begin{code} +-- | CKY adjunction rule: note - we need this split into two rules because +-- both variants could fire at the same time, for example, the passive variant +-- to adjoin into the root of an auxiliary tree, and the active variant because +-- it is an aux tree itself and it wants to adjoin somewhere +activeAdjunctionRule item chart | ciRoot item && ciAux item = + mapMaybe (\p -> attemptAdjunction p item) + [ p | p <- chart, compatibleForAdjunction item p ] +activeAdjunctionRule _ _ = [] -- if not applicable + +-- | CKY adjunction rule: we're just a regular node, minding our own business +-- looking for an auxiliary tree to adjoin into us +passiveAdjunctionRule item chart = + mapMaybe (attemptAdjunction item) + [ a | a <- chart, compatibleForAdjunction a item ] + +attemptAdjunction :: CkyItem -> CkyItem -> Maybe CkyItem +attemptAdjunction pItem aItem | ciRoot aItem && ciAux aItem = + -- trace ("try adjoining " ++ (showItem aItem) ++ " into " ++ (showItem pItem)) $ + do let aRoot = ciNode aItem + aFoot = (foot.ttree.ciSourceTree) aItem-- could be pre-computed? + pNode = ciNode pItem + (newTop, _ , subst) <- unifyPair (gup pNode, gdown pNode) + (gup aRoot, gdown aFoot) + let newNode = pNode { gaconstr = False, gup = newTop, gdown = [] } + newItem = combineWith AdjOp newNode subst aItem pItem + return newItem +attemptAdjunction _ _ = error "attemptAdjunction called on non-aux or non-root node" + +-- | return True if the first item may be adjoined into the second +-- as long as unification and all the nasty details work out +compatibleForAdjunction :: CkyItem -- ^ active item + -> CkyItem -- ^ passive item + -> Bool +compatibleForAdjunction a p = + ciAux a && ciRoot a && ciAdjDone a + && (gtype.ciNode) p == Other && (not.ciAdjDone) p + && compatible a p +\end{code} + +\subsection{Helpers for inference rules} + +\begin{code} +isLexeme :: GNode -> Bool +isLexeme = not.null.glexeme + +-- | return True if the chart items may be combined with each other; for now, this +-- consists of a semantic check +compatible :: CkyItem -> CkyItem -> Bool +compatible a b = ( (ciSemantics a) .&. (ciSemantics b) ) == 0 + && ( (ciPolpaths a) .|. (ciPolpaths b) ) /= 0 +\end{code} + +To factorise the construction of new items, we provide two functions for combining +two chart items. \fnreflite{combineVectors} merely combines the easy stuff (the +semantic bit maps and the polarity paths). \fnreflite{combineWith} does the +heavier stuff like the list of open variables and the derivation for the new item. +The reason we expose \fnreflite{combineVectors} as a separate function is because +the \fnreflite{kidsToParentsRule} needs it. + +\begin{code} +combineVectors :: CkyItem -> CkyItem -> CkyItem +combineVectors a b = + b { ciSemantics = (ciSemantics a) .|. (ciSemantics b) + , ciPolpaths = (ciPolpaths a) .&. (ciPolpaths b) + , ciSemBitMap = ciSemBitMap a } + +combineWithSubst :: GNode -> Subst -> CkyItem -> CkyItem -> CkyItem +combineWithSubst node subst a p = + newPassive { ciAccesible = (ciAccesible a) `union` (ciAccesible p) + , ciInaccessible = (ciInaccessible a) `union` (ciInaccessible p) + , ciSubstnodes = newCiSubstnodes } + where newCiSubstnodes = [ t | t@(TagSite x _ _ _) <- ciSubstnodes p, x /= gnname node ] + newPassive = combineWith SubstOp node subst a p + +combineWith :: ChartOperationConstructor -- ^ how did we get the new item? + -> GNode -> Subst -> CkyItem -> CkyItem -> CkyItem +combineWith operation node subst active passive = + combineVectors active $ + passive { ciNode = node + , ciPayload = [] + , ciVariables = replace subst (ciVariables passive) + , ciDerivation = [ operation (ciId active) (ciId passive) ] } +\end{code} + +\paragraph{unifyTagNodes} performs feature structure unification +on TAG nodes. First we try unification on the top node. We +propagate any results from that unification and proceed to trying +unification on the bottom nodes. If succesful, we return the +results of both unifications and a list of substitutions to +propagate. Otherwise we return Nothing. + +\begin{code} +unifyGNodes :: GNode -> GNode -> Maybe (Flist, Flist, Subst) +unifyGNodes g1 g2 = + unifyPair (gupdown g1) (gupdown g2) + where gupdown n = (gup n, gdown n) + +unifyPair :: (Flist, Flist) -> (Flist, Flist) -> Maybe (Flist, Flist, Subst) +unifyPair (t1, b1) (t2, b2) = + do (newTop, subst1) <- unifyFeat t1 t2 + (newBot, subst2) <- unifyFeat (replace subst1 b1) (replace subst1 b2) + return (newTop, newBot, mergeSubst subst1 subst2) +\end{code} + +% -------------------------------------------------------------------- +\section{Dispatching new chart items} +% -------------------------------------------------------------------- + +We use the generic dispatch mechanism described in section \ref{sec:dispatch}. + +\begin{code} +type CKY_DispatchFilter = DispatchFilter CkyState CkyItem + +ckyDispatch :: Bool -- ^ index accessibility filtering + -> CKY_DispatchFilter +ckyDispatch iaf = + dispatchTbFailure >--> dispatchRedundant >--> dispatchResults >--> + (if iaf then dispatchIafFailure >--> dispatchToAgenda + else dispatchToAgenda) + +dispatchToAgenda, dispatchRedundant, dispatchResults, dispatchTbFailure :: CKY_DispatchFilter + +-- | Trivial dispatch filter: always put the item on the agenda and return +-- Nothing +dispatchToAgenda item = + do addToAgenda item + return Nothing + +-- | If the item can merge with another, merge it with the equivalent +-- item and return Nothing. +-- If the item is indeed unique, return (Just $ setId item) +dispatchRedundant item = + do st <- get + let chart = theChart st + mergeEquivItems o = + let equiv = canMerge o item + in (equiv, if equiv then mergeItems o item else o) + (isEq, newChart) = unzip $ map mergeEquivItems chart + -- + if or isEq + then -- trace (ckyShow "-> merge" item []) $ + do put ( st {theChart = newChart} ) + return Nothing + else do s <- get + let counter = gencounter s + put $ s { gencounter = counter + 1 } + return $ Just $ item { ciId = counter } + +-- | If it is a result, put the item in the results list. +-- Otherwise, return (Just unmodified) +dispatchResults item = + do st <- get + let synComplete = ciInit item && ciRoot item && ciAdjDone item + semComplete = tsemVector st == ciSemantics item + -- + if (synComplete && semComplete ) + then -- trace ("isResult " ++ showItem item) $ + addToResults item >> return Nothing + else return $ Just item + +-- | This filter requires another inversion in thinking. It suceeds +-- if tb unification fails by dispatching to the trash and returning +-- Nothing. If tb unification suceeds, it returns (Just newItem), +-- where newItem has its top and bottom nodes unified. +dispatchTbFailure itemRaw = + case tbUnify itemRaw of + Nothing -> + do addToTrash itemRaw ts_tbUnificationFailure + return Nothing + Just item -> return $ Just item + +tbUnify :: CkyItem -> Maybe CkyItem +-- things for which tb unification is not relevant +tbUnify item | ciFoot item = return item +tbUnify item | (not.ciAdjDone) item = return item +-- ok, here, we should do tb unification +tbUnify item = + do let node = ciNode item + (newTop, sub1) <- unifyFeat (gup node) (gdown node) + -- it's not enough if t/b unification succeeds by itself + -- we also have to check that these unifications propagate alright + let origVars = ciOrigVariables item + treeVars = ciVariables item + nodeVars = replace sub1 origVars + (newVars, _) <- unify treeVars nodeVars + return $ item + { ciNode = node { gup = newTop, gdown = [] } + , ciVariables = newVars } +\end{code} + +% -------------------------------------------------------------------- +\subsection{Equivalence classes} +\label{sec:cky:merging} +% -------------------------------------------------------------------- + +\fnlabel{canMerge} returns true if two chart items are allowed to merge. +We do not allow items to merge when they are not "complete", because that +would complicate things like the right sister rule. + +\begin{code} +canMerge :: CkyItem -> CkyItem -> Bool +canMerge c1 c2 = ciComplete c1 && ciComplete c2 && stuff c1 == stuff c2 + where stuff x = ( ciNode x, ciSourceTree x, ciSemantics x, ciPolpaths x ) +\end{code} + +\fnlabel{mergeItems} combines two chart items into one, with the +assumption being that you have already determined that they can be +merged. Information from the second ``slave'' item is merged +into information from the first ``master'' item. + +\begin{code} +mergeItems :: CkyItem -> CkyItem -> CkyItem +mergeItems master slave = + master { ciDerivation = ciDerivation master ++ (ciDerivation slave) } +\end{code} + +Note that we do not perform index accesibility filtering on auxiliary +trees. What we're after here is delayed substitution, meaning that we +don't do any substitution until the adjunctions are done. If an +auxiliary tree has substitution nodes, this puts us in the paradoxical +situation where we're trying to delay a substitution which we need in +order to perform an adjunction. + +Consider for example, the semantics \texttt{john(j) ask(e1 j e2) go(e2 +j w) where(w)} which we intend to realise as \natlang{John asks where to +go}. Depending on your grammar, one conceivable way to realise this is +as an initial tree for ``to go'', and an auxiliary tree for ``asks'' (a +sentential modifier). You plug ``where'' into ``to go'' to get ``where +to go'' and ``John'' into ``asks''. This gives you an auxiliary tree +``John asks'' which adjoins into another tree ``where to go''. Now the +problem is that if you enable iaf on auxiliary trees, you're not going +to be able to construct the ``John asks'' tree because it thinks that +by doing so, you have sealed off access to the \texttt{j} index in +\texttt{go(e2 j w)}. Conclusion: iaf on auxiliary trees is a no-no. + +\begin{code} +instance IafAble CkyItem where + iafAcc = ciAccesible + iafInacc = ciInaccessible + iafSetAcc a i = i { ciAccesible = a } + iafSetInacc a i = i { ciInaccessible = a } + iafNewAcc i = + concatMap fromUniConst $ replaceList r $ + concat [ getIdx u | (TagSite _ u _ _) <- ciSubstnodes i ] + where r = zip (map fromGVar $ ciOrigVariables i) + (ciVariables i) + +dispatchIafFailure :: CkyItem -> CkyState (Maybe CkyItem) +dispatchIafFailure item | ciAux item = return $ Just item +dispatchIafFailure itemRaw = + do s <- get + let bmap = ciSemBitMap item + item = recalculateAccesibility itemRaw + badSem = iafBadSem (theIafMap s) bmap (tsemVector s) ciSemantics item + inAcc = iafInacc item + if badSem == 0 + then -- can't dispatch, but that's good! + -- (note that we return the item with its iaf criteria updated) + return $ Just item + else do addToTrash item (ts_iafFailure inAcc $ bitVectorToSem bmap badSem) + return Nothing +\end{code} + +% -------------------------------------------------------------------- +\section{Unpacking the chart} +% -------------------------------------------------------------------- + +\begin{code} +unpackItem :: CkyStatus -> CkyItem -> [B.Output] +unpackItem st it = + zip (mAutomatonPaths $ uncurry mJoinAutomata $ unpackItemToAuts st it) + (repeat []) + +type SentenceAutPairMaybe = (Maybe SentenceAut, Maybe SentenceAut) + +unpackItemToAuts :: CkyStatus -> CkyItem + -- left and right automata + -> SentenceAutPairMaybe +unpackItemToAuts st item = + case map aut derivations of + [] -> (Nothing, Nothing) + (a:as) -> foldr pairUnion a as + where + pairUnion (l1,r1) (l2,r2) = (mUnionAutomata l1 l2, mUnionAutomata r1 r2) + derivations = ciDerivation item + retrieve = findIdOrBug st + -- these are fleshed out in the paragraphs below + aut (KidsToParentOp k) = unpackKidsToParentOp st $ map retrieve k + aut (NullAdjOp p) = unpackNullAdjOp st $ retrieve p + aut (SubstOp a p) = unpackSubstOp st (retrieve a) (retrieve p) + aut (AdjOp a p) = unpackAdjOp st (retrieve a) (retrieve p) + aut InitOp = unpackInitOp st item +\end{code} + +\paragraph{Leaf nodes} + +\begin{code} +unpackInitOp :: CkyStatus -> CkyItem -> SentenceAutPairMaybe +unpackInitOp _ item = + let node = ciNode item + -- we have to add a transition for each choice in the lexical + -- atomic disjunction + lexAut = foldr (\l a -> addTrans a 0 (via l) 1) iAut (glexeme node) + via l = Just (l, gup node) + iAut = emptySentenceAut { startSt = 0 + , finalStList = [1] + , states = [[0,1]]} + in if isLexeme node + then case ciTreeSide item of + LeftSide -> (Just lexAut, Nothing) + RightSide -> (Nothing, Just lexAut) + OnTheSpine -> (Nothing, Nothing) + else (Nothing, Nothing) + +emptySentenceAut :: SentenceAut +emptySentenceAut = + NFA { startSt = (-1) + , isFinalSt = Nothing + , finalStList = [] + , transitions = Map.empty + , states = [[]] } +\end{code} + +\paragraph{Null adjunction} is a trivial case; we just propagate the automaton upwards. + +\begin{code} +unpackNullAdjOp :: CkyStatus -> CkyItem -> SentenceAutPairMaybe +unpackNullAdjOp st psv = unpackItemToAuts st psv +\end{code} + +\paragraph{Substitution} would be as simple as null adjunction, were it +not for auxiliary trees. When dealing with an auxiliary tree, we need +to be careful which side of the spine we substitute into. For those of +you not so familiar with TAG, the spine is the path from root node to +the foot node of an auxiliary tree. + +If we're on the left side of the spine, we propagate into the left +automaton. Likewise, we propagate into the right autamaton if we're on +the right side of the spine. If we're trying to substitute \emph{into} +the spine, we're in trouble. + +\begin{code} +unpackSubstOp :: CkyStatus -> CkyItem -> CkyItem -> SentenceAutPairMaybe +unpackSubstOp st act psv = + case ciTreeSide psv of + LeftSide -> (actAut, Nothing) + RightSide -> (Nothing, actAut) + OnTheSpine -> geniBug $ "Tried to substitute on the spine!" + where actAut = fst $ unpackItemToAuts st act +\end{code} + +\paragraph{Adjunction} involves joining the left sides of both items +together as well as the right side. This is probably best explained +with a picture: + +FIXME: insert figure + +\begin{code} +unpackAdjOp :: CkyStatus -> CkyItem -> CkyItem -> SentenceAutPairMaybe +unpackAdjOp st act psv = + let (actL, actR) = unpackItemToAuts st act + (psvL, psvR) = unpackItemToAuts st psv + newAutL = mJoinAutomata actL psvL + newAutR = mJoinAutomata psvR actR + newAut = mJoinAutomata newAutL newAutR + in case ciTreeSide psv of + LeftSide -> (newAut, Nothing) + RightSide -> (Nothing, newAut) + OnTheSpine -> (newAutL, newAutR) +\end{code} + +\paragraph{The kids to parents rule} is complicated because of auxiliary +trees. As usual, there are three cases: + +\begin{itemize} +\item On the left of the spine: we concatenate all the left + automata of the kids +\item On the right of the spine: we concatenate all the right + automata of the kids +\item On the spine itself: we concatenate all the left automata + of the stuff on the left of the spine and propagate that + as our left side. Similarly, we concatenate all the right + automata of the stuff on the right of the spine and send + that up the right side. +\end{itemize} + +\begin{code} +unpackKidsToParentOp :: CkyStatus -> [CkyItem] -> SentenceAutPairMaybe +unpackKidsToParentOp st kids = + let (bef, aft) = span (not.ciOnTheSpine) kids + (befL, befR) = unzip $ map (unpackItemToAuts st) bef + concatAut_ theLast auts = foldr mJoinAutomata theLast auts + concatAut = concatAut_ Nothing + in case aft of + -- two cases in one! (we expect one of these to be Nothing) + -- we're either on the left or the right of the spine + [] -> ( concatAut befL, concatAut befR ) + -- we are on the spine: we attach the left automaton of the + -- spinal child to the other left automata and likewise, + -- its right automaton to the rest of the right automata + (spi:aft2) -> + let (spiL, spiR) = unpackItemToAuts st spi + (_ , aftR) = unzip $ map (unpackItemToAuts st) aft2 + in ( concatAut_ spiL befL, concatAut (spiR:aftR) ) +\end{code} + +\subsection{Core automaton stuff} + +Note: you might be tempted to move this code to the generic Automaton library. +In order to do this, you will have to introduce a geniric notion of +state-renaming to the library. I didn't want to bother with any of that. + +\begin{code} +mUnionAutomata :: Maybe SentenceAut -> Maybe SentenceAut -> Maybe SentenceAut +mUnionAutomata Nothing mAut2 = mAut2 +mUnionAutomata mAut1 Nothing = mAut1 +mUnionAutomata (Just aut1) (Just aut2) = Just $ unionAutomata aut1 aut2 + +-- | Merge two sentence automata together. This essentially calculates the +-- union of the two automata and "pinches" their final states together. +-- FIXME: could be much more sophisticated and produce smaller automata! +unionAutomata :: SentenceAut -> SentenceAut -> SentenceAut +unionAutomata aut1 rawAut2 = + let -- rename all the states in aut2 so that they don't overlap + aut1Max = foldr max (-1) $ concat $ states aut1 + aut2 = incrStates (1 + aut1Max) rawAut2 + -- make the start state of the new automaton also transition + -- everything that the from the start state of aut2 transitions to + t1 = transitions aut1 + t2 = transitions aut2 + aut2Start = startSt aut2 + addAut2Trans = Map.unionWith (++) $ Map.findWithDefault Map.empty aut2Start t2 + newT1 = Map.adjust addAut2Trans (startSt aut1) t1 + newT2 = Map.delete aut2Start t2 + in aut1 { states = [ delete aut2Start $ concat $ states aut1 ++ states aut2 ] + , transitions = Map.union newT1 newT2 + , isFinalSt = do -- in the Maybe Monad + f1 <- isFinalSt aut1 + f2 <- isFinalSt aut2 + return $ \s -> f1 s || f2 s + , finalStList = finalStList aut1 ++ finalStList aut2 } +\end{code} + +It's important not to confuse \fnreflite{joinAutomata} with +\fnreflite{unionAutomata}. Joining automata is basically concatenation, +putting the second automaton after the first one. +Interestingly, their implementations have a lot in common. +FIXME: it might be worth refactoring the two. + +\begin{code} +mJoinAutomata :: Maybe SentenceAut -> Maybe SentenceAut -> Maybe SentenceAut +mJoinAutomata Nothing mAut2 = mAut2 +mJoinAutomata mAut1 Nothing = mAut1 +mJoinAutomata (Just aut1) (Just aut2) = Just $ joinAutomata aut1 aut2 + +-- | Concatenate two sentence automata. This merges the final state of the +-- first automaton into the initial state of the second automaton. +joinAutomata :: SentenceAut -> SentenceAut -> SentenceAut +joinAutomata aut1 rawAut2 = + let -- rename all the states in aut2 so that they don't overlap + aut1Max = (maximum.concat.states) aut1 + aut2 = incrStates (1 + aut1Max) rawAut2 + -- replace all transitions to aut1's final st by + -- transitions to aut2's start state + aut1Final = finalSt aut1 + aut2Start = startSt aut2 + t1 = transitions aut1 + t2 = transitions aut2 + updateKey k m = case Map.lookup k m of + Nothing -> m + Just v -> Map.insert aut2Start v (Map.delete k m) + replaceFinal (f,t) = (f, foldr updateKey t aut1Final) + newT1 = Map.fromList $ map replaceFinal $ Map.toList t1 + newStates1 = map (\\ aut1Final) $ states aut1 + -- + in aut1 { states = [ concat $ newStates1 ++ states aut2 ] + , transitions = Map.union newT1 t2 + , isFinalSt = isFinalSt aut2 + , finalStList = finalStList aut2 } + +incrStates :: Int -> SentenceAut -> SentenceAut +incrStates prefix aut = + let -- increment a state + addP_s = (prefix +) + -- increment all the states involved in a transition + addP_t (st,l) = (addP_s st, Map.mapKeys addP_s l) + in aut { startSt = addP_s (startSt aut) + , states = map (map addP_s) $ states aut + , transitions = Map.fromList $ map addP_t $ + Map.toList $ transitions aut + , finalStList = map addP_s $ finalStList aut } + +mAutomatonPaths :: (Ord st, Ord ab) => Maybe (NFA st ab) -> [[ab]] +mAutomatonPaths Nothing = [] +mAutomatonPaths (Just x) = automatonPaths x +\end{code} + +\subsection{Item history} + +We don't ever really need to calculate the derivation tree for an item. +Don't get me wrong, we certainly calculate something which looks a lot +like a derivation tree and contains more or less the same stuff, but not +a derivation tree per se. + +On the otherhand, debugging the generator is \emph{much} easier if you +can get a graphical representation for an item. This is like a +derivation tree with way too much detail. We calculate a tree-like +representation of the history of inference rule applications for this +item. + +Note that because of equivalence classes, an item can be seen as having +more than one derivation. We abstract around this fact simply by +implementing the function with a \verb!List! monad. + +\begin{code} +-- | Returns all the derivations trees for this item: note that this is +-- not a TAG derivation tree but a history of inference rule applications +-- in tree form +extractDerivations :: CkyStatus -> CkyItem -> [ Tree (ChartId, String) ] +extractDerivations st item = + do chartOp <- ciDerivation item + case chartOp of + KidsToParentOp kids -> + do kidTrees <- mapM treeFor kids + createNode "kids" kidTrees + SubstOp act psv -> + do actTree <- treeFor act + let psvTree = Node (psv, "subst") [ actTree ] + createNode "subst-finish" [psvTree] + AdjOp act psv -> + do actTree <- treeFor act + let psvTree = Node (psv, "adj") [ actTree ] + createNode "adj-finish" [psvTree] + NullAdjOp psv -> + do psvTree <- treeFor psv + createNode "no-adj" [psvTree] + InitOp -> createNode "init" [] + where + createNode op kids = + return $ Node (ciId item, op) kids + treeFor i = + case findId st i of + Nothing -> geniBug $ "derivation for item " ++ (show $ ciId item) + ++ "points to non-existent item " ++ (show i) + Just x -> extractDerivations st x +\end{code} + +\subsection{Helpers for unpacking} + +\begin{code} +findId :: CkyStatus -> ChartId -> Maybe CkyItem +findId st i = find (\x -> ciId x == i) $ theChart st ++ (theAgenda st) ++ (theResults st) ++ (theTrash st) + +-- | The same as 'findId' but calls 'geniBug' if not found +findIdOrBug :: CkyStatus -> ChartId -> CkyItem +findIdOrBug st i = + case findId st i of + Nothing -> geniBug $ "Cannot find item in chart with id " ++ (show i) + Just x -> x +\end{code} + +\section{Optimisations} + +\paragraph{Earley-style derivation} + +The idea is that we to perform substitutions in a fixed order so that we avoid +generating a lot of useless chart items that aren't going to be used in a final +result anyway. + +We implement this in two places. In the initialisation phase, (page +\pageref{fn:cky:initTree}), we avoid placing all the leaf items onto the +agenda. Instead, we make each leaf node point to the next leaf, as +with a singly linked list, and put the head of that list on the agenda. +The second part of this is implemented below as an inference rule which +takes only complete items (i.e. items for which there is no need to +perform substitution) and releases their payload. + +Note that in order for this to work, we also had to introduce a +restriction into chart item merging (page \pageref{sec:cky:merging}) +that no two items may merge if they are not complete in the same sense +as this inference rule. Otherwise, we'd have to think find a way to +make sure that payloads get released correctly (which might not be as +hard as I first thought). + + diff --git a/src/NLP/GenI/CkyEarley/CkyGui.lhs b/src/NLP/GenI/CkyEarley/CkyGui.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/CkyEarley/CkyGui.lhs @@ -0,0 +1,456 @@ +% 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. + +\chapter{CKY Gui} + +\begin{code} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.GenI.CkyEarley.CkyGui where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX hiding (when) + +import qualified Control.Monad as Monad +import Control.Monad (liftM) + +import Data.IORef +import Data.List (intersperse, findIndex, sort) +import qualified Data.Map as Map +import Data.Maybe (listToMaybe, catMaybes) +import Data.Tree + +import NLP.GenI.Statistics (Statistics) + +import NLP.GenI.Automaton + ( NFA(states, transitions, startSt, finalStList) + , addTrans ) +import qualified NLP.GenI.Builder as B +import qualified NLP.GenI.BuilderGui as BG +import NLP.GenI.Btypes ( GNode, gnname ) + +import NLP.GenI.CkyEarley.CkyBuilder + ( ckyBuilder, earleyBuilder, CkyStatus, CkyItem(..), ChartId + , ciRoot, ciAdjDone + , bitVectorToSem, findId + , extractDerivations + , theResults, theAgenda, theChart, theTrash + , emptySentenceAut, mJoinAutomata, mAutomatonPaths + , unpackItemToAuts, + ) +import NLP.GenI.Configuration ( Params(..) ) + +import NLP.GenI.Geni + ( ProgStateRef, runGeni, GeniResult ) +import NLP.GenI.General ( boundsCheck, geniBug ) +import NLP.GenI.GuiHelper + ( messageGui, toSentence + , debuggerPanel, DebuggerItemBar + , addGvHandler, modifyGvParams + , GraphvizGuiSt(gvitems, gvsel, gvparams), GvIO, setGvSel + , graphvizGui, newGvRef, setGvDrawables, + ) + +import NLP.GenI.Tags ( idname, tsemantics, ttree, TagElem ) + +import NLP.GenI.Graphviz + ( GraphvizShow(..), gvNode, gvEdge, gvSubgraph, gvUnlines, gvShowTree + , gvNewline + , GraphvizShowNode(..) ) +\end{code} +} + +% -------------------------------------------------------------------- +\section{Interface} +% -------------------------------------------------------------------- + +\begin{code} +ckyGui, earleyGui :: BG.BuilderGui +ckyGui = ckyOrEarleyGui False +earleyGui = ckyOrEarleyGui True + +ckyOrEarleyGui :: Bool -> BG.BuilderGui +ckyOrEarleyGui isEarley = BG.BuilderGui { + BG.resultsPnl = resultsPnl builder + , BG.debuggerPnl = ckyDebuggerTab builder } + where builder = if isEarley then earleyBuilder else ckyBuilder + +resultsPnl :: B.Builder CkyStatus CkyItem Params -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) +resultsPnl builder pstRef f = + do (sentences, stats, st) <- runGeni pstRef builder + (lay, _, _) <- realisationsGui pstRef f (theResults st) + return (sentences, stats, lay) +\end{code} + +% -------------------------------------------------------------------- +\section{Results} +\label{sec:cky_results_gui} +% -------------------------------------------------------------------- + +\begin{code} +-- | Browser for the results (if there are any) +realisationsGui :: ProgStateRef -> (Window a) -> [CkyItem] + -> GvIO CkyDebugParams (Maybe CkyItem) +realisationsGui _ f [] = + do m <- messageGui f "No results found" + gvRef <- newGvRef initCkyDebugParams [] "" + return (m, gvRef, return ()) +realisationsGui _ f resultsRaw = + do let tip = "result" + results = map Just resultsRaw + labels = map (toSentence.ciSourceTree) resultsRaw + gvRef <- newGvRef initCkyDebugParams labels tip + setGvDrawables gvRef results + graphvizGui f "cky-results" gvRef +\end{code} + +\begin{code} +data CkyDebugParams = + CkyDebugParams { debugShowFeats :: Bool + , debugShowFullDerv :: Bool + , debugShowSourceTree :: Bool + , debugWhichDerivation :: Int + , debugNodeChoice :: [ChartId] } + +initCkyDebugParams :: CkyDebugParams +initCkyDebugParams = + CkyDebugParams { debugShowFeats = False + , debugShowFullDerv = False + , debugShowSourceTree = False + , debugWhichDerivation = 0 + , debugNodeChoice = [] } + +-- would be nice if Haskell sugared this kind of stuff for us +setDebugShowFeats, setDebugShowFullDerv, setDebugShowSourceTree :: Bool -> CkyDebugParams -> CkyDebugParams +setDebugShowFeats b x = x { debugShowFeats = b } +setDebugShowFullDerv b x = x { debugShowFullDerv = b } +setDebugShowSourceTree b x = x { debugShowSourceTree = b } + +setDebugWhichDerivation :: Int -> CkyDebugParams -> CkyDebugParams +setDebugWhichDerivation w x = x { debugWhichDerivation = w } + +clearDebugNodeChoice :: CkyDebugParams -> CkyDebugParams +clearDebugNodeChoice x = x { debugNodeChoice = [] } + +pushDebugNodeChoice :: ChartId -> CkyDebugParams -> CkyDebugParams +pushDebugNodeChoice w x = x { debugNodeChoice = w:(debugNodeChoice x) } + +popDebugNodeChoice :: CkyDebugParams -> Maybe (ChartId, CkyDebugParams) +popDebugNodeChoice x = + case debugNodeChoice x of + [] -> Nothing + (h:t) -> Just (h, x { debugNodeChoice = t }) + +ckyDebuggerTab :: B.Builder CkyStatus CkyItem Params + -> (Window a) -> Params -> B.Input -> String -> IO Layout +ckyDebuggerTab builder = debuggerPanel builder initCkyDebugParams stateToGv ckyItemBar + where + stateToGv :: CkyStatus -> [(Maybe (CkyStatus,CkyItem), String)] + stateToGv st = + let agenda = section "AGENDA" $ theAgenda st + trash = section "TRASH" $ theTrash st + chart = section "CHART" $ theChart st + results = section "RESULTS" $ theResults st + -- + section n i = hd : (map tlFn i) + where hd = (Nothing, "___" ++ n ++ "___") + tlFn x = (Just (st,x), labelFn x) + showPaths = const "" + {- if (polarised $ genconfig st) + then (\t -> " (" ++ showPolPaths t ++ ")") + else const "" -} + gorn i = case gornAddressStr (ttree $ ciSourceTree i) (ciNode i) of + Nothing -> geniBug "A chart item claims to have a node which is not in its tree" + Just x -> x + isComplete i = ciRoot i && ciAdjDone i + -- try displaying as an automaton, or if all else fails, the tree sentence + fancyToSentence ci = + let mergedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts st ci + boringSentence = toSentence $ ciSourceTree ci + in case mAutomatonPaths mergedAut of + [] -> boringSentence + (h:_) -> unwords $ map fst $ h + labelFn i = unwords [ completeStr ++ idStr ++ gornStr + , fancyToSentence i + , "/" ++ (idname $ ciSourceTree i) + , showPaths i + ] + where idStr = show $ ciId i + completeStr = if isComplete i then ">" else "" + gornStr = if isComplete i then "" else " g" ++ (gorn i) + in agenda ++ chart ++ results ++ trash + +ckyItemBar :: DebuggerItemBar CkyDebugParams (CkyStatus, CkyItem) +ckyItemBar f gvRef updaterFn = + do ib <- panel f [] + -- select derivation + derTxt <- staticText ib [] + derChoice <- choice ib [ tooltip := "Select a derivation" ] + jumpBtn <- button ib [ text := "Go to node" ] + unjumpBtn <- button ib [ text := "Pop back" ] + jumpChoice <- choice ib [ tooltip := "Jump to item." ] + let onDerChoice = + do sel <- get derChoice selection + modifyGvParams gvRef (setDebugWhichDerivation sel) + gvSt <- readIORef gvRef + -- update the list of jump choices + case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just (s,c)) -> do + let t = selectedDerivation (gvparams gvSt) s c + nodes = map show $ sort $ derivationNodes t + set jumpChoice [ items := nodes, selection := 0 ] + updaterFn + _ -> return () + set derChoice [ on select := onDerChoice ] + -- show features + detailsChk <- checkBox ib [ text := "features" + , enabled := False, checked := False ] + fullDervChk <- checkBox ib [ text := "full derivation" + , checked := False ] + srcTreeChk <- checkBox ib [ text := "src tree" + , checked := False ] + let setChkBoxUpdater box setter = + set box [ on command := do isChecked <- get box checked + modifyGvParams gvRef $ setter isChecked + updaterFn ] + setChkBoxUpdater detailsChk setDebugShowFeats + setChkBoxUpdater fullDervChk setDebugShowFullDerv + setChkBoxUpdater srcTreeChk setDebugShowSourceTree + -- make detailsChk conditioned on srcTreeChk + set srcTreeChk [ on command :~ \x -> x >> do + isChecked <- get srcTreeChk checked + set detailsChk [ enabled := isChecked ] + ] + -- add a handler for when an item is selected: + -- update the list of derivations to choose from + let updateDerTxt t = set derTxt [ text := "Deriviations (" ++ t ++ ")" ] + handler gvSt = + do case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just (s,c)) -> + do let derivations = extractDerivations s c + dervLabels = zipWith (\n _ -> show n) ([1..]::[Int]) derivations + set derChoice [ enabled := True, items := dervLabels, selection := 0 ] + onDerChoice + updateDerTxt $ show $ length derivations + _ -> + do set derChoice [ enabled := False, items := [] ] + updateDerTxt "n/a" + addGvHandler gvRef handler + -- call the handler to react to the first selection + handler `liftM` readIORef gvRef + -- pushing and popping between nodes + let jumpToNode jmpTo = + do gvSt <- readIORef gvRef + let chartItems = Map.elems $ gvitems gvSt + case findIndex isJmpTo chartItems of + Nothing -> geniBug $ "Was asked to see node " ++ (show jmpTo) ++ ", which is not in the list" + Just x -> + do setGvSel gvRef x + modifyGvParams gvRef (setDebugWhichDerivation 0) + readIORef gvRef >>= handler + updaterFn + where isJmpTo Nothing = False + isJmpTo (Just (_,x)) = ciId x == jmpTo + set jumpBtn [ on command := do + gvSt <- readIORef gvRef + case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just x) -> modifyGvParams gvRef (pushDebugNodeChoice $ (ciId.snd) x) + _ -> return () + jmpSel <- get jumpChoice selection + jmpItms <- get jumpChoice items + let jmpTo = (read $ jmpItms !! jmpSel) + jumpToNode jmpTo ] + + set unjumpBtn [ on command := do + gvSt <- readIORef gvRef + case popDebugNodeChoice (gvparams gvSt) of + Nothing -> return () + Just (x,gvParam) -> do modifyGvParams gvRef (const gvParam) + jumpToNode x ] + -- + return $ hfloatCentre $ container ib $ column 0 $ + [ row 5 + [ label "Show...", widget fullDervChk, widget srcTreeChk, widget detailsChk ] + , row 5 + [ widget derTxt, widget derChoice + , hspace 5, label "Node", widget jumpChoice, widget jumpBtn, widget unjumpBtn ] ] +\end{code} + +\section{Helper code} + +\begin{code} + +gornAddressStr :: Tree GNode -> GNode -> Maybe String +gornAddressStr t target = + (concat . intersperse "." . map show) `liftM` gornAddress t target + +gornAddress :: Tree GNode -> GNode -> Maybe [Int] +gornAddress tr target = reverse `liftM` helper [] tr + where + helper current (Node x _) | (gnname x == gnname target) = Just current + helper current (Node _ l) = listToMaybe $ catMaybes $ + zipWith (\c t -> helper (c:current) t) [1..] l + + +selectedDerivation :: CkyDebugParams -> CkyStatus -> CkyItem -> Tree (ChartId, String) +selectedDerivation f s c = + let derivations = extractDerivations s c + whichDer = debugWhichDerivation f + in if boundsCheck whichDer derivations + then derivations !! whichDer + else geniBug $ "Bounds check failed on derivations selector:\n" + ++ "Selected derivation: " ++ (show whichDer) ++ "\n" + ++ "Bounds: 0 to " ++ (show $ length derivations - 1) + +derivationNodes :: Tree (ChartId, String) -> [ChartId] +derivationNodes = (map fst).flatten + +-- | Remove na and subst or adj completion links +thinDerivationTree :: Tree (ChartId, String) -> Tree (ChartId, String) +thinDerivationTree = + let thinlst = ["no-adj", "subst", "adj" ] + helper n@(Node _ []) = n + -- this is made complicated for fancy highlighting to work + helper (Node (i,op) [k]) | op `elem` thinlst = (Node (i,op2) k2) + where (Node (_,op2) k2) = helper k + helper (Node x kids) = (Node x $ map helper kids) + in helper + +instance GraphvizShow CkyDebugParams (CkyStatus, CkyItem) where + graphvizLabel f (_,c) = graphvizLabel f c + graphvizParams f (_,c) = graphvizParams f c + graphvizShowAsSubgraph f p (s,c) = + let color_ x = ("color", x) + label_ x = ("label", x) + style_ x = ("style", x) + arrowtail_ x = ("arrowtail", x) + -- + substColor = color_ "blue" + adjColor = color_ "red" + -- + edgeParams (_ ,"no-adj") = [ label_ "na" ] + edgeParams (_, "kids" ) = [] + edgeParams (_, "init" ) = [ label_ "i" ] + edgeParams (_, "subst" ) = [ substColor ] + edgeParams (_, "adj" ) = [ adjColor ] + edgeParams (_, "subst-finish") = [ substColor, style_ "bold" , arrowtail_ "normal" ] + edgeParams (_, "adj-finish") = [ adjColor , style_ "dashed, bold", arrowtail_ "normal" ] + edgeParams (_, k) = [ ("label", "UNKNOWN: " ++ k) ] + -- + whichDer = debugWhichDerivation f + showFullDer = debugShowFullDerv f + showSrcTree = debugShowSourceTree f + showTree i t = gvSubgraph $ gvShowTree edgeParams (s,showFullDer, [ciId c]) prfx t + where prfx = p ++ "t" ++ (show i) + gvDerv = showTree whichDer $ if showFullDer then t else thinDerivationTree t + where t = selectedDerivation f s c + -- + joinedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts s c + gvAut = graphvizShowAsSubgraph () (p ++ "aut") joinedAut + -- + showFeats = debugShowFeats f + treeParams = unlines $ graphvizParams showFeats $ ciSourceTree c + -- FIXME: will have to make this configurable, maybe, show aut, show tree? radio button? + in "\n// ------------------- derivations --------------------------\n" + ++ treeParams ++ "node [ shape = plaintext, peripheries = 0 ]\n" + ++ gvDerv + ++ "\n// ------------------- automata (joined) ------------------------\n" + ++ gvSubgraph gvAut + ++ if showSrcTree + then ("\n// ------------------- elementary tree --------------------------\n" + ++ treeParams ++ graphvizShowAsSubgraph f p c) + else "" + +instance GraphvizShowNode (CkyStatus,Bool,[ChartId]) (ChartId, String) where + graphvizShowNode (st,showFullDerv,highlight) prefix (theId,_) = + let idStr = show theId + treename i = " (" ++ ((idname.ciSourceTree) i) ++ ")" + txt = case findId st theId of + Nothing -> ("???" ++ idStr) + Just i -> idStr ++ " " ++ (show.ciNode) i + ++ (if showFullDerv then treename i else "") + custom = if theId `elem` highlight then [ ("fontcolor","red") ] else [] + in gvNode prefix txt custom + +instance GraphvizShow CkyDebugParams CkyItem where + graphvizLabel f ci = + graphvizLabel (debugShowFeats f, nullHlter) (toTagElem ci) ++ + gvNewline ++ (gvUnlines $ ciDiagnostic ci) + + graphvizShowAsSubgraph f prefix ci = + let showFeats = debugShowFeats f + hlter n = (n, if (gnname n) == (gnname $ ciNode ci) + then Just "red" else Nothing) + in graphvizShowAsSubgraph (showFeats,hlter) (prefix ++ "tree") $ toTagElem ci + +nullHlter :: GNode -> (GNode, Maybe String) +nullHlter a = (a,Nothing) + +toTagElem :: CkyItem -> TagElem +toTagElem ci = + te { ttree = ttree te + , tsemantics = bitVectorToSem (ciSemBitMap ci) (ciSemantics ci) } + where te = ciSourceTree ci + +-- FIXME: this is largely copy-and-pasted from Polarity.lhs +-- it should be refactored later +instance GraphvizShow () B.SentenceAut where + graphvizShowAsSubgraph _ prefix aut = + let st = (concat.states) aut + ids = map (\x -> prefix ++ show x) ([0..]::[Int]) + -- map which permits us to assign an id to a state + stmap = Map.fromList $ zip st ids + lookupFinal x = Map.findWithDefault "error_final" x stmap + in -- final states should be a double-edged ellispse + "node [ shape = ellipse, peripheries = 2 ]; " + ++ (unlines $ map lookupFinal $ finalStList aut) + -- any other state should be an ellipse + ++ "node [ shape = ellipse, peripheries = 1 ]\n" + -- draw the states and transitions + ++ (concat $ zipWith gvShowState ids st) + ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) + +type SentenceAutState = Int + +gvShowState :: String -> SentenceAutState -> String +gvShowState stId st = gvNode stId (show st) [] + +gvShowTrans :: B.SentenceAut -> Map.Map SentenceAutState String + -> String -> SentenceAutState -> String +gvShowTrans aut stmap idFrom st = + let -- outgoing transition labels from st + trans = Map.findWithDefault Map.empty st $ transitions aut + -- returns the graphviz dot command to draw a labeled transition + drawTrans (stTo,x) = case Map.lookup stTo stmap of + Nothing -> drawTrans' ("id_error_" ++ (show stTo)) x + Just idTo -> drawTrans' idTo x + drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] + drawLabel labels = gvUnlines $ map fst $ catMaybes labels + in unlines $ map drawTrans $ Map.toList trans +\end{code} + +\begin{code} +-- | join two automata, inserting a ".." transition between them +mJoinAutomataUsingHole :: Maybe B.SentenceAut -> Maybe B.SentenceAut -> Maybe B.SentenceAut +mJoinAutomataUsingHole aut1 Nothing = aut1 +mJoinAutomataUsingHole aut1 aut2 = + mJoinAutomata aut1 $ mJoinAutomata (Just holeAut) aut2 + where holeAut = addTrans emptyA 0 (Just ("..",[])) 1 + emptyA = emptySentenceAut { startSt = 0, finalStList = [1], states = [[0,1]] } +\end{code} diff --git a/src/NLP/GenI/Configuration.lhs b/src/NLP/GenI/Configuration.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Configuration.lhs @@ -0,0 +1,873 @@ +% 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. + +\chapter{Command line arguments} + +\begin{code} +{-# LANGUAGE ExistentialQuantification #-} +module NLP.GenI.Configuration + ( Params(..), GrammarType(..), BuilderType(..), Instruction, Flag + -- flags + , BatchDirFlg(..) + , DisableGuiFlg(..) + , EarlyDeathFlg(..) + , ExtraPolaritiesFlg(..) + , FromStdinFlg(..) + , HelpFlg(..) + , IgnoreSemanticsFlg(..) + , InstructionsFileFlg(..) + , LexiconFlg(..) + , MacrosFlg(..) + , MaxTreesFlg(..) + , MetricsFlg(..) + , MorphCmdFlg(..) + , MorphInfoFlg(..) + , MorphLexiconFlg(..) + , NoLoadTestSuiteFlg(..) + , OptimisationsFlg(..) + , OutputFileFlg(..) + , PartialFlg(..) + , RegressionTestModeFlg(..) + , RootFeatureFlg(..) + , RunUnitTestFlg(..) + , StatsFileFlg(..) + , TestCaseFlg(..) + , TestInstructionsFlg(..) + , TestSuiteFlg(..) + , TimeoutFlg(..) + , TracesFlg(..) + , VerboseModeFlg(..) + , ViewCmdFlg(..) + -- + , mainBuilderTypes + , getFlagP, getListFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt, polarised + , getFlag, setFlag, hasFlag + , Optimisation(..) + , rootcatfiltered, semfiltered + , isIaf + , emptyParams, defineParams + , treatArgs, treatStandardArgs, treatArgsWithParams, treatStandardArgsWithParams + , processInstructions + , optionsForStandardGenI + , optionsForBasicStuff, optionsForOptimisation, optionsForMorphology, optionsForInputFiles + , optionsForBuilder, optionsForTesting + , nubBySwitches + , noArg, reqArg, optArg + , parseFlagWithParsec + -- re-exports + , module System.Console.GetOpt + , Typeable + ) +where +\end{code} + +\ignore{ +\begin{code} +import qualified Data.Map as Map + +import Control.Monad ( liftM ) +import Data.Char ( toLower ) +import Data.Maybe ( listToMaybe, mapMaybe ) +import Data.Typeable ( Typeable, typeOf, cast ) +import System.Console.GetOpt +import System.Exit ( exitFailure, exitWith, ExitCode(..) ) +import Data.List ( find, intersperse, nubBy ) +import Data.Maybe ( catMaybes, fromMaybe, isNothing, fromJust ) +import Text.ParserCombinators.Parsec ( runParser, CharParser ) + +import NLP.GenI.Btypes ( GeniVal(GConst), Flist, showFlist, ) +import NLP.GenI.General ( geniBug, fst3, snd3, Interval ) +import NLP.GenI.GeniParsers ( geniFeats, geniPolarities ) +\end{code} +} + +% -------------------------------------------------------------------- +% Code for debugging. (should be latex-commented +% when not in use) +% -------------------------------------------------------------------- + +%\begin{code} +%import Debug.Trace +%\end{code} + +% -------------------------------------------------------------------- +% Params +% -------------------------------------------------------------------- + +\begin{code} +-- | Holds the specification for how Geni should be run, its input +-- files, etc. This is the stuff that would normally be found in +-- the configuration file. +data Params = Prms{ + grammarType :: GrammarType, + builderType :: BuilderType, + geniFlags :: [Flag] +} deriving (Show) + +hasOpt :: Optimisation -> Params -> Bool +hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p + +polarised, isIaf :: Params -> Bool +rootcatfiltered, semfiltered :: Params -> Bool +polarised = hasOpt Polarised +isIaf = hasOpt Iaf +semfiltered = hasOpt SemFiltered +rootcatfiltered = hasOpt RootCatFiltered + +hasFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool +deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params +setFlagP :: (Eq f, Show f, Show x, Typeable f, Typeable x) => (x -> f) -> x -> Params -> Params +getFlagP :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> Params -> Maybe x +getListFlagP :: (Show f, Show x, Typeable f, Typeable x) => ([x] -> f) -> Params -> [x] + +hasFlagP f = hasFlag f . geniFlags +deleteFlagP f p = p { geniFlags = deleteFlag f (geniFlags p) } +setFlagP f v p = p { geniFlags = setFlag f v (geniFlags p) } +getFlagP f = getFlag f . geniFlags +getListFlagP f = fromMaybe [] . getFlagP f +-- | The default parameters configuration +emptyParams :: Params +emptyParams = Prms { + builderType = SimpleBuilder, + grammarType = GeniHand, + geniFlags = [ Flag ViewCmdFlg "ViewTAG" + , Flag RootFeatureFlg defaultRootFeat ] +} +\end{code} + +% -------------------------------------------------------------------- +\section{Command line arguments} +% -------------------------------------------------------------------- + +Command line arguments can be specified in the GNU style, for example +\texttt{--foo=bar} or \texttt{--foo bar}, or \texttt{-f bar} when a +short switch is available. For more information, type \texttt{geni +--help}. + +\begin{code} +-- | Uses the GetOpt library to process the command line arguments. +-- Note that we divide them into basic and advanced usage. +optionsForStandardGenI :: [OptDescr Flag] +optionsForStandardGenI = + nubBySwitches $ concatMap snd3 optionsSections + ++ -- FIXME: weird mac stuff + [ Option ['p'] [] (reqArg WeirdFlg id "CMD") "" ] + +optionsSections :: [(String,[OptDescr Flag],[String])] +optionsSections = + [ ("Core options", optionsForBasicStuff, example) + , ("Input", optionsForInputFiles, []) + , ("Output", optionsForOutput, []) + , ("Algorithm", + (nubBySwitches $ optionsForBuilder ++ optionsForOptimisation), + usageForOptimisations) + , ("Morphology", optionsForMorphology, []) + , ("User interface", optionsForUserInterface, []) + , ("Batch processing", optionsForTesting, []) + , ("Miscellaneous", nubBySwitches $ optionsForIgnoreSem, []) + ] + where + example = [ "Example:" + , " geni -m examples/ej/mac -l examples/ej/lexicon -s examples/ej/suite" + ] + +getSwitches :: OptDescr a -> ([Char],[String]) +getSwitches (Option s l _ _) = (s,l) + +nubBySwitches :: [OptDescr a] -> [OptDescr a] +nubBySwitches = nubBy (\x y -> getSwitches x == getSwitches y) +\end{code} + +\subsection{Essential arguments} + +See also section \ref{sec:optimisations} for more details on +optimisations. + +% FIXME: what would be great is some special processing of the +% code below so that the documentation writes itself + +\begin{code} +-- GetOpt wrappers +noArg :: forall f . (Eq f, Show f, Typeable f) + => (() -> f) -> ArgDescr Flag +noArg s = NoArg (Flag s ()) + +reqArg :: forall f x . (Eq f, Show f, Typeable f, Eq x, Show x, Typeable x) + => (x -> f) -- ^ flag + -> (String -> x) -- ^ string reader for flag (probably |id| if already a String) + -> String -- ^ description + -> ArgDescr Flag +reqArg s fn desc = ReqArg (\x -> Flag s (fn x)) desc + +optArg :: forall f x . (Eq f, Show f, Typeable f, Eq x, Show x, Typeable x) + => (x -> f) -- ^ flag + -> x -- ^ default value + -> (String -> x) -- ^ string reader (as in @reqArg@) + -> String -- ^ description + -> ArgDescr Flag +optArg s def fn desc = OptArg (\x -> Flag s (maybe def fn x)) desc +\end{code} + +\begin{code} +-- ------------------------------------------------------------------- +-- Parsing command line arguments +-- ------------------------------------------------------------------- + +usage :: Bool -- ^ advanced + -> String +usage adv = + let header = "Usage: geni [OPTION...]\n" + tweakBasic (x,y,z) = (x,y,z ++ ["See geni --help for more details"]) + sections = if adv + then optionsSections + else map tweakBasic $ take 1 optionsSections + body = unlines $ map usageSection sections + in header ++ body + +usageSection :: (String, [OptDescr Flag],[String]) -> String +usageSection (name, opts, comments) = + usageInfo (unlines $ [bar,name, bar]) opts ++ mcomments + where + bar = replicate 72 '=' + mcomments = if null comments then [] else "\n" ++ unlines comments + +treatStandardArgs :: [String] -> IO Params +treatStandardArgs argv = treatStandardArgsWithParams argv emptyParams + +treatStandardArgsWithParams :: [String] -> Params -> IO Params +treatStandardArgsWithParams = treatArgsWithParams optionsForStandardGenI + +treatArgs :: [OptDescr Flag] -> [String] -> IO Params +treatArgs options argv = treatArgsWithParams options argv emptyParams + +treatArgsWithParams :: [OptDescr Flag] -> [String] -> Params -> IO Params +treatArgsWithParams options argv initParams = + case getOpt Permute options argv of + (os,_,[] ) + | hasFlag HelpFlg os -> + do putStrLn $ usage True + exitWith ExitSuccess + | hasFlag DisableGuiFlg os + && notHasFlag TestCaseFlg os + && notHasFlag RegressionTestModeFlg os + && notHasFlag BatchDirFlg os + && notHasFlag FromStdinFlg os -> + do putStrLn $ "GenI must either be run in graphical mode, " + ++ "in regression mode, with a test case specified, with --from-stdin," + ++ "or with a batch directory specified" + exitFailure + | otherwise -> + return $ defineParams os initParams + (_,_,errs) -> ioError (userError $ concat errs ++ usage False) + where notHasFlag f l = not $ hasFlag f l + +defineParams :: [Flag] -> Params -> Params +defineParams flgs prms = + (\p -> foldr setDefault p $ geniFlags prms) + . maybeSetMaxTrees + . (mergeFlagsP OptimisationsFlg) + . (mergeFlagsP MetricsFlg) + $ prms + { geniFlags = flgs + , builderType = fromFlags builderType BuilderFlg flgs + , grammarType = fromFlags grammarType GrammarTypeFlg flgs + } + where + setDefault (Flag f v) p = + if hasFlagP f p then p else setFlagP f v p + mergeFlagsP f p = + if hasFlagP f p + then setFlagP f (concat $ getAllFlags f flgs) p + else p + fromFlags default_ t fs = + fromMaybe (default_ prms) (getFlag t fs) + maybeSetMaxTrees p = + if hasFlagP IgnoreSemanticsFlg p && (not $ hasFlagP MaxTreesFlg p) + then setFlagP MaxTreesFlg 5 p else p +\end{code} + +\section{Options by theme} +\label{sec:fancy_parameters} + +Note that you might see an option described in more than one place +because it falls into multiple categories. + +% -------------------------------------------------------------------- +\subsection{Basic options} +% -------------------------------------------------------------------- + +\begin{code} +optionsForBasicStuff :: [OptDescr Flag] +optionsForBasicStuff = + [ helpOption, verboseOption, noguiOption + , macrosOption , lexiconOption, testSuiteOption + , outputOption + ] +\end{code} + +% -------------------------------------------------------------------- +\subsection{Input files} +% -------------------------------------------------------------------- + +\begin{code} +optionsForInputFiles :: [OptDescr Flag] +optionsForInputFiles = + [ macrosOption + , lexiconOption + , tracesOption + , testSuiteOption + , fromStdinOption + , morphInfoOption + , instructionsOption + , outputOption + , Option [] ["preselected"] (NoArg (Flag GrammarTypeFlg PreAnchored)) + "do NOT perform lexical selection - treat the grammar as the selection" + ] + +instructionsOption, macrosOption, lexiconOption, tracesOption, outputOption :: OptDescr Flag + +instructionsOption = + Option [] ["instructions"] (reqArg InstructionsFileFlg id "FILE") + "instructions file FILE" + +macrosOption = + Option ['m'] ["macros"] (reqArg MacrosFlg id "FILE") + "macros file FILE (unanchored trees)" + +lexiconOption = + Option ['l'] ["lexicon"] (reqArg LexiconFlg id "FILE") + "lexicon file FILE" + +tracesOption = + Option [] ["traces"] (reqArg TracesFlg id "FILE") + "traces file FILE (list of traces to display)" + +outputOption = + Option ['o'] ["output"] (reqArg OutputFileFlg id "FILE") + "output file FILE (stdout if unset)" +\end{code} + +% -------------------------------------------------------------------- +\subsection{Output} +% -------------------------------------------------------------------- + +\begin{code} +optionsForOutput :: [OptDescr Flag] +optionsForOutput = + [ outputOption + , Option [] ["partial"] (noArg PartialFlg) + "return partial result(s) if no complete solution is found" + ] +\end{code} + +% -------------------------------------------------------------------- +\subsection{User interface} +% -------------------------------------------------------------------- + +\begin{code} +optionsForUserInterface :: [OptDescr Flag] +optionsForUserInterface = + [ noguiOption, helpOption + , Option [] ["regression"] (noArg RegressionTestModeFlg) + "Run in regression testing mode (needs grammar, etc)" + , Option [] ["unit-tests"] (noArg RunUnitTestFlg) + "Run in unit testing mode (no arguments needed)" + , Option [] ["viewcmd"] (reqArg ViewCmdFlg id "CMD") + "XMG tree-view command" + ] + +verboseOption, noguiOption, helpOption :: OptDescr Flag +noguiOption = Option [] ["nogui"] (noArg DisableGuiFlg) + "disable graphical user interface" +helpOption = Option [] ["help"] (noArg HelpFlg) + "show full list of command line switches" +verboseOption = Option ['v'] ["verbose"] (noArg VerboseModeFlg) + "verbose mode" +\end{code} + +% -------------------------------------------------------------------- +\subsection{Optimisations} +% -------------------------------------------------------------------- + +\begin{description} +\item[opt] + The opt switch lets you specify a list of optimisations + that GenI should use, for example, \texttt{--opt='pol S i'}. + We associate each optimisation with a short code like 'i' for + ``index accessibility filtering''. This code is what the + user passes in, and is sometimes used by GenI to tell the + user which optimisations it's using. See \texttt{geni + --help} for more detail on the codes. + + Optimisations can be accumulated. For example, if you say something + like \texttt{--opt='foo bar' --opt='quux'} it is the same as saying + \texttt{--opt='foo bar quux'}. + + Note that we also have two special thematic codes ``pol'' and + ``adj'' which tell GenI that it should enable all the + polarity-related, and all the adjunction-related + optimisations respectively. + +\item[rootfeat] + No results? Make sure your rootfeat are set correctly. GenI + will reject all sentences whose root category does not unify + with the rootfeat, the default of which is: +\begin{includecodeinmanual} +\begin{code} +defaultRootFeat :: Flist +defaultRootFeat = + [ ("cat" , GConst ["s"]) + , ("inv" , GConst ["-"]) + , ("mode", GConst ["ind","subj"]) + , ("wh" , GConst ["-"]) + ] +\end{code} +\end{includecodeinmanual} + + You can set rootfeat to be empty (\verb![]!) if you want, in + which case the realiser proper will return all results; but + note that if you want to use polarity filtering, you must at + least specify a value for the \verb!cat! feature. + +\item[extrapols] + Allows to to preset some polarities. There's not very much use for + this, in my opinion. Most likely, what you really want is rootfeat. +\end{description} + +\begin{code} +optionsForOptimisation :: [OptDescr Flag] +optionsForOptimisation = + [ Option [] ["opts"] + (reqArg OptimisationsFlg readOptimisations "LIST") + "optimisations 'LIST' (--help for details)" + , Option [] ["rootfeat"] + (reqArg RootFeatureFlg readRF "FEATURE") + ("root features 'FEATURE' (for polarities, default:" + ++ showFlist defaultRF ++ ")") + , Option [] ["extrapols"] + (reqArg ExtraPolaritiesFlg readPolarities "STRING") + "preset polarities (normally, you should use rootfeat instead)" + ] + where + defaultRF = getListFlagP RootFeatureFlg emptyParams + readRF = parseFlagWithParsec "root feature" geniFeats + readPolarities = parseFlagWithParsec "polarity string" geniPolarities + +data Optimisation = + PolOpts | AdjOpts | Polarised | NoConstraints | + RootCatFiltered | SemFiltered | Iaf {- one phase only! -} + deriving (Show,Eq,Typeable) + +coreOptimisationCodes :: [(Optimisation,String,String)] +coreOptimisationCodes = + [ (Polarised , "p", "polarity filtering") + , (SemFiltered , "f-sem", "semantic filtering (two-phase only)") + , (RootCatFiltered , "f-root", "filtering on root node (two-phase only)") + , (Iaf , "i", "index accesibility filtering (one-phase only)") + , (NoConstraints , "nc", "disable semantic constraints (anti-optimisation!)") + ] + +optimisationCodes :: [(Optimisation,String,String)] +optimisationCodes = + coreOptimisationCodes ++ + [ (SemFiltered , "S", "semantic filtering (same as f-sem)") + , (PolOpts , "pol", equivalentTo polOpts) + , (AdjOpts , "adj", equivalentTo adjOpts) + ] + where equivalentTo os = "equivalent to '" ++ (unwords $ map showOptCode os) ++ "'" + +polOpts, adjOpts :: [Optimisation] +polOpts = [Polarised] +adjOpts = [RootCatFiltered, SemFiltered] +\end{code} + +\begin{code} +-- --------------------------------------------------------------------- +-- Optimisation usage info +-- --------------------------------------------------------------------- + +lookupOpt:: Optimisation -> (String, String) +lookupOpt k = + case find (\x -> k == fst3 x) optimisationCodes of + Just (_, c, d) -> (c, d) + Nothing -> geniBug $ "optimisation " ++ show k ++ " unknown" + +showOptCode :: Optimisation -> String +showOptCode = fst.lookupOpt + +describeOpt :: (Optimisation, String, String) -> String +describeOpt (_,k,d) = k ++ " - " ++ d + +-- | Displays the usage text for optimisations. +-- It shows a table of optimisation codes and their meaning. +usageForOptimisations :: [String] +usageForOptimisations = + [ "Optimisations must be passed in as a space-delimited list" + , "(ex: --opt='p f-sem' for polarities and semantic filtering)" + , "" + , "Optimisations:" + , " " ++ unlinesTab (map describeOpt coreOptimisationCodes) + ] + where unlinesTab l = concat (intersperse "\n " l) +\end{code} + +\begin{code} +-- --------------------------------------------------------------------- +-- Parsing optimisation stuff +-- --------------------------------------------------------------------- + +-- | If we do not recognise a code, we output an error message. We +-- also take the liberty of expanding thematic codes like 'pol' +-- into the respective list of optimisations. +readOptimisations :: String -> [Optimisation] +readOptimisations str = + case parseOptimisations str of + Left ick -> error $ "Unknown optimisations: " ++ (unwords ick) + Right os -> (addif PolOpts polOpts) . (addif AdjOpts adjOpts) $ os + where addif t x o = if (t `elem` o) then x ++ o else o + +-- | Returns |Left| for any codes we don't recognise, or +-- |Right| if everything is ok. +parseOptimisations :: String -> Either [String] [Optimisation] +parseOptimisations str = + let codes = words str + mopts = map lookupOptimisation codes + in if any isNothing mopts + then Left [ c | (c,o) <- zip codes mopts, isNothing o ] + else Right $ map fromJust mopts + +lookupOptimisation :: String -> Maybe Optimisation +lookupOptimisation code = + liftM fst3 $ find (\x -> snd3 x == code) optimisationCodes + +parseFlagWithParsec :: String -> CharParser () b -> String -> b +parseFlagWithParsec description p str = + case runParser p () "" str of + Left err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err + Right res -> res +\end{code} + +% -------------------------------------------------------------------- +\subsection{Builders} +% -------------------------------------------------------------------- + +\begin{description} +\item[builder] + A builder is basically a surface realisation algorithm. Some + builders do not differ by very much. For example, the Earley and CKY builders + are more or less the same from GenI's point of view, except with one little + parameter to tweak. +\end{description} + +\begin{code} +data BuilderType = NullBuilder | + SimpleBuilder | SimpleOnePhaseBuilder | + CkyBuilder | EarleyBuilder + deriving (Eq, Typeable) + +instance Show BuilderType where + show NullBuilder = "null" + show SimpleBuilder = "simple-2p" + show SimpleOnePhaseBuilder = "simple-1p" + show CkyBuilder = "CKY" + show EarleyBuilder = "Earley" + +optionsForBuilder :: [OptDescr Flag] +optionsForBuilder = + [ Option ['b'] ["builder"] (reqArg BuilderFlg readBuilderType "BUILDER") + ("use as realisation engine one of: " ++ (unwords $ map show mainBuilderTypes)) + ] + +mainBuilderTypes :: [BuilderType] +mainBuilderTypes = + [ SimpleBuilder, SimpleOnePhaseBuilder + , CkyBuilder, EarleyBuilder] + +-- | Hint: compose with (map toLower) to make it case-insensitive +mReadBuilderType :: String -> Maybe BuilderType +mReadBuilderType "null" = Just NullBuilder +mReadBuilderType "cky" = Just CkyBuilder +mReadBuilderType "earley" = Just EarleyBuilder +mReadBuilderType "simple" = Just SimpleBuilder +mReadBuilderType "simple-2p" = Just SimpleBuilder +mReadBuilderType "simple-1p" = Just SimpleOnePhaseBuilder +mReadBuilderType _ = Nothing + +-- | Is case-insensitive, error if unknown type +readBuilderType :: String -> BuilderType +readBuilderType b = + case mReadBuilderType $ map toLower b of + Just x -> x + Nothing -> error $ "Unknown builder type " ++ b + +\end{code} + +% -------------------------------------------------------------------- +\subsection{Testing and profiling} +% -------------------------------------------------------------------- + +\begin{code} +fromStdinOption :: OptDescr Flag +fromStdinOption = + Option [] ["from-stdin"] (noArg FromStdinFlg) "get testcase from stdin" + +testSuiteOption :: OptDescr Flag +testSuiteOption = + Option ['s'] ["testsuite"] (reqArg TestSuiteFlg id "FILE") "test suite FILE" + +optionsForTesting :: [OptDescr Flag] +optionsForTesting = + [ testSuiteOption + , fromStdinOption + , Option [] ["testcase"] (reqArg TestCaseFlg id "STRING") + "run test case STRING" + , Option [] ["timeout"] (reqArg TimeoutFlg read "SECONDS") + "time out after SECONDS seconds" + , Option [] ["metrics"] (optArg MetricsFlg ["default"] words "LIST") + "keep track of performance metrics: (default: iterations comparisons chart_size)" + , Option [] ["statsfile"] (reqArg StatsFileFlg id "FILE") + "write performance data to file FILE (stdout if unset)" + , Option [] ["batchdir"] (reqArg BatchDirFlg id "DIR") + "batch process the test suite and save results to DIR" + , Option [] ["earlydeath"] (noArg EarlyDeathFlg) + "exit on first case with no results (batch processing) " + ] +\end{code} + +% -------------------------------------------------------------------- +\subsection{Morphology} +% -------------------------------------------------------------------- + +GenI provides two options for morphology: either you use an external +inflection program (morphcmd), or you pass in a morphological lexicon +(morphlexicon) and in doing so, use GenI's built in inflecter. The +GenI internal morphology mechanism is a simple and stupid lookup-and- +unify table, so you probably don't want to use it if you have a huge +lexicon. + +\begin{description} +\item[morphcmd] specifies the program used for morphology. Literate +GenI \cite{literateGeni} has a chapter describing how that program must work. +It will mostly likely be a script you wrote to wrap around some off-the-shelf +software. +\item[morphlexicon] specifies a morphological lexicon for use by +GenI's internal morphological generator. Specifying this option will +cause the morphcmd flag to be ignored. +\item[morphinfo] tells GenI which literals in the input semantics are +to be used by the morphological \emph{pre-}processor. The pre-processor +strips these features from the input and fiddles with the elementary +trees used by GenI so that the right features get attached to the leaf +nodes. An example of a ``morphological'' literal is something like +\texttt{past(p)}. +\end{description} + +\begin{code} +optionsForMorphology :: [OptDescr Flag] +optionsForMorphology = + [ morphInfoOption + , Option [] ["morphcmd"] (reqArg MorphCmdFlg id "CMD") + "morphological post-processor CMD (default: unset)" + , Option [] ["morphlexicon"] (reqArg MorphLexiconFlg id "FILE") + "morphological lexicon FILE (default: unset) - overrides morphcmd!" + ] + +morphInfoOption :: OptDescr Flag +morphInfoOption = Option [] ["morphinfo"] (reqArg MorphInfoFlg id "FILE") + "morphological lexicon FILE (default: unset)" +\end{code} + +% -------------------------------------------------------------------- +\subsection{Ignore semantics mode} +% -------------------------------------------------------------------- + +\begin{description} +\item[ignoresem] is a special generation mode for systematically +churning out any sentences that the grammar can produce, without +using an input semantics. \textbf{Note}: This was implemented by Jackie +Lai (see patches around 2005-06-16), but has been horribly broken by +Eric sometime before 2006-08. Please let us know if you actually use +this thing, so that we can fix it. +\item[maxtrees] limits ignoresem mode by restricting the size of its +derivation trees (in number of elementary trees). Otherwise, GenI +would just spin around exploring an infinite number of sentences. +If you don't specify a maxtrees under ignoresem mode, we'll use a +default of 5. Note that maxtrees also works in normal generation +mode. It could be a useful way of saying ``give me only really +small sentences''. +\end{description} + +\begin{code} +optionsForIgnoreSem :: [OptDescr Flag] +optionsForIgnoreSem = + [ Option [] ["ignoresem"] (noArg IgnoreSemanticsFlg) + "ignore all semantic information" + , Option [] ["maxtrees"] (reqArg MaxTreesFlg read "INT") + "max tree size INT by number of elementary trees" + ] +\end{code} + +% -------------------------------------------------------------------- +\subsection{Other options} +% -------------------------------------------------------------------- + +\begin{code} +data GrammarType = GeniHand -- ^ geni's text format + | PreCompiled -- ^ built into geni, no parsing needed + | PreAnchored -- ^ lexical selection already done + deriving (Show, Eq, Typeable) +\end{code} + +% ==================================================================== +\section{Scripting GenI} +% ==================================================================== + +Any input that you give to GenI will be interpreted as a list of test +suites (and test cases that you want to run). Each line has the format +\texttt{path/to/test-suite case1 case2 .. caseN}. You can omit the +test cases, which is interpreted as you wanting to run the entire test +suite. Also, the \verb!%! character and anything after is treated as +a comment. + +\begin{code} +type Instruction = (FilePath, Maybe [String]) + +processInstructions :: Params -> IO Params +processInstructions config = + do let is0 = case getFlagP TestSuiteFlg config of + Just ts -> case getFlagP TestCaseFlg config of + Just c -> [ (ts, Just [c]) ] + Nothing -> [ (ts, Nothing) ] + Nothing -> [] + is <- case getFlagP InstructionsFileFlg config of + Nothing -> return [] + Just f -> instructionsFile `fmap` readFile f + -- basically set the test suite/case flag to the first instruction + -- note that with the above code (which sets the first instruction + -- to the test suite/case flag), this should work out to identity + -- when those flags are provided. + let instructions = is0 ++ is + updateInstructions = + setFlagP TestInstructionsFlg instructions + updateTestCase = + case (listToMaybe instructions >>= snd >>= listToMaybe) of + Just c -> setFlagP TestCaseFlg c + Nothing -> id + updateTestSuite = + case (fst `fmap` listToMaybe instructions) of + Just s -> setFlagP TestSuiteFlg s + Nothing -> id + updateFlags = updateInstructions . updateTestSuite . updateTestCase + return $ updateFlags config + +instructionsFile :: String -> [Instruction] +instructionsFile = mapMaybe inst . lines + where + inst l = case words (takeWhile (/= '%') l) of + [] -> Nothing + [f] -> Just (f, Nothing) + (f:cs) -> Just (f, Just cs) +\end{code} + +% ==================================================================== +% Flags +% ==================================================================== + +\begin{code} +{- +Flags are GenI's internal representation of command line arguments. We +use phantom existential types (?) for representing GenI flags. This +makes it simpler to do things such as ``get the value of the MacrosFlg'' +whilst preserving type safety (we always know that MacrosFlg is +associated with String). The alternative would be writing getters and +setters for each flag, and that gets really boring after a while. +-} + +data Flag = forall f x . (Eq f, Show f, Show x, Typeable f, Typeable x) => + Flag (x -> f) x deriving (Typeable) + +instance Show Flag where + show (Flag f x) = "Flag " ++ show (f x) + +instance Eq Flag where + (Flag f1 x1) == (Flag f2 x2) + | (typeOf f1 == typeOf f2) && (typeOf x1 == typeOf x2) = + (fromJust . cast . f1 $ x1) == (f2 x2) + | otherwise = False + +isFlag :: (Typeable f, Typeable x) => (x -> f) -> Flag -> Bool +hasFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> Bool +deleteFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> [Flag] +setFlag :: (Eq f, Show f, Show x, Typeable f, Typeable x) => (x -> f) -> x -> [Flag] -> [Flag] +getFlag :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> [Flag] -> Maybe x +getAllFlags :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> [Flag] -> [x] + +isFlag f1 (Flag f2 _) = typeOf f1 == typeOf f2 +hasFlag f = any (isFlag f) +deleteFlag f = filter (not.(isFlag f)) +setFlag f v fs = (Flag f v) : tl where tl = deleteFlag f fs +getFlag f fs = do (Flag _ v) <- find (isFlag f) fs ; cast v +getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- fs, isFlag f flg ] + + +{- +Below are just the individual flags, which unfortunately have to be +defined as separate data types because of our fancy existential +data type code. +-} +-- input files +#define FLAG(x,y) data x = x y deriving (Eq, Show, Typeable) + +FLAG (BatchDirFlg, FilePath) +FLAG (DisableGuiFlg, ()) +FLAG (EarlyDeathFlg, ()) +FLAG (ExtraPolaritiesFlg, (Map.Map String Interval)) +FLAG (FromStdinFlg, ()) +FLAG (HelpFlg, ()) +FLAG (IgnoreSemanticsFlg, ()) +FLAG (InstructionsFileFlg, FilePath) +FLAG (LexiconFlg, FilePath) +FLAG (MacrosFlg, FilePath) +FLAG (TracesFlg, FilePath) +FLAG (MaxTreesFlg, Int) +FLAG (MetricsFlg, [String]) +FLAG (MorphCmdFlg, String) +FLAG (MorphInfoFlg, FilePath) +FLAG (MorphLexiconFlg, FilePath) +FLAG (OptimisationsFlg, [Optimisation]) +FLAG (OutputFileFlg, String) +FLAG (PartialFlg, ()) +FLAG (RegressionTestModeFlg, ()) +FLAG (RootFeatureFlg, Flist) +FLAG (RunUnitTestFlg, ()) +FLAG (NoLoadTestSuiteFlg, ()) +FLAG (StatsFileFlg, FilePath) +FLAG (TestCaseFlg, String) +FLAG (TestInstructionsFlg, [Instruction]) +FLAG (TestSuiteFlg, FilePath) +FLAG (TimeoutFlg, Integer) +FLAG (VerboseModeFlg, ()) +FLAG (ViewCmdFlg, String) +-- not to be exported (defaults) +-- the WeirdFlg exists strictly to please OS X when you launch +-- GenI in an application bundle (double-click)... for some +-- reason it wants to pass an argument to -p +FLAG (BuilderFlg, BuilderType) +FLAG (GrammarTypeFlg, GrammarType) +FLAG (WeirdFlg, String) +\end{code} + + diff --git a/src/NLP/GenI/Console.hs b/src/NLP/GenI/Console.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Console.hs @@ -0,0 +1,196 @@ +-- 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 console user interface including batch processing on entire +-- test suites. + +module NLP.GenI.Console(consoleGeni, runTestCaseOnly) where + +import Control.Monad +import Data.IORef(readIORef, modifyIORef) +import Data.List(find, sort) +import Data.Maybe ( isJust, fromMaybe ) +import System.Directory(createDirectoryIfMissing) +import System.Exit ( exitFailure ) +import System.FilePath ( () ) +import Test.HUnit.Text (runTestTT) +import qualified Test.HUnit.Base as H +import Test.HUnit.Base ((@?)) + +import NLP.GenI.Btypes + ( SemInput, showSem + , TestCase(tcSem, tcName, tcExpected) + ) +import qualified NLP.GenI.Btypes as G +import NLP.GenI.General + ( ePutStrLn, withTimeout, exitTimeout + , fst3, + ) +import NLP.GenI.Geni +import NLP.GenI.Configuration + ( Params + , BatchDirFlg(..), EarlyDeathFlg(..), FromStdinFlg(..), OutputFileFlg(..) + , MetricsFlg(..), RegressionTestModeFlg(..), RunUnitTestFlg(..), StatsFileFlg(..) + , TestCaseFlg(..), TimeoutFlg(..), VerboseModeFlg(..) + , hasFlagP, getFlagP + , builderType , BuilderType(..) + ) +import qualified NLP.GenI.Builder as B +import NLP.GenI.CkyEarley.CkyBuilder +import NLP.GenI.Simple.SimpleBuilder +import NLP.GenI.Statistics ( showFinalStats, Statistics ) +import NLP.GenI.Test (runTests) + +consoleGeni :: ProgStateRef -> IO() +consoleGeni pstRef = do + pst <- readIORef pstRef + if hasFlagP RunUnitTestFlg (pa pst) + then runTests + else do + loadEverything pstRef + case getFlagP TimeoutFlg (pa pst) of + Nothing -> runSuite pstRef + Just t -> withTimeout t (timeoutErr t) $ runSuite pstRef + where + timeoutErr t = do ePutStrLn $ "GenI timed out after " ++ (show t) ++ "s" + exitTimeout + +-- | Runs a test suite. +-- We assume that the grammar and target semantics are already +-- loaded into the monadic state. +-- If batch processing is enabled, save the results to the batch output +-- directory with one subdirectory per case. +runSuite :: ProgStateRef -> IO () +runSuite pstRef = + do pst <- readIORef pstRef + let suite = tsuite pst + config = pa pst + verbose = hasFlagP VerboseModeFlg config + earlyDeath = hasFlagP EarlyDeathFlg config + if hasFlagP RegressionTestModeFlg config + then runRegressionSuite pstRef >> return () + else case getFlagP BatchDirFlg config of + Nothing -> runTestCaseOnly pstRef >> return () + Just bdir -> runBatch earlyDeath verbose bdir suite + where + runBatch earlyDeath verbose bdir suite = + if any null $ map tcName suite + then ePutStrLn "Can't do batch processing. The test suite has cases with no name." + else do ePutStrLn "Batch processing mode" + mapM_ (runCase earlyDeath verbose bdir) suite + runCase earlyDeath verbose bdir (G.TestCase { tcName = n, tcSem = s }) = + do when verbose $ + ePutStrLn "======================================================" + (res , _) <- runOnSemInput pstRef (PartOfSuite n bdir) s + ePutStrLn $ " " ++ n ++ " - " ++ (show $ length res) ++ " results" + when (null res && earlyDeath) $ do + ePutStrLn $ "Exiting early because test case " ++ n ++ " failed." + exitFailure + +-- | Run a test suite, but in HUnit regression testing mode, +-- treating each GenI test case as an HUnit test. Obviously +-- we need a test suite, grammar, etc as input +runRegressionSuite :: ProgStateRef -> IO (H.Counts) +runRegressionSuite pstRef = + do pst <- readIORef pstRef + tests <- (mapM toTest) . tsuite $ pst + runTestTT . (H.TestList) . concat $ tests + where + toTest :: G.TestCase -> IO [H.Test] -- ^ GenI test case to HUnit Tests + toTest tc = -- run the case, and return a test case for each expected result + do (res , _) <- runOnSemInput pstRef InRegressionTest (tcSem tc) + let sentences = fst (unzip res) + name = tcName tc + semStr = showSem . fst3 . tcSem $ tc + mainMsg = "for " ++ semStr ++ ", got no results" + mainCase = H.TestLabel name + $ H.TestCase $ (not.null $ sentences) @? mainMsg + subMsg e = "for " ++ semStr ++ ", failed to get (" ++ e ++ ")" + subCase e = H.TestLabel name + $ H.TestCase $ (e `elem` sentences) @? subMsg e + return $ (mainCase :) $ map subCase (tcExpected tc) + +-- | Run the specified test case, or failing that, the first test +-- case in the suite +runTestCaseOnly :: ProgStateRef -> IO ([GeniResult], Statistics) +runTestCaseOnly pstRef = + do pst <- readIORef pstRef + let config = pa pst + pstOutfile = fromMaybe "" $ getFlagP OutputFileFlg config + sFile = fromMaybe "" $ getFlagP StatsFileFlg config + semInput <- case getFlagP TestCaseFlg config of + Nothing -> if hasFlagP FromStdinFlg config + then do getContents >>= loadTargetSemStr pstRef + ts `fmap` readIORef pstRef + else getFirstCase pst + Just c -> findCase pst c + runOnSemInput pstRef (Standalone pstOutfile sFile) semInput + where + getFirstCase pst = + case tsuite pst of + [] -> fail "Test suite is empty." + (c:_) -> return $ tcSem c + findCase pst theCase = + case find (\x -> tcName x == theCase) (tsuite pst) of + Nothing -> fail ("No such test case: " ++ theCase) + Just s -> return $ tcSem s + +data RunAs = Standalone FilePath FilePath + | PartOfSuite String FilePath + | InRegressionTest + +-- | Runs a case in the test suite. If the user does not specify any test +-- cases, we run the first one. If the user specifies a non-existing +-- test case we raise an error. +runOnSemInput :: ProgStateRef + -> RunAs + -> SemInput + -> IO ([GeniResult], Statistics) +runOnSemInput pstRef args semInput = + do modifyIORef pstRef (\x -> x{ts = semInput}) + pst <- readIORef pstRef + let config = pa pst + (results', stats) <- case builderType config of + NullBuilder -> helper B.nullBuilder + SimpleBuilder -> helper simpleBuilder_2p + SimpleOnePhaseBuilder -> helper simpleBuilder_1p + CkyBuilder -> helper ckyBuilder + EarleyBuilder -> helper earleyBuilder + let results = sort results' + -- create directory if need be + case args of + PartOfSuite n f -> createDirectoryIfMissing False (f n) + _ -> return () + let oWrite = case args of + Standalone "" _ -> putStrLn + Standalone f _ -> writeFile f + PartOfSuite n f -> writeFile $ f n "responses" + InRegressionTest -> const $ return () + soWrite = case args of + Standalone _ "" -> putStrLn + Standalone _ f -> writeFile f + PartOfSuite n f -> writeFile $ f n "stats" + InRegressionTest -> const $ return () + oWrite . unlines . map fst $ results + -- print out statistical data (if available) + when (isJust $ getFlagP MetricsFlg config) $ + do soWrite $ "begin stats\n" ++ showFinalStats stats ++ "end" + return (results, stats) + where + helper builder = + do (results, stats, _) <- runGeni pstRef builder + return (results, stats) diff --git a/src/NLP/GenI/General.hs b/src/NLP/GenI/General.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/General.hs @@ -0,0 +1,435 @@ +-- 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. + +-- | This module provides some very generic, non-GenI specific functions on strings, +-- trees and other miscellaneous odds and ends. Whenever possible, one should try +-- to replace these functions with versions that are available in the standard +-- libraries, or the Haskell platform ones, or on hackage. + +module NLP.GenI.General ( + -- * IO + ePutStr, ePutStrLn, eFlush, + -- ** Strict readFile + readFile', + lazySlurp, + -- ** Timeouts + withTimeout, + exitTimeout, + -- * Strings + dropTillIncluding, + trim, + toUpperHead, toLowerHead, + toAlphaNum, + -- * Triples + fst3, snd3, thd3, + -- * Lists + equating, comparing, + map', + wordsBy, + boundsCheck, + isEmptyIntersect, + groupByFM, + multiGroupByFM, + insertToListMap, + groupAndCount, + combinations, + mapMaybeM, + repList, + -- * Trees + mapTree', filterTree, + treeLeaves, preTerminals, + repNode, repAllNode, listRepNode, repNodeByNode, + -- * Intervals + Interval, + (!+!), ival, showInterval, + -- * Bit vectors + BitVector, + showBitVector, + -- * Bugs + geniBug, + ) + where + +import Control.Monad (liftM) +import Data.Bits (shiftR, (.&.)) +import Data.Char (isDigit, isSpace, toUpper, toLower) +import Data.List (intersect, groupBy, group, sort) +import Data.Tree +import System.IO (hPutStrLn, hPutStr, hFlush, stderr) +import qualified Data.Map as Map + +-- for timeout +import Control.Concurrent +import Control.Exception +import Data.Dynamic(Typeable, typeOf, TyCon, mkTyCon, mkTyConApp, toDyn) +import Data.Unique +import System.Exit(exitWith, ExitCode(ExitFailure)) + +-- for non-lazy IO +import System.IO (openFile, IOMode(ReadMode), hFileSize, hGetBuf) +import System.IO.Unsafe (unsafeInterleaveIO) +import Foreign (mallocForeignPtrBytes, withForeignPtr, ForeignPtr, Ptr, peekElemOff, plusPtr, Word8) +import Data.Char (chr) + +-- ---------------------------------------------------------------------- +-- IO +-- ---------------------------------------------------------------------- + +-- | putStr on stderr +ePutStr :: String -> IO () +ePutStr = hPutStr stderr + +ePutStrLn :: String -> IO() +ePutStrLn = hPutStrLn stderr + +eFlush :: IO() +eFlush = hFlush stderr + +-- ---------------------------------------------------------------------- +-- Strings +-- ---------------------------------------------------------------------- + +trim :: String -> String +trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace) + +-- | Drop all characters up to and including the one in question +dropTillIncluding :: Char -> String -> String +dropTillIncluding c = drop 1 . (dropWhile (/= c)) + +-- | Make the first character of a string upper case +toUpperHead :: String -> String +toUpperHead [] = [] +toUpperHead (h:t) = (toUpper h):t + +-- | Make the first character of a string lower case +toLowerHead :: String -> String +toLowerHead [] = [] +toLowerHead(h:t) = (toLower h):t + +-- ---------------------------------------------------------------------- +-- Alphanumeric sort +-- ---------------------------------------------------------------------- + +-- | Intermediary type used for alphanumeric sort +data AlphaNum = A String | N Int deriving Eq + +-- we don't derive this, because we want num < alpha +instance Ord AlphaNum where + compare (A s1) (A s2) = compare s1 s2 + compare (N s1) (N s2) = compare s1 s2 + compare (A _) (N _) = GT + compare (N _) (A _) = LT + +-- | An alphanumeric sort is one where you treat the numbers in the string +-- as actual numbers. An alphanumeric sort would put x2 before x100, +-- because 2 < 10, wheraeas a naive sort would put it the other way +-- around because the characters 1 < 2. To sort alphanumerically, just +-- 'sortBy (comparing toAlphaNum)' +toAlphaNum :: String -> [AlphaNum] +toAlphaNum = map readOne . groupBy (equating isDigit) + where + readOne s + | all isDigit s = N (read s) + | otherwise = A s + +-- ---------------------------------------------------------------------- +-- Triples +-- ---------------------------------------------------------------------- + +fst3 :: (a,b,c) -> a +fst3 (x,_,_) = x + +snd3 :: (a,b,c) -> b +snd3 (_,x,_) = x + +thd3 :: (a,b,c) -> c +thd3 (_,_,x) = x + +-- ---------------------------------------------------------------------- +-- Lists +-- ---------------------------------------------------------------------- + +equating :: Eq b => (a -> b) -> (a -> a -> Bool) +equating f a b = f a == f b + +comparing :: Ord b => (a -> b) -> (a -> a -> Ordering) +comparing f a b = compare (f a) (f b) + +-- | A strict version of 'map' +map' :: (a->b) -> [a] -> [b] +map' _ [] = [] +map' f (x:xs) = let a = f x in a `seq` (a:(map' f xs)) + +-- | A generic version of the Data.List.words +-- TODO: replace by version from split +wordsBy :: (Eq a) => a -> [a] -> [[a]] +wordsBy c xs = filter (/= [c]) $ groupBy (\x y -> x /= c && y /= c) xs + +-- | Makes sure that index s is in the bounds of list l. +-- Surely there must be some more intelligent way to deal with this. +boundsCheck :: Int -> [a] -> Bool +boundsCheck s l = s >= 0 && s < length l + +-- | True if the intersection of two lists is empty. +isEmptyIntersect :: (Eq a) => [a] -> [a] -> Bool +isEmptyIntersect a b = null $ intersect a b + +-- ---------------------------------------------------------------------- +-- Grouping +-- ---------------------------------------------------------------------- + +-- | Serves the same function as 'Data.List.groupBy'. It groups together +-- items by some property they have in common. The difference is that the +-- property is used as a key to a Map that you can lookup. +groupByFM :: (Ord b) => (a -> b) -> [a] -> (Map.Map b [a]) +groupByFM fn list = + let addfn x acc key = insertToListMap key x acc + helper acc x = addfn x acc (fn x) + in foldl helper Map.empty list + +-- | Same as 'groupByFM', except that we let an item appear in +-- multiple groups. The fn extracts the property from the item, +-- and returns multiple results in the form of a list +multiGroupByFM :: (Ord b) => (a -> [b]) -> [a] -> (Map.Map b [a]) +multiGroupByFM fn list = + let addfn x acc key = insertToListMap key x acc + helper acc x = foldl (addfn x) acc (fn x) + in foldl helper Map.empty list + +{-# INLINE insertToListMap #-} +insertToListMap :: (Ord b) => b -> a -> Map.Map b [a] -> Map.Map b [a] +insertToListMap k i m = + case Map.lookup k m of + Nothing -> Map.insert k [i] m + Just p -> Map.insert k (i:p) m + +-- | Convert a list of items into a list of tuples (a,b) where +-- a is an item in the list and b is the number of times a +-- in occurs in the list. +groupAndCount :: (Eq a, Ord a) => [a] -> [(a, Int)] +groupAndCount xs = + map (\x -> (head x, length x)) grouped + where grouped = (group.sort) xs + +-- Given a list of lists, return all lists such that one item from each sublist is chosen. +-- If returns the empty list if there are any empty sublists. +combinations :: [[a]] -> [[a]] +combinations = sequence + +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM _ [] = return [] +mapMaybeM f (x:xs) = + f x >>= + (\my -> case my of + Nothing -> mapMaybeM f xs + Just y -> liftM (y:) (mapMaybeM f xs)) + +-- | Return the list, modifying only the first matching item. +repList :: (a->Bool) -> (a->a) -> [a] -> [a] +repList _ _ [] = [] +repList pr fn (x:xs) + | pr x = fn x : xs + | otherwise = x : (repList pr fn xs) + +-- ---------------------------------------------------------------------- +-- Trees +-- ---------------------------------------------------------------------- + +-- | Strict version of 'mapTree' (for non-strict, just use fmap) +mapTree' :: (a->b) -> Tree a -> Tree b +mapTree' fn (Node a []) = let b = fn a in b `seq` Node b [] +mapTree' fn (Node a l) = let b = fn a + bs = map' (mapTree' fn) l + in b `seq` bs `seq` Node b bs + +-- | Like 'filter', except on Trees. Filter might not be a good name, though, +-- because we return a list of nodes, not a tree. +filterTree :: (a->Bool) -> Tree a -> [a] +filterTree fn = (filter fn) . flatten + +-- | The leaf nodes of a Tree +treeLeaves :: Tree a -> [a] +treeLeaves (Node n []) = [n] +treeLeaves (Node _ l ) = concatMap treeLeaves l + +-- | Return pairs of (parent, terminal) +preTerminals :: Tree a -> [(a,a)] +preTerminals (Node _ []) = [] +preTerminals (Node x ks) = + [ (x,y) | (Node y ys) <- ks, null ys ] ++ concatMap preTerminals ks + +-- | 'repNode' @fn filt t@ returns a version of @t@ in which the first +-- node which @filt@ matches is transformed using @fn@. +repNode :: (Tree a -> Tree a) -- ^ replacement function + -> (Tree a -> Bool) -- ^ filtering function + -> Tree a -> Maybe (Tree a) +repNode fn filt t = + case listRepNode fn filt [t] of + (_, False) -> Nothing + ([t2], True) -> Just t2 + _ -> geniBug "Either repNode or listRepNode are broken" + +-- | Like 'repNode' except that it performs the operations on +-- all nodes that match and doesn't care if any nodes match +-- or not +repAllNode :: (Tree a -> Tree a) -> (Tree a -> Bool) + -> Tree a -> Tree a +repAllNode fn filt n | filt n = fn n +repAllNode fn filt (Node p ks) = Node p $ map (repAllNode fn filt) ks + +-- | Like 'repNode' but on a list of tree nodes +listRepNode :: (Tree a -> Tree a) -- ^ replacement function + -> (Tree a -> Bool) -- ^ filtering function + -> [Tree a] -- ^ nodes + -> ([Tree a], Bool) +listRepNode _ _ [] = ([], False) +listRepNode fn filt (n:l2) | filt n = (fn n : l2, True) +listRepNode fn filt ((n@(Node a l1)):l2) = + case listRepNode fn filt l1 of + (lt1, True) -> ((Node a lt1):l2, True) + _ -> case listRepNode fn filt l2 of + (lt2, flag2) -> (n:lt2, flag2) + +-- | Replace a node in the tree in-place with another node; keep the +-- children the same. If the node is not found in the tree, or if +-- there are multiple instances of the node, this is treated as an +-- error. +repNodeByNode :: (a -> Bool) -- ^ which node? + -> a -> Tree a -> Tree a +repNodeByNode nfilt rep t = + let tfilt (Node n _) = nfilt n + replaceFn (Node _ k) = Node rep k + in case listRepNode replaceFn tfilt [t] of + ([t2], True) -> t2 + (_ , False) -> geniBug "Node not found in repNode" + _ -> geniBug "Unexpected result in repNode" + +-- ---------------------------------------------------------------------- +-- Errors +-- ---------------------------------------------------------------------- + +-- | errors specifically in GenI, which is very likely NOT the user's fault. +geniBug :: String -> a +geniBug s = error $ "Bug in GenI!\n" ++ s ++ + "\nPlease file a report on http://wiki.loria.fr/wiki/GenI/Complaints" + +-- ---------------------------------------------------------------------- +-- Intervals +-- ---------------------------------------------------------------------- + +type Interval = (Int,Int) + +-- | Add two intervals +(!+!) :: Interval -> Interval -> Interval +(!+!) (a1,a2) (b1,b2) = (a1+b1, a2+b2) + +-- | 'ival' @x@ builds a trivial interval from 'x' to 'x' +ival :: Int -> Interval +ival i = (i,i) + +showInterval :: Interval -> String +showInterval (x,y) = + let sign i = if i > 0 then "+" else "" + -- + in if (x==y) + then (sign x) ++ (show x) + else show (x,y) + +-- ---------------------------------------------------------------------- +-- Bit vectors +-- ---------------------------------------------------------------------- + +type BitVector = Integer + +-- | displays a bit vector, using a minimum number of bits +showBitVector :: Int -> BitVector -> String +showBitVector min_ 0 = replicate min_ '0' +showBitVector min_ x = showBitVector (min_ - 1) (shiftR x 1) ++ (show $ x .&. 1) + +-- ---------------------------------------------------------------------- +-- Strict readfile +-- Simon Marlow wrote this code on the Haskell mailing list 2005-08-02. +-- ---------------------------------------------------------------------- + +-- | Using readFile' can be a good idea if you're dealing with not-so-huge +-- files (i.e. where you don't want lazy evaluation), because it ensures +-- that the handles are closed. No more ``too many open files'' +readFile' :: FilePath -> IO String +readFile' f = do + h <- openFile f ReadMode + s <- hFileSize h + fp <- mallocForeignPtrBytes (fromIntegral s) + len <- withForeignPtr fp $ \buf -> hGetBuf h buf (fromIntegral s) + lazySlurp fp 0 len + +buf_size :: Int +buf_size = 4096 :: Int + +lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String +lazySlurp fp ix len + | fp `seq` False = undefined + | ix >= len = return [] + | otherwise = do + cs <- unsafeInterleaveIO (lazySlurp fp (ix + buf_size) len) + ws <- withForeignPtr fp $ \p -> loop (min (len-ix) buf_size - 1) + ((p :: Ptr Word8) `plusPtr` ix) cs + return ws + where + loop :: Int -> Ptr Word8 -> String -> IO String + loop sublen p acc + | sublen `seq` p `seq` False = undefined + | sublen < 0 = return acc + | otherwise = do + w <- peekElemOff p sublen + loop (sublen-1) p (chr (fromIntegral w):acc) + +-- ---------------------------------------------------------------------- +-- Timeouts +-- ---------------------------------------------------------------------- + +data TimeOut = TimeOut Unique + +timeOutTc :: TyCon +timeOutTc = mkTyCon "TimeOut" + +instance Typeable TimeOut where + typeOf _ = mkTyConApp timeOutTc [] + +withTimeout :: Integer + -> IO a -- ^ action to run upon timing out + -> IO a -- ^ main action to run + -> IO a +withTimeout secs on_timeout action = + do parent <- myThreadId + i <- newUnique + block $ do + timeout <- forkIO (timeout_thread secs parent i) + Control.Exception.catchDyn + ( unblock $ do result <- action + killThread timeout + return result ) + ( \ex -> case ex of + TimeOut u | u == i -> unblock on_timeout + _ -> killThread timeout >>= throwDyn ex ) + where + timeout_thread secs_ parent i = + do threadDelay $ (fromInteger secs_) * 1000000 + throwTo parent (DynException $ toDyn $ TimeOut i) + +-- | Like 'exitFailure', except that we return with a code that we reserve for timing out +exitTimeout :: IO () +exitTimeout = exitWith $ ExitFailure 2 diff --git a/src/NLP/GenI/Geni.lhs b/src/NLP/GenI/Geni.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Geni.lhs @@ -0,0 +1,1029 @@ +% 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. + +\chapter{Geni} +\label{cha:Geni} + +Geni is the interface between the front and backends of the generator. The GUI +and the console interface both talk to this module, and in turn, this module +talks to the input file parsers and the surface realisation engine. This +module also does lexical selection and anchoring because these processes might +involve some messy IO performance tricks. + +\begin{code} +module NLP.GenI.Geni (ProgState(..), ProgStateRef, emptyProgState, + showRealisations, groupAndCount, + initGeni, runGeni, runGeniWithSelector, getTraces, GeniResult, Selector, + loadEverything, loadLexicon, loadGeniMacros, + loadTestSuite, loadTargetSemStr, + combine, + + -- used by auxiliary tools only + chooseLexCand, + ) +where +\end{code} + +\ignore{ +\begin{code} +import Control.Arrow (first) +import Control.Monad.Error +import Control.Monad (unless) + +import Data.Binary (Binary, decodeFile) +import Data.IORef (IORef, readIORef, modifyIORef) +import Data.List +import qualified Data.Map as Map +import Data.Maybe (mapMaybe, fromMaybe, isJust) +import Data.Tree (Tree(Node)) +import Data.Typeable (Typeable) + +import System.IO.Unsafe (unsafePerformIO) +import Text.ParserCombinators.Parsec +-- import System.Process + + +import NLP.GenI.General(filterTree, repAllNode, + equating, groupAndCount, multiGroupByFM, + geniBug, + repNodeByNode, + wordsBy, + fst3, + ePutStr, ePutStrLn, eFlush, + ) + +import NLP.GenI.Btypes + (Macros, MTtree, ILexEntry, Lexicon, + Replacable(..), + Sem, SemInput, TestCase(..), sortSem, subsumeSem, params, + GeniVal(GConst), fromGVar, + GNode(ganchor, gnname, gup, gdown, gaconstr, gtype, gorigin), Flist, + GType(Subs, Other), + isemantics, ifamname, iword, iparams, iequations, + iinterface, ifilters, + isempols, + toKeys, + showLexeme, showSem, + pidname, pfamily, pinterface, ptype, psemantics, ptrace, + setAnchor, setLexeme, tree, unifyFeat, + alphaConvert, + ) +import NLP.GenI.BtypesBinary () + +import NLP.GenI.Tags (Tags, TagElem, emptyTE, + idname, ttreename, + ttype, tsemantics, ttree, tsempols, + tinterface, ttrace, + setTidnums) + +import NLP.GenI.Configuration + ( Params, getFlagP, hasFlagP, hasOpt, Optimisation(NoConstraints) + , MacrosFlg(..), LexiconFlg(..), TestSuiteFlg(..), TestCaseFlg(..) + , MorphInfoFlg(..), MorphCmdFlg(..), MorphLexiconFlg(..) + , PartialFlg(..) + , IgnoreSemanticsFlg(..), FromStdinFlg(..), VerboseModeFlg(..) + , NoLoadTestSuiteFlg(..) + , TracesFlg(..) + , grammarType + , GrammarType(..) ) + +import qualified NLP.GenI.Builder as B + +import NLP.GenI.GeniParsers (geniMacros, geniTagElems, + geniLexicon, geniTestSuite, + geniTestSuiteString, geniSemanticInput, + geniMorphInfo, geniMorphLexicon, + ) +import NLP.GenI.Morphology +import NLP.GenI.Statistics (Statistics) + +-- import CkyBuilder +-- import SimpleBuilder (simpleBuilder) +\end{code} +} + +\begin{code} +myEMPTY :: String +myEMPTY = "MYEMPTY" +\end{code} + +% -------------------------------------------------------------------- +\section{ProgState} +% -------------------------------------------------------------------- + +\begin{code} +data ProgState = ST{ -- | the current configuration being processed + pa :: Params, + -- + gr :: Macros, + le :: Lexicon, + morphinf :: MorphFn, + morphlex :: Maybe [(String,String,Flist)], + ts :: SemInput, + -- | names of test case to run + tcase :: String, + -- | name, original string (for gui), sem + tsuite :: [TestCase], + -- | simplified traces (optional) + traces :: [String] + } + +type ProgStateRef = IORef ProgState + +-- | The program state when you start GenI for the very first time +emptyProgState :: Params -> ProgState +emptyProgState args = + ST { pa = args + , gr = [] + , le = Map.empty + , morphinf = const Nothing + , morphlex = Nothing + , ts = ([],[],[]) + , tcase = [] + , tsuite = [] + , traces = [] + } +\end{code} + +% -------------------------------------------------------------------- +\section{Interface} +\subsection{Loading and parsing} +% -------------------------------------------------------------------- + +We have one master function that loads all the files GenI is expected to +use. This just calls the sub-loaders below, some of which are exported +for use by the graphical interface. The master function also makes sure +to complain intelligently if some of the required files are missing. + +\begin{code} +loadEverything :: ProgStateRef -> IO() +loadEverything pstRef = + do pst <- readIORef pstRef + -- + let config = pa pst + isMissing f = not $ hasFlagP f config + -- grammar type + isNotPreanchored = grammarType config /= PreAnchored + isNotPrecompiled = grammarType config /= PreCompiled + useTestSuite = isMissing FromStdinFlg + && isMissing NoLoadTestSuiteFlg + -- display + let errormsg = + concat $ intersperse ", " [ msg | (con, msg) <- errorlst, con ] + errorlst = + [ (isNotPrecompiled && isMissing MacrosFlg, + "a tree file") + , (isNotPreanchored && isMissing LexiconFlg, + "a lexicon file") + , (useTestSuite && isMissing TestSuiteFlg, + "a test suite") ] + unless (null errormsg) $ fail ("Please specify: " ++ errormsg) + -- we only have to read in grammars from the simple format + case grammarType config of + PreAnchored -> return () + PreCompiled -> return () + _ -> loadGeniMacros pstRef + -- we don't have to read in the lexicon if it's already pre-anchored + when isNotPreanchored $ loadLexicon pstRef + -- in any case, we have to... + loadMorphInfo pstRef + when useTestSuite $ loadTestSuite pstRef + -- the morphological lexicon + loadMorphLexicon pstRef + -- the trace filter file + loadTraces pstRef +\end{code} + +The file loading functions all work the same way: we load the file, +and try to parse it. If this doesn't work, we just fail in IO, and +GenI dies. If we succeed, we update the program state passed in as +an IORef. + +\begin{code} +loadLexicon, loadGeniMacros, loadMorphInfo, loadMorphLexicon, loadTraces :: ProgStateRef -> IO () + +loadLexicon pstRef = + do config <- pa `fmap` readIORef pstRef + let getSem l = if hasFlagP IgnoreSemanticsFlg config + then [] else isemantics l + sorter l = l { isemantics = (sortSem . getSem) l } + cleanup = mapBySemKeys isemantics . map sorter + loadThingOrDie LexiconFlg "lexicon" pstRef + (parseFromFileOrFail geniLexicon) + (\l p -> p { le = cleanup l }) + +-- | The macros are stored as a hashing function in the monad. +loadGeniMacros pstRef = + loadThingOrDie MacrosFlg "trees" pstRef parser updater + where parser = parseFromFileMaybeBinary geniMacros + updater g p = p { gr = g } + + + +-- | The results are stored as a lookup function in the monad. +loadMorphInfo pstRef = + loadThingOrIgnore MorphInfoFlg "morphological info" pstRef parser updater + where parser = parseFromFileOrFail geniMorphInfo + updater m p = p { morphinf = readMorph m } + +loadMorphLexicon pstRef = + loadThingOrIgnore MorphLexiconFlg "morphological lexicon" pstRef parser updater + where parser = parseFromFileOrFail geniMorphLexicon + updater m p = p { morphlex = Just m } + +loadTraces pstRef = + loadThingOrIgnore TracesFlg "traces" pstRef + (\f -> lines `fmap` readFile f) + (\t p -> p {traces = t}) +\end{code} + +\subsubsection{Target semantics} + +Reading in the target semantics (or test suite) is a little more +complicated. It follows the same general schema as above, except +that we parse the file twice: once for our internal representation, +and once to get a string representation of each test case. The +string representation is for the graphical interface; it avoids us +figuring out how to pretty-print things because we can assume the +user will format it the way s/he wants. + +\begin{code} +-- | Stores the results in the tcase and tsuite fields +loadTestSuite :: ProgStateRef -> IO () +loadTestSuite pstRef = do + config <- pa `fmap` readIORef pstRef + unless (hasFlagP IgnoreSemanticsFlg config) $ + let parser f = do + sem <- parseFromFileOrFail geniTestSuite f + mStrs <- parseFromFileOrFail geniTestSuiteString f + return $ zip sem mStrs + updater s x = + x { tsuite = map cleanup s + , tcase = fromMaybe "" $ getFlagP TestCaseFlg config} + cleanup (tc,str) = + tc { tcSem = (sortSem sm, sort sr, lc) + , tcSemString = str } + where (sm, sr, lc) = tcSem tc + in loadThingOrDie TestSuiteFlg "test suite" pstRef parser updater +\end{code} + +Sometimes, the target semantics does not come from a file, but from +the graphical interface, so we also provide the ability to parse an +arbitrary string as the semantics. + +\begin{code} +-- | Updates program state the same way as 'loadTestSuite' +loadTargetSemStr :: ProgStateRef -> String -> IO () +loadTargetSemStr pstRef str = + do pst <- readIORef pstRef + if hasFlagP IgnoreSemanticsFlg (pa pst) then return () else parseSem + where + parseSem = do + let sem = runParser geniSemanticInput () "" str + case sem of + Left err -> fail (show err) + Right sr -> modifyIORef pstRef (\x -> x{ts = smooth sr}) + smooth (s,r,l) = (sortSem s, sort r, l) +\end{code} + +\subsubsection{Helpers for loading files} + +\begin{code} +type UpdateFn a = (a -> ProgState -> ProgState) + +loadThingOrIgnore, loadThingOrDie :: forall f a . (Eq f, Show f, Typeable f) + => (FilePath -> f) -- ^ flag + -> String + -> ProgStateRef + -> (FilePath -> IO [a]) + -> UpdateFn [a] + -> IO () + +loadThing :: FilePath -- ^ file to load + -> String -- ^ description + -> ProgStateRef + -> (FilePath -> IO [a]) -- ^ parsing cmd + -> UpdateFn [a] -- ^ update fn + -> IO () + +-- | Load the file if the relevant option is set, otherwise ignore +loadThingOrIgnore flag description pstRef parser job = + do config <- pa `fmap` readIORef pstRef + case getFlagP flag config of + Nothing -> return () + Just f -> loadThing f description pstRef parser job + +-- | Load the file if the relevant option is set, otherwise complain and die +loadThingOrDie flag description pstRef parser job = + do config <- pa `fmap` readIORef pstRef + case getFlagP flag config of + Nothing -> fail $ "Please specify a " ++ description ++ "!" + Just f -> loadThing f description pstRef parser job + +loadThing filename description pstRef parser job = + do config <- pa `fmap` readIORef pstRef + let verbose = hasFlagP VerboseModeFlg config + when verbose $ do + ePutStr $ unwords [ "Loading", description, filename ++ "... " ] + eFlush + theTs <- parser filename + when verbose $ ePutStr $ (show $ length theTs) ++ " entries\n" + modifyIORef pstRef (job theTs) + +parseFromFileOrFail :: Parser a -> FilePath -> IO a +parseFromFileOrFail p f = parseFromFile p f >>= either (fail.show) (return) + +parseFromFileMaybeBinary :: Binary a + => Parser a + -> FilePath + -> IO a +parseFromFileMaybeBinary p f = + if (".genib" `isSuffixOf` f) + then decodeFile f + else parseFromFileOrFail p f +\end{code} + +% -------------------------------------------------------------------- +\subsection{Surface realisation - entry point} +% -------------------------------------------------------------------- + +This is your basic entry point. You call this if the only thing you want to do +is run the surface realiser. + +\begin{enumerate} +\item It initialises the realiser (lexical selection, among other things), + via \fnref{initGeni} +\item It runs the builder (the surface realisation engine proper) +\item It unpacks the builder results +\item It finalises the results (morphological generation) +\end{enumerate} + +\begin{code} +type GeniResult = (String, B.Derivation) + +-- | Returns a list of sentences, a set of Statistics, and the generator state. +-- The generator state is mostly useful for debugging via the graphical interface. +-- Note that we assumes that you have already loaded in your grammar and +-- parsed your input semantics. +runGeni :: ProgStateRef -> B.Builder st it Params -> IO ([GeniResult], Statistics, st) +runGeni pstRef builder = runGeniWithSelector pstRef defaultSelector builder + +runGeniWithSelector :: ProgStateRef -> Selector -> B.Builder st it Params -> IO ([GeniResult], Statistics, st) +runGeniWithSelector pstRef selector builder = + do let run = B.run builder + unpack = B.unpack builder + getPartial = B.partial builder + -- step 1 + initStuff <- initGeniWithSelector pstRef selector + -- + pst <- readIORef pstRef + let config = pa pst + -- step 2 + (finalSt, stats) = run initStuff config + -- step 3 + uninflected = unpack finalSt + partial = getPartial finalSt + -- step 4 + sentences <- if null uninflected && hasFlagP PartialFlg config + then map (first star) `fmap` finaliseResults pstRef partial + else finaliseResults pstRef uninflected + return (sentences, stats, finalSt) + where star :: String -> String + star s = '*' : s +\end{code} + +% -------------------------------------------------------------------- +\subsection{Surface realisation - sub steps} +% -------------------------------------------------------------------- + +Below are the initial and final steps of \fnreflite{runGeni}. These functions +are seperated out so that they may be individually called from the graphical +debugger. The middle steps (running and unpacking the builder) depend on your +builder implementation. + +\begin{code} +-- | 'initGeni' performs lexical selection and strips the input semantics of +-- any morpohological literals +initGeni :: ProgStateRef -> IO (B.Input) +initGeni pstRef = initGeniWithSelector pstRef defaultSelector + +initGeniWithSelector :: ProgStateRef -> Selector -> IO (B.Input) +initGeniWithSelector pstRef lexSelector = + do -- disable constraints if the NoConstraintsFlg anti-optimisation is active + modifyIORef pstRef + (\p -> if hasOpt NoConstraints (pa p) + then p { ts = (fst3 (ts p),[],[]) } + else p) + -- lexical selection + pstLex <- readIORef pstRef + (cand, lexonly) <- lexSelector pstLex + -- strip morphological predicates + let (tsem,tres,lc) = ts pstLex + tsem2 = stripMorphSem (morphinf pstLex) tsem + -- + let initStuff = B.Input + { B.inSemInput = (tsem2, tres, lc) + , B.inLex = lexonly + , B.inCands = map (\c -> (c,-1)) cand + } + return initStuff +\end{code} + +\begin{code} +-- | 'finaliseResults' for the moment consists only of running the +-- morphological generator, but there could conceivably be more involved. +finaliseResults :: ProgStateRef -> [B.Output] -> IO [GeniResult] +finaliseResults pstRef os = + do mss <- runMorph pstRef ss + return . concat $ zipWith merge mss ds + where + (ss,ds) = unzip os + merge ms d = map (\m -> (m,d)) ms +\end{code} + +% -------------------------------------------------------------------- +\subsection{Displaying results} +% -------------------------------------------------------------------- + +\begin{code} +-- | Show the sentences produced by the generator, in a relatively compact form +showRealisations :: [String] -> String +showRealisations sentences = + let sentencesGrouped = map (\ (s,c) -> s ++ countStr c) g + where g = groupAndCount sentences + countStr c = if c > 1 then " (" ++ show c ++ " instances)" + else "" + in if null sentences + then "(none)" + else unlines sentencesGrouped +\end{code} + +\begin{code} +-- | 'getTraces' is most likely useful for grammars produced by a +-- metagrammar system. Given a tree name, we retrieve the ``trace'' +-- information from the grammar for all trees that have this name. We +-- assume the tree name was constructed by GenI; see the source code for +-- details. +getTraces :: ProgState -> String -> [String] +getTraces pst tname = + filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ] + where + filt = case traces pst of + [] -> id + theTs -> filter (`elem` theTs) + +-- | We assume the name was constructed by 'combineName' +readPidname :: String -> String +readPidname n = + case wordsBy ':' n of + (_:_:p:_) -> p + _ -> geniBug "readPidname or combineName are broken" +\end{code} + +% -------------------------------------------------------------------- +\section{Lexical selection} +\label{sec:candidate_selection} \label{sec:lexical_selecetion} \label{par:lexSelection} +% -------------------------------------------------------------------- + +\paragraph{runLexSelection} \label{fn:runLexSelection} determines which +candidates trees which will be used to generate the current target semantics. +In addition to the anchored candidate trees, we also return the lexical items +themselves. This list of lexical items is useful for debugging a grammar; +it lets us know if GenI managed to lexically select something, but did not +succeed in anchoring it. + +\begin{code} +runLexSelection :: ProgState -> IO ([TagElem], [ILexEntry]) +runLexSelection pst = + do -- select lexical items first + let (tsem,_,litConstrs) = ts pst + lexicon = le pst + lexCand = chooseLexCand lexicon tsem + config = pa pst + verbose = hasFlagP VerboseModeFlg config + -- then anchor these lexical items to trees + let grammar = gr pst + combineWithGr l = + do let (_, res) = combineList grammar l + familyMembers = [ p | p <- grammar, pfamily p == ifamname l ] + -- snippets of error message + let lexeme = showLexeme.iword $ l + _outOfFamily n = show n ++ "/" ++ (show $ length familyMembers) + ++ " instances of " ++ lexeme ++ ":" ++ ifamname l + -- print out missing coanchors list + case concatMap (missingCoanchors l) familyMembers of + [] -> return () + cs -> mapM_ showWarning . group . sort $ cs + where showWarning [] = geniBug "silly error in Geni.runLexSelection" + showWarning xs = + ePutStrLn $ + "Warning: Missing co-anchor '" ++ head xs ++ "'" + ++ " in " ++ (_outOfFamily $ length xs) ++ "." + -- print out enrichment errors +{- + unless (null enrichEs) $ do + let numDiscards = length enrichEs + badEnrichments = [ av | av <- iequations l, hasMatch av ] + hasMatch (a,_) = any (== parsePathEq a) errLocs + errLocs = map eeLocation enrichEs + ePutStrLn $ "Warning: Discarded " + ++ _outOfFamily numDiscards + ++ "\n due to enrichment failure with " + ++ "[" ++ showPairs badEnrichments ++ "]." + mapM (ePutStrLn.show) otherEs +-} + + -- FIXMENOW when (not.null $ errs) $ ePutStrLn (unlines errs) + return res + cand <- case grammarType config of + PreAnchored -> readPreAnchored pst + _ -> concat `liftM` mapM combineWithGr lexCand + -- attach any morphological information to the candidates + let considerMorph = attachMorph (morphinf pst) tsem + -- filter out candidates which do not fulfill the trace constraints + let matchesLc t = all (`elem` myTrace) constrs + where constrs = concat [ cs | (l,cs) <- litConstrs, l `elem` mySem ] + mySem = tsemantics t + myTrace = ttrace t + considerLc = filter matchesLc + -- filter out candidates whose semantics has bonus stuff which does + -- not occur in the input semantics + let considerCoherency = filter (all (`elem` tsem) . tsemantics) + considerHasSem = filter (not . null . tsemantics) + -- + let candFinal = setTidnums . considerCoherency . considerHasSem + . considerLc . considerMorph $ cand + indent x = ' ' : x + unlinesIndentAnd :: (x -> String) -> [x] -> String + unlinesIndentAnd f = unlines . map (indent . f) + when verbose $ + do ePutStrLn $ "Lexical items selected:\n" ++ (unlinesIndentAnd (showLexeme.iword) lexCand) + ePutStrLn $ "Trees anchored (family) :\n" ++ (unlinesIndentAnd idname candFinal) + -- lexical selection failures + let missedSem = tsem \\ (nub $ concatMap tsemantics candFinal) + hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand + where lsem = isemantics l + missedLex = filter (not.hasTree) lexCand + unless (null missedSem) $ + ePutStrLn $ "WARNING: no lexical selection for " ++ showSem missedSem + unless (null missedLex) $ + ePutStrLn $ "WARNING: '" ++ (concat $ intersperse ", " $ map showLex missedLex) + ++ "' were lexically selected, but are not anchored to" + ++ " any trees" + return (candFinal, lexCand) + where showLex l = (showLexeme $ iword l) ++ "-" ++ (ifamname l) + +-- | Select and returns the set of entries from the lexicon whose semantics +-- subsumes the input semantics. +chooseLexCand :: Lexicon -> Sem -> [ILexEntry] +chooseLexCand slex tsem = + let keys = toKeys tsem + -- we choose candidates that match keys + lookuplex t = Map.findWithDefault [] t slex + cand = concatMap lookuplex $ myEMPTY : keys + -- and refine the selection... + cand2 = chooseCandI tsem cand + -- treat synonyms as a single lexical entry + -- FIXME: disabled see mergeSynonyms for explanation + -- cand3 = mergeSynonyms cand2 + in cand2 +\end{code} + +With a helper function, we refine the candidate selection by +instatiating the semantics, at the same time filtering those which +do not stay within the target semantics, and finally eliminating +the duplicates. + +\begin{code} +chooseCandI :: Sem -> [ILexEntry] -> [ILexEntry] +chooseCandI tsem cand = + let replaceLex i (sem,sub) = + (replace sub i) { isemantics = sem } + -- + helper :: ILexEntry -> [ILexEntry] + helper l = if null sem then [l] + else map (replaceLex l) psubsem + where psubsem = subsumeSem tsem sem + sem = isemantics l + -- + in nub $ concatMap helper cand +\end{code} + +A semantic key is a semantic literal boiled down to predicate plus arity +(see section \ref{btypes_semantics}). + + +\begin{code} +-- | 'mapBySemKeys' @xs fn@ organises items (@xs@) by their semantic key +-- (retrieved by @fn@). An item may have multiple keys. +--- This is used to organise the lexicon by its semantics. +mapBySemKeys :: (a -> Sem) -> [a] -> Map.Map String [a] +mapBySemKeys semfn xs = + let gfn t = if (null s) then [myEMPTY] else toKeys s + where s = semfn t + in multiGroupByFM gfn xs +\end{code} + +\fnlabel{mergeSynonyms} is a factorisation technique that uses +atomic disjunction to merge all synonyms into a single lexical +entry. Two lexical entries are considered synonyms if their +semantics match and they point to the same tree families. + +FIXME: 2006-10-11 - note that this is no longer being used, +because it breaks the case where two lexical entries differ +only by their use of path equations. Perhaps it's worthwhile +just to add a check that the path equations match exactly. + +\begin{code} +{- +mergeSynonyms :: [ILexEntry] -> [ILexEntry] +mergeSynonyms lexEntry = + let mergeFn l1 l2 = l1 { iword = (iword l1) ++ (iword l2) } + keyFn l = (ifamname l, isemantics l) + synMap = foldr helper Map.empty lexEntry + where helper x acc = Map.insertWith mergeFn (keyFn x) x acc + in Map.elems synMap +-} +\end{code} + +% -------------------------------------------------------------------- +\subsection{Basic anchoring} +\label{sec:combine_macros} +% -------------------------------------------------------------------- + +This section of the code helps you to combined a selected lexical item with +a macro or a list of macros. This is a process that can go fail for any +number of reasons, so we try to record the possible failures for book-keeping. + +\begin{code} +data LexCombineError = + BoringError String + | EnrichError { eeMacro :: MTtree + , eeLexEntry :: ILexEntry + , eeLocation :: PathEqLhs } + | OtherError MTtree ILexEntry String + +instance Error LexCombineError where + noMsg = strMsg "error combining items" + strMsg s = BoringError s + +instance Show LexCombineError where + show (BoringError s) = "Warning: " ++ s + show (OtherError t l s) = + "Warning: " ++ s ++ " on " ++ (pidname t) ++ "-" ++ (pfamily t) ++ " (" ++ (showLexeme $ iword l) ++ ")" + show (EnrichError t l _) = show (OtherError t l "enrichment error") +\end{code} + +The first step in lexical selection is to collect all the features and +parameters that we want to combine. + +\begin{code} +-- | 'combine' @macros lex@ creates the 'Tags' repository combining lexical +-- entries and un-anchored trees from the grammar. It also unifies the +-- parameters used to specialize un-anchored trees and propagates additional +-- features given in the 'ILexEntry'. +combine :: Macros -> Lexicon -> Tags +combine gram lexicon = + let helper li = mapEither (combineOne li) macs + where tn = ifamname li + macs = [ t | t <- gram, pfamily t == tn ] + in Map.map (\e -> concatMap helper e) lexicon + +mapEither :: (a -> Either l r) -> [a] -> [r] +mapEither fn = mapMaybe (\x -> either (const Nothing) Just $ fn x) +\end{code} + +\begin{code} +-- | Given a lexical item, looks up the tree families for that item, and +-- anchor the item to the trees. +combineList :: Macros -> ILexEntry + -> ([LexCombineError],[TagElem]) -- ^ any warnings, plus the results +combineList gram lexitem = + case [ t | t <- gram, pfamily t == tn ] of + [] -> ([BoringError $ "Family " ++ tn ++ " not found in Macros"],[]) + macs -> unzipEither $ map (combineOne lexitem) macs + where tn = ifamname lexitem + +unzipEither :: (Error e, Show b) => [Either e b] -> ([e], [b]) +unzipEither es = helper ([],[]) es where + helper accs [] = accs + helper (eAcc, rAcc) (Left e : next) = helper (e:eAcc,rAcc) next + helper (eAcc, rAcc) (Right r : next) = helper (eAcc,r:rAcc) next +\end{code} + +\begin{code} +-- | Combine a single tree with its lexical item to form a bonafide TagElem. +-- This process can fail, however, because of filtering or enrichement +combineOne :: ILexEntry -> MTtree -> Either LexCombineError TagElem +combineOne lexRaw eRaw = -- Maybe monad + -- trace ("\n" ++ (show wt)) $ + do let l1 = alphaConvert "-l" lexRaw + e1 = alphaConvert "-t" eRaw + (l,e) <- unifyParamsWithWarning (l1,e1) + >>= unifyInterfaceUsing iinterface + >>= unifyInterfaceUsing ifilters -- filtering + >>= enrichWithWarning -- enrichment + let name = concat $ intersperse ":" $ filter (not.null) + [ head (iword l) , pfamily e , pidname e ] + return $ emptyTE + { idname = name + , ttreename = pfamily e + , ttype = ptype e + , ttree = setOrigin name . setLemAnchors . setAnchor (iword l) $ tree e + , tsemantics = + sortSem $ case psemantics e of + Nothing -> isemantics l + Just s -> s + , tsempols = isempols l + , tinterface = pinterface e + , ttrace = ptrace e + } + where + unifyParamsWithWarning (l,t) = + -- trace ("unify params " ++ wt) $ + let lp = iparams l + tp = map fromGVar $ params t + psubst = zip tp lp + in if (length lp) /= (length tp) + then Left $ OtherError t l $ "Parameter length mismatch" + else Right $ (replaceList psubst l, replaceList psubst t) + -- + unifyInterfaceUsing ifn (l,e) = + -- trace ("unify interface" ++ wt) $ + case unifyFeat (ifn l) (pinterface e) of + Nothing -> Left $ OtherError e l $ "Interface unification error" + Just (int2, fsubst) -> Right $ (replace fsubst l, e2) + where e2 = (replace fsubst e) { pinterface = int2 } + -- + enrichWithWarning (l,e) = + -- trace ("enrich" ++ wt) $ + do e2 <- enrich l e + return (l,e2) +\end{code} + +\subsubsection{CGM Enrichement} + +Enrichment is a concept introduced by the common grammar manifesto +\cite{kow05CGM}, the idea being that during lexical selection, you sometimes +want to add feature structures to specific nodes in a tree. + +The conventions taken by GenI for path equations are: + +\begin{tabular}{|l|p{8cm}|} +\hline +\verb!interface.foo=bar! & +\fs{foo=bar} is unified into the interface (not the tree) \\ +\hline +\verb!anchor.bot.foo=bar! & +\fs{foo=bar} is unified into the bottom feature of the node +which is marked anchor. \\ +\hline +\verb!toto.top.foo=bar! & +\fs{foo=bar} is unified into the top feature of node named toto \\ +\hline +\verb!toto.bot.foo=bar! & +\fs{foo=bar} is unified into the bot feature of node named toto \\ +\hline +\verb!anchor.foo=bar! & +same as \verb!anchor.bot.foo=bar! \\ +\hline +\verb!anc.whatever...! & +same as \verb!anchor.whatever...! \\ +\hline +\verb!top.foo=bar! & +same as \verb!anchor.top.foo=bar! \\ +\hline +\verb!bot.foo=bar! & +same as \verb!anchor.bot.foo=bar! \\ +\hline +\verb!foo=bar! & +same as \verb!anchor.bot.foo=bar! \\ +\hline +\verb!toto.foo=bar! & +same as \verb!toto.top.foo=bar! (creates a warning) \\ +\hline +\end{tabular} + +\begin{code} +-- | (node, top, att) (node is Nothing if anchor) +type PathEqLhs = (String, Bool, String) +type PathEqPair = (PathEqLhs, GeniVal) + +enrich :: ILexEntry -> MTtree -> Either LexCombineError MTtree +enrich l t = + do -- separate into interface/anchor/named + let (intE, namedE) = lexEquations l + -- enrich the interface and everything else + t2 <- foldM enrichInterface t intE + -- enrich everything else + foldM (enrichBy l) t2 namedE + where + toAvPair ((_,_,a),v) = (a,v) + enrichInterface tx en = + do (i2, isubs) <- unifyFeat [toAvPair en] (pinterface tx) + `catchError` (\_ -> throwError $ ifaceEnrichErr en) + return $ (replace isubs tx) { pinterface = i2 } + ifaceEnrichErr (loc,_) = EnrichError + { eeMacro = t + , eeLexEntry = l + , eeLocation = loc } + +enrichBy :: ILexEntry -- ^ lexeme (for debugging info) + -> MTtree + -> (PathEqLhs, GeniVal) -- ^ enrichment eq + -> Either LexCombineError MTtree +enrichBy lexEntry t (eqLhs, eqVal) = + case seekCoanchor eqName t of + Nothing -> return t -- to be robust, we accept if the node isn't there + Just a -> + do let tfeat = (if eqTop then gup else gdown) a + (newfeat, sub) <- unifyFeat [(eqAtt,eqVal)] tfeat + `catchError` (\_ -> throwError enrichErr) + let newnode = if eqTop then a {gup = newfeat} + else a {gdown = newfeat} + return $ fixNode newnode $ replace sub t + where + (eqName, eqTop, eqAtt) = eqLhs + fixNode n mt = mt { tree = repNodeByNode (matchNodeName eqName) n (tree mt) } + enrichErr = EnrichError { eeMacro = t + , eeLexEntry = lexEntry + , eeLocation = eqLhs } + +pathEqName :: PathEqPair -> String +pathEqName = fst3.fst + +missingCoanchors :: ILexEntry -> MTtree -> [String] +missingCoanchors lexEntry t = + -- list monad + do eq <- nubBy (equating pathEqName) $ snd $ lexEquations lexEntry + let name = pathEqName eq + case seekCoanchor name t of + Nothing -> [name] + Just _ -> [] + +-- | Split a lex entry's path equations into interface enrichement equations +-- or (co-)anchor modifiers +lexEquations :: ILexEntry -> ([PathEqPair], [PathEqPair]) +lexEquations = + partition (nameIs "interface") . map (first parsePathEq) . iequations + where nameIs n x = pathEqName x == n + +seekCoanchor :: String -> MTtree -> Maybe GNode +seekCoanchor eqName t = + case filterTree (matchNodeName eqName) (tree t) of + [a] -> Just a + [] -> Nothing + _ -> geniBug $ "Tree with multiple matches in enrichBy. " ++ + "\nTree: " ++ pidname t ++ "\nFamily: " ++ pfamily t ++ + "\nMatching on: " ++ eqName + +matchNodeName :: String -> GNode -> Bool +matchNodeName "anchor" = ganchor +matchNodeName n = (== n) . gnname + +-- | Parse a path equation using the GenI conventions +parsePathEq :: String -> PathEqLhs +parsePathEq e = + case wordsBy '.' e of + (n:"top":r) -> (n, True, rejoin r) + (n:"bot":r) -> (n, False, rejoin r) + ("top":r) -> ("anchor", True, rejoin r) + ("bot":r) -> ("anchor", False, rejoin r) + ("anc":r) -> parsePathEq $ rejoin $ "anchor":r + ("anchor":r) -> ("anchor", False, rejoin r) + ("interface":r) -> ("interface", False, rejoin r) + (n:r) -> unsafePerformIO $ do + ePutStrLn $ "Warning: Interpreting path equation " ++ e ++ + " as applying to top of " ++ n ++ "." + return (n, True, rejoin r) + _ -> unsafePerformIO $ do + ePutStrLn $ "Warning: could not interpret path equation " ++ e + return ("", True, e) -- unknown + where + rejoin = concat . (intersperse ".") +\end{code} + +\subsubsection{Lemanchor mechanism} + +One problem in building reversible grammars is the treatment of co-anchors. +In the French language, for example, we have some structures like +\natlang{C'est Jean qui regarde Marie} +\natlang{It is John who looks at Mary} + +One might be tempted to hard code the ce (it) and the être (is) into the tree +for regarder (look at), something like \texttt{s(ce, être, n$\downarrow$, qui, +v(regarder), n$\downarrow$)}. Indeed, this would work just fine for +generation, but not for parsing. When you parse, you would encounter inflected +forms for these items for example \natlang{c'} for \natlang{ce} or +\natlang{sont} or \natlang{est} for \natlang{être}. Hard-coding the \natlang{ce} +into such trees would break parsing. + +To work around this, we propose a mechanism to have our co-anchors and parsing +too. Co-anchors that are susceptible to morphological variation should be +\begin{itemize} +\item marked in a substitution site (this is to keep parsers happy) +\item have a feature \texttt{bot.lemanchor:foo} where foo is the + coanchor you want +\end{itemize} + +GenI will convert these into non-substitution sites with a lexical item +leaf node. + +\begin{code} +setLemAnchors :: Tree GNode -> Tree GNode +setLemAnchors t = + repAllNode fn filt t + where + filt (Node a []) = gtype a == Subs && (isJust. lemAnchor) a + filt _ = False + fn (Node x k) = setLexeme (lemAnchorMaybeFake x) $ + Node (x { gtype = Other, gaconstr = False }) k + -- + lemAnchorMaybeFake :: GNode -> [String] + lemAnchorMaybeFake n = + case lemAnchor n of + Nothing -> ["ERR_UNSET_LEMMANCHOR"] + Just l -> l + lemAnchor :: GNode -> Maybe [String] + lemAnchor n = + case [ v | (a,v) <- gdown n, a == _lemanchor ] of + [GConst l] -> Just l + _ -> Nothing + +_lemanchor :: String +_lemanchor = "lemanchor" +\end{code} + +\subsubsection{Node origins} + +After lexical selection, we label each tree node with its origin, most +likely the name and id of its elementary tree. This is useful for +building derivation trees + +\begin{code} +setOrigin :: String -> Tree GNode -> Tree GNode +setOrigin t = fmap (\g -> g { gorigin = t }) +\end{code} + +% -------------------------------------------------------------------- +\subsection{Pre-selection and pre-anchoring} +\label{sec:pre-anchor} +% -------------------------------------------------------------------- + +For testing purposes, we can perform lexical selection ahead of time and store +it somewhere else. + +\begin{code} +-- | Only used for instances of GenI where the grammar is compiled +-- directly into GenI. +type Selector = ProgState -> IO ([TagElem],[ILexEntry]) + +defaultSelector :: Selector +defaultSelector = runLexSelection +\end{code} + +For debugging purposes, it is often useful to perform lexical selection and +surface realisation separately. Pre-anchored mode allows the user to just +pass the lexical selection in as a file of anchored trees associated with a +semantics. + +\begin{code} +readPreAnchored :: ProgState -> IO [TagElem] +readPreAnchored pst = + case getFlagP MacrosFlg (pa pst) of + Nothing -> fail "No macros file specified (preanchored mode)" + Just file -> parseFromFileOrFail geniTagElems file +\end{code} + +% -------------------------------------------------------------------- +\section{Morphology} +% -------------------------------------------------------------------- + +\begin{code} +-- | 'runMorph' inflects a list of sentences if a morphlogical generator +-- has been specified. If not, it returns the sentences as lemmas. +runMorph :: ProgStateRef -> [[(String,Flist)]] -> IO [[String]] +runMorph pstRef sentences = + do pst <- readIORef pstRef + case morphlex pst of + Just m -> return (inflectSentencesUsingLex m sentences) + Nothing -> case getFlagP MorphCmdFlg (pa pst) of + Nothing -> return $ map sansMorph sentences + Just cmd -> inflectSentencesUsingCmd cmd sentences +\end{code} + + diff --git a/src/NLP/GenI/GeniParsers.lhs b/src/NLP/GenI/GeniParsers.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GeniParsers.lhs @@ -0,0 +1,763 @@ +% 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. + +\chapter{File formats (GeniParsers)} +\label{cha:GeniParsers} + +This chapter is a description of the file format used by GenI. You +might also have to look at the LORIA wiki for documentation on this. +See \url{http://wiki.loria.fr/wiki/GenI/Input_format}. If the +descriptions here sound a little weird to you, it's likely because +they used to be source code comments, and are being converted into +actual documentation. + +\ignore{ +\begin{code} +module NLP.GenI.GeniParsers ( + -- test suite stuff + geniTestSuite, geniSemanticInput, geniTestSuiteString, + geniDerivations, + toSemInputString, + -- macros + geniMacros, + -- lexicons + geniLexicon, geniMorphLexicon, geniMorphInfo, + -- features and polarities + geniFeats, geniPolarities, + -- TagElem, + geniTagElems, + -- things used by external scripts + geniSemantics, geniValue, geniWords, geniLanguageDef, tillEof, +) where + +import NLP.GenI.General ((!+!), Interval, ival) +import NLP.GenI.Btypes +import NLP.GenI.Tags (TagElem(..), emptyTE, setTidnums) +import NLP.GenI.GeniShow (GeniShow(geniShow)) +import Control.Monad (liftM, when) +import Data.List (sort) +import qualified Data.Map as Map +import qualified Data.Tree as T +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language (emptyDef) +import Text.ParserCombinators.Parsec.Token (TokenParser, + LanguageDef(..), makeTokenParser) +import qualified Text.ParserCombinators.Parsec.Token as P + +-- reserved words +#define SEMANTICS "semantics" +#define SENTENCE "sentence" +#define OUTPUT "output" +#define TRACE "trace" +#define ANCHOR "anchor" +#define SUBST "subst" +#define FOOT "foot" +#define LEX "lex" +#define TYPE "type" +#define ACONSTR_NOADJ "aconstr:noadj" +#define INITIAL "initial" +#define AUXILIARY "auxiliary" +#define IDXCONSTRAINTS "idxconstraints" +#define BEGIN "begin" +#define END "end" +\end{code} +} + +\section{Test suites} + +The test suite format consists of arbitrarily many test cases: + +\begin{code} +geniTestSuite :: Parser [TestCase] +geniTestSuite = + tillEof (many geniTestCase) + +-- | Just the String representations of the semantics +-- in the test suite +geniTestSuiteString :: Parser [String] +geniTestSuiteString = + tillEof (many geniTestCaseString) + +-- | This is only used by the script genimakesuite +geniDerivations :: Parser [TestCaseOutput] +geniDerivations = tillEof $ many geniOutput +\end{code} + +A test case is composed of an optional test id, some semantic input +\fnref{geniSemanticInput}, followed by any number of sentences +and optionally followed by a list of outputs. +The sentences can either be known good sentences (optionally preceded by the +keyword 'sentence' -- perhaps this should be mandatory one day). The outputs +are used directly by users. The field is useful for noting what outputs were +actually produced, say, in a script that generates test suites from GenI +output. This field doesn't have much use for GenI per se, just its satellite +scripts. + +\begin{code} +geniTestCase :: Parser TestCase +geniTestCase = + do name <- option "" (identifier "a test case name") + seminput <- geniSemanticInput + sentences <- many geniSentence + outputs <- many geniOutput + return $ TestCase name "" seminput sentences outputs + +-- note that the keyword is NOT optional +type TestCaseOutput = (String, Map.Map (String,String) [String]) +geniOutput :: Parser TestCaseOutput +geniOutput = + do ws <- keyword OUTPUT >> (squares geniWords) + ds <- Map.fromList `fmap` many geniTraces + return (ws, ds) + +geniTraces :: Parser ((String,String), [String]) +geniTraces = + do keyword TRACE + squares $ do + k1 <- withWhite geniWord + k2 <- withWhite geniWord + whiteSpace >> char '!' >> whiteSpace + traces <- sepEndBy1 geniWord whiteSpace + return ((k1,k2), traces) + +withWhite :: Parser a -> Parser a +withWhite p = p >>= (\a -> whiteSpace >> return a) + +geniSentence :: Parser String +geniSentence = optional (keyword SENTENCE) >> squares geniWords + +geniWords :: Parser String +geniWords = + unwords `fmap` (sepEndBy1 geniWord whiteSpace "a sentence") + +geniWord :: Parser String +geniWord = many1 (noneOf "[]\v\f\t\r\n ") + +-- | The original string representation of a test case semantics +-- (for gui) +geniTestCaseString :: Parser String +geniTestCaseString = + do option "" (identifier "a test case name") + s <- geniSemanticInputString + many geniSentence + many geniOutput + return s +\end{code} + +\section{Semantics} + +\fnlabel{geniSemanticInput} consists of a semantics, and optionally a +set of index constraints. + +The semantics may contain literal based constraints as described in +section \ref{sec:fixme}. These constraints are just a space-delimited +list of String. When returning the results, we separate them out from +the semantics proper so that they can be treated separately. + +Index constraints are represented as feature structures. For more +details about them, see \fnref{detectIdxConstraints}. + +\begin{code} +geniSemanticInput :: Parser (Sem,Flist,[LitConstr]) +geniSemanticInput = + do keywordSemantics + (sem,litC) <- liftM unzip $ squares $ many literalAndConstraint + idxC <- option [] geniIdxConstraints + -- + let sem2 = createHandles sem + semlitC2 = [ (s,c) | (s,c) <- zip sem2 litC, (not.null) c ] + return (createHandles sem, idxC, semlitC2) + where + -- set all anonymous handles to some unique value + -- this is to simplify checking if a result is + -- semantically complete + createHandles :: Sem -> Sem + createHandles = zipWith setHandle ([1..] :: [Int]) + -- + setHandle i (h, pred_, par) = + let h2 = if h /= GAnon then h + else GConst ["genihandle" ++ (show i)] + in (h2, pred_, par) + -- + literalAndConstraint :: Parser (Pred, [String]) + literalAndConstraint = + do l <- geniLiteral + t <- option [] $ squares $ many identifier + return (l,t) + +-- | The original string representation of the semantics (for gui) +geniSemanticInputString :: Parser String +geniSemanticInputString = + do keywordSemantics + s <- squaresString + whiteSpace + optional geniIdxConstraints + return s + +geniIdxConstraints :: Parser Flist +geniIdxConstraints = keyword IDXCONSTRAINTS >> geniFeats + +squaresString :: Parser String +squaresString = + do char '[' + s <- liftM concat $ many $ (many1 $ noneOf "[]") <|> squaresString + char ']' + return $ "[" ++ s ++ "]" + +-- the output end of things +-- displaying preformatted semantic input + +data SemInputString = SemInputString String Flist + +instance GeniShow SemInputString where + geniShow (SemInputString semStr idxC) = + SEMANTICS ++ ":" ++ semStr ++ (if null idxC then "" else r) + where r = "\n" ++ IDXCONSTRAINTS ++ ": " ++ showFlist idxC + +toSemInputString :: SemInput -> String -> SemInputString +toSemInputString (_,lc,_) s = SemInputString s lc +\end{code} + +\section{Lexicon} + +A lexicon is just a whitespace seperated list of lexical entries. +Each lexical entry is +\begin{enumerate} +\item A lemma +\item The family name of things this lemma anchors to +\item The interface to the tree. Here's the compicated bit. + Either you provide : +\begin{itemize} +\item A list of parameters and an interface, as defined in + \fnref{geniParams}. The interface is meant to be unified with + the tree interface. +\item A feature structure which is to be unifed with the tree interface. + This is equivalent to the attribute-value pairs above; the only + difference is that we don't do any parameters, and we use square + brackets instead of parentheses. +\item Optionally: a set of path equations for enrichmment. + This feature structure can consist of + path equations of the form node.att:val, because they will be + unified with the entire tree and not just the tree interface. To + force something to unify with a tree interface in XMG, you should + supply ``interface.'' as a node name. +\end{itemize} +\item Optionally: a set of filters. This is to be used in conjunction + with XMG's SelectTAG. Note that you must explicitly include + family as an attribute, even if it's already declared in the + lexical entry. +\end{enumerate} + +\begin{code} +geniLexicon :: Parser [ILexEntry] +geniLexicon = tillEof $ many1 geniLexicalEntry + +geniLexicalEntry :: Parser ILexEntry +geniLexicalEntry = + do lemma <- (looseIdentifier <|> stringLiteral) "a lemma" + family <- identifier "a tree family" + (pars, interface) <- option ([],[]) $ parens paramsParser + equations <- option [] $ do keyword "equations" + geniFeats "path equations" + filters <- option [] $ do keyword "filters" + geniFeats + keywordSemantics + (sem,pols) <- squares geniLexSemantics + -- + return emptyLE { iword = [lemma] + , ifamname = family + , iparams = pars + , iinterface = sortFlist interface + , iequations = equations + , ifilters = filters + , isemantics = sem + , isempols = pols } + where + paramsParser :: Parser ([GeniVal], Flist) + paramsParser = do + pars <- many geniValue "some parameters" + interface <- option [] $ do symbol "!" + many geniAttVal + return (pars, interface) +\end{code} + +\section{Trees} + +\subsection{Macros} + +A macro library is basically a list of trees. + +\begin{code} +geniMacros :: Parser [MTtree] +geniMacros = tillEof $ many geniTreeDef + +initType, auxType :: Parser Ptype +initType = do { reserved INITIAL ; return Initial } +auxType = do { reserved AUXILIARY ; return Auxiliar } +\end{code} + +\subsection{Tree definitions} + +A tree definition consists of +\begin{enumerate} +\item a family name, followed by an optional tree id +\item the tree parameters/interface as defined in \fnref{geniParams} +\item (optional) a tree type specification, as parameterised through the + \fnparam{ttypeP} argument +\item the tree itself +\end{enumerate} + +\begin{code} +geniTreeDef :: Parser MTtree +geniTreeDef = + do sourcePos <- getPosition + family <- identifier + tname <- option "" $ do { colon; identifier } + (pars,iface) <- geniParams + theTtype <- (initType <|> auxType) + theTree <- geniTree + -- sanity checks? + let treeFail x = + do setPosition sourcePos -- FIXME does not do what I expect + fail $ "In tree " ++ family ++ ":" ++ tname ++ " " ++ show sourcePos ++ ": " ++ x + let theNodes = T.flatten theTree + numFeet = length [ x | x <- theNodes, gtype x == Foot ] + numAnchors = length [ x | x <- theNodes, ganchor x ] + when (not $ any ganchor theNodes) $ + treeFail "At least one node in an LTAG tree must be an anchor" + when (numAnchors > 1) $ + treeFail "There can be no more than 1 anchor node in a tree" + when (numFeet > 1) $ + treeFail "There can be no more than 1 foot node in a tree" + when (theTtype == Initial && numFeet > 0) $ + treeFail "Initial trees may not have foot nodes" + -- + psem <- option Nothing $ do { keywordSemantics; liftM Just (squares geniSemantics) } + ptrc <- option [] $ do { keyword TRACE; squares (many identifier) } + -- + return TT{ params = pars + , pfamily = family + , pidname = tname + , pinterface = sortFlist iface + , ptype = theTtype + , tree = theTree + , ptrace = ptrc + , psemantics = psem + } +\end{code} + +\subsection{Tree structure} + +A tree is recursively defined as a node followed by an optional list of child +nodes. If there are any child nodes, they appear between curly brackets. + +A node consists of + +\begin{enumerate} +\item A node name +\item (optionally) a node type (anchor, lexeme, foot, subst). +\item (if node type is lexeme) a lexeme +\item (optionally) an adjunction constraint + (Notes: We only know about null adjunction constraints. + If the node has a type, it is assumed as having + a null adjunction constraint) +\end{enumerate} + +Example of a tree: +\begin{verbatim} +n2 type:subst [cat:np idx:?Agent]![] +n3[cat:vp idx:?Event]![] +{ + n4 aconstr:noadj [cat:v idx:?Event]![] + { + n5 anchor + } +\end{verbatim} + +\begin{code} +geniTree :: Parser (T.Tree GNode) +geniTree = + do node <- geniNode + kids <- option [] (braces $ many geniTree) + "child nodes" + -- sanity checks + let noKidsAllowed t c = when (c node && (not.null $ kids)) $ + fail $ t ++ " nodes may *not* have any children" + noKidsAllowed "Anchor" $ ganchor + noKidsAllowed "Substitution" $ (== Subs) . gtype + noKidsAllowed "Foot" $ (== Foot) . gtype + -- + return (T.Node node kids) + +geniNode :: Parser GNode +geniNode = + do name <- identifier + nodeType <- option "" ( (keyword TYPE >> typeParser) + <|> + reserved ANCHOR) + lex_ <- if nodeType == LEX + then (sepBy (stringLiteral<|>identifier) (symbol "|") "some lexemes") + else return [] + constr <- case nodeType of + "" -> adjConstraintParser + ANCHOR -> adjConstraintParser + _ -> return True + (top_,bot_) <- -- features only obligatory for non-lex nodes + if nodeType == LEX + then option ([],[]) $ try topbotParser + else topbotParser + -- + let top = sort top_ + bot = sort bot_ + nodeType2 = case nodeType of + ANCHOR -> Lex + LEX -> Lex + FOOT -> Foot + SUBST -> Subs + "" -> Other + other -> error ("unknown node type: " ++ other) + return $ GN { gnname = name, gtype = nodeType2 + , gup = top, gdown = bot + , glexeme = lex_ + , ganchor = (nodeType == ANCHOR) + , gaconstr = constr + , gorigin = "" } + where + typeParser = choice $ map (try.symbol) [ ANCHOR, FOOT, SUBST, LEX ] + adjConstraintParser = option False $ reserved ACONSTR_NOADJ >> return True + topbotParser = + do top <- geniFeats "top features" + symbol "!" + bot <- geniFeats "bot features" + return (top,bot) +\end{code} + +\subsection{TagElem} + +For debugging purposes, it is often useful to be able to read TagElem's +directly. Note that this shares a lot of code with the macros above. +Hopefully, it is reasonably refactored. + +FIXME: note that this is very rudimentary; we do not set id numbers, +parse polarities. You'll have to call +some of our helper functions if you want that functionality. + +\begin{code} +geniTagElems :: Parser [TagElem] +geniTagElems = tillEof $ setTidnums `fmap` many geniTagElem + +geniTagElem :: Parser TagElem +geniTagElem = + do family <- identifier + tname <- option "" $ do { colon; identifier } + iface <- (snd `liftM` geniParams) <|> geniFeats + theType <- initType <|> auxType + theTree <- geniTree + sem <- do { keywordSemantics; squares geniSemantics } + -- + return $ emptyTE { idname = tname + , ttreename = family + , tinterface = iface + , ttype = theType + , ttree = theTree + , tsemantics = sem } +\end{code} + +\section{Polarities} + +The polarities parser is used for parsing extra polarity input from the +user. For more information, see chapter \ref{cha:Polarity}. + +\begin{code} +geniPolarities :: Parser (Map.Map String Interval) +geniPolarities = tillEof $ toMap `fmap` many pol + where + toMap = Map.fromListWith (!+!) + pol = do p <- geniPolarity + i <- identifier + return (i,ival p) +\end{code} + +\fnlabel{geniPolarity} associates a numerical value to a polarity symbol, + that is, '+' or '-'. + +\begin{code} +geniPolarity :: Parser Int +geniPolarity = option 0 (plus <|> minus) + where + plus = do { char '+'; return 1 } + minus = do { char '-'; return (-1) } +\end{code} + + +\section{Morphology} + +GenI has two types of morphological input. + +\paragraph{morphinfo} A morphinfo file associates predicates with +morphological feature structures. Each morphological entry consists of +a predicate followed by a feature structuer. For more information, see +chapter \ref{cha:Morphology}. + +\begin{code} +geniMorphInfo :: Parser [(String,Flist)] +geniMorphInfo = tillEof $ many morphEntry + +morphEntry :: Parser (String,Flist) +morphEntry = + do pred_ <- identifier + feats <- geniFeats + return (pred_, feats) +\end{code} + +\paragraph{morphlexicon} A morphological lexicon is a table where each +entry is an inflected form followed by the lemma and the feature +structure to which it is associated. The table is whitespace-delimited. + +\begin{code} +geniMorphLexicon :: Parser [MorphLexEntry] +geniMorphLexicon = tillEof $ many morphLexiconEntry + +morphLexiconEntry :: Parser (String, String, Flist) +morphLexiconEntry = + do inflected <- try stringLiteral <|> geniWord + whiteSpace + lemma <- try stringLiteral <|> geniWord + whiteSpace + feats <- geniFeats + return (inflected, lemma, feats) +\end{code} + +\section{Generic GenI stuff} + +\subsection{Lexer} + +Some preliminaries about GenI formats in general - comments start with +\verb!%! There is also the option of using \verb'/* */' for embedded +comments. + +\begin{code} +lexer :: TokenParser () +lexer = makeTokenParser geniLanguageDef + +geniLanguageDef :: LanguageDef () +geniLanguageDef = emptyDef + { commentLine = "%" + , commentStart = "/*" + , commentEnd = "*/" + , opLetter = oneOf "" + , reservedOpNames = [""] + , reservedNames = + [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE + , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR_NOADJ + , INITIAL , AUXILIARY + , BEGIN , END ] + , identLetter = identStuff + , identStart = identStuff + } + where identStuff = alphaNum <|> oneOf "_'+-." + +whiteSpace :: CharParser () () +whiteSpace = P.whiteSpace lexer + +looseIdentifier, identifier, stringLiteral, colon :: CharParser () String +identifier = P.identifier lexer + +-- stolen from Parsec code (ident) +-- | Like 'identifier' but allows for reserved words too +looseIdentifier = + do { i <- ident ; whiteSpace; return i } + where + ident = + do { c <- identStart geniLanguageDef + ; cs <- many (identLetter geniLanguageDef) + ; return (c:cs) } "identifier" + +stringLiteral = P.stringLiteral lexer +colon = P.colon lexer + +squares, braces, parens :: CharParser () a -> CharParser () a +squares = P.squares lexer +braces = P.braces lexer +parens = P.parens lexer + +reserved, symbol :: String -> CharParser () String +reserved s = P.reserved lexer s >> return s +symbol = P.symbol lexer +\end{code} + +\subsection{Keyword} + +A key is nothing simpler than the keyword, followed by a colon. +We factor this into a seperate function to account for whitespace. + +\begin{code} +{-# INLINE keyword #-} +keyword :: String -> Parser String +keyword k = + do let helper = try $ do { reserved k; colon; return k } + helper k ++ ":" + +{-# INLINE keywordSemantics #-} +keywordSemantics :: Parser String +keywordSemantics = keyword SEMANTICS +\end{code} + +\subsection{Feature structures} + +Feature structures take the form \verb!val : att! with only +whitespace to separate each attval pair. See \fnref{geniValue} for +details about what the values look like. + +\begin{code} +geniFeats :: Parser Flist +geniFeats = option [] $ squares $ many geniAttVal + +geniAttVal :: Parser AvPair +geniAttVal = do + att <- identifier "an attribute"; colon + val <- geniValue "a GenI value" + return (att, val) +\end{code} + +\fnlabel{geniParams} recognises a list of parameters optionally followed by a +bang (\verb$!$) and a list of attribute-value pairs. This whole thing is to +wrapped in the parens. + +\textbf{Note:} sometimes people prefer not to use parameters - instead they +stick to using the interface. This is fine, but they should not forget the +bang seperator. + +\begin{code} +geniParams :: Parser ([GeniVal], Flist) +geniParams = parens $ do + pars <- many geniValue "some parameters" + interface <- option [] $ do { symbol "!"; many geniAttVal } + return (pars, interface) +\end{code} + +\subsection{Semantics} + +A semantics is simply a list of literals. A literal can take one of two +forms: +\begin{verbatim} + handle:predicate(arguments) + predicate(arguments) +\end{verbatim} + +The arguments are space-delimited. Not providing a handle is +equivalent to providing an anonymous one. + +\begin{code} +geniSemantics :: Parser Sem +geniSemantics = + do sem <- many (geniLiteral "a literal") + return (sortSem sem) + +geniLiteral :: Parser Pred +geniLiteral = + do handle <- option GAnon handleParser "a handle" + predicate <- geniValue "a predicate" + pars <- parens (many geniValue) "some parameters" + -- + return (handle, predicate, pars) + where handleParser = + try $ do { h <- geniValue ; char ':' ; return h } +\end{code} + +\subsection{Lexical semantics} + +A lexical semantics is almost exactly the same as a regular semantics, +except that each variable may be preceded by a polarity symbol. When +we figure out how to automate the detection of lexical semantic +polarities, we can start using a regular semantics again. + +\begin{code} +geniLexSemantics :: Parser (Sem, [[Int]]) +geniLexSemantics = + do litpols <- many (geniLexLiteral "a literal") + return $ unzip litpols + +geniLexLiteral :: Parser (Pred, [Int]) +geniLexLiteral = + do (handle, hpol) <- option (GAnon,0) (handleParser "a handle") + predicate <- geniValue "a predicate" + paramsPols <- parens (many geniPolValue) "some parameters" + -- + let (pars, pols) = unzip paramsPols + literal = (handle, predicate, pars) + return (literal, hpol:pols) + where handleParser = + try $ do { h <- geniPolValue; colon; return h } + +geniPolValue :: Parser (GeniVal, Int) +geniPolValue = + do p <- geniPolarity + v <- geniValue + return (v,p) +\end{code} + + +\subsection{Miscellaneous} + +\fnlabel{geniValue} is recognised both in feature structures and in the +GenI semantics. + +\begin{enumerate} +\item As of geni 0.8, variables are prefixed with a question + mark. +\item The underscore, \verb!_!, and \verb!?_! are treated as anonymous + variables. +\item Atomic disjunctions are seperated with a pipe, \verb!|!. Only + constants may be separated by atomic disjunction +\item Anything else is just a constant +\end{enumerate} + +\begin{code} +geniValue :: Parser GeniVal +geniValue = ((try $ anonymous) "_ or ?_") + <|> (constants "a constant or atomic disjunction") + <|> (variable "a variable") + where + question = "?" + -- + constants :: Parser GeniVal + constants = + do c <- sepBy1 (looseIdentifier <|> stringLiteral) (symbol "|") + return (GConst c) + variable :: Parser GeniVal + variable = + do symbol question + v <- identifier + return (GVar v) + anonymous :: Parser GeniVal + anonymous = + do optional $ symbol question + symbol "_" + return GAnon +\end{code} + +\begin{code} +tillEof :: Parser a -> Parser a +tillEof p = + do whiteSpace + r <- p + eof + return r +\end{code} + + diff --git a/src/NLP/GenI/GeniShow.lhs b/src/NLP/GenI/GeniShow.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GeniShow.lhs @@ -0,0 +1,185 @@ +% 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 (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 new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Graphviz.hs @@ -0,0 +1,212 @@ +{-# OPTIONS -fglasgow-exts #-} + +{- + 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. +-} + +{- | Graphviz is an open source tool which converts an abstract + representation of a graph (node foo is connected to node bar, etc.) + into a nicely laid out graphic. This module contains methods + to invoke graphviz and to convert graphs and trees to its input format. + + You can download this (open source) tool at + +-} + +module NLP.GenI.Graphviz +where + +import Control.Monad(when) +import Data.List(intersperse) +import Data.Tree +import System.IO(hPutStrLn, hClose) +import System.Exit(ExitCode) + +import NLP.GenI.SysGeni(waitForProcess, runInteractiveProcess) + +{- | + Data structures which can be visualised with GraphViz should + implement this class. Note the first argument to graphvizShowGraph is + so that you can parameterise your show function (i.e. pass in + flags to change the way you show particular object). Note + that by default, all graphs are treated as directed graphs. You + can hide this by turning off edge arrows. +-} +class GraphvizShow flag b where + graphvizShowGraph :: flag -> b -> String + graphvizShowAsSubgraph :: flag -- ^ flag + -> String -- ^ prefix + -> b -- ^ item + -> String -- ^ gv output + graphvizLabel :: flag -- ^ flag + -> b -- ^ item + -> String -- ^ gv output + graphvizParams :: flag -> b -> [String] + + graphvizShowGraph f b = + let l = graphvizLabel f b + in "digraph {\n" + ++ (unlines $ graphvizParams f b) + ++ graphvizShowAsSubgraph f "_" b ++ "\n" + ++ (if null l then "" else " label = \"" ++ l ++ "\";\n") + ++ "}" + graphvizLabel _ _ = "" + graphvizParams _ _ = [] + +class GraphvizShowNode flag b where + graphvizShowNode :: flag -- ^ flag + -> String -- ^ prefix + -> b -- ^ item + -> String -- ^ gv output + +-- | Things which are meant to be displayed within some other graph +-- as (part) of a node label +class GraphvizShowString flag b where + graphvizShow :: flag -- ^ flag + -> b -- ^ item + -> String -- ^ gv output + +-- | Note: the 'dotFile' argument allows you to save the intermediary +-- dot output to a file. You can pass in the empty string if you don't +toGraphviz :: (GraphvizShow f a) => f + -> a + -> String -- ^ the 'dotFile' + -> String -> IO ExitCode +toGraphviz p x dotFile outputFile = do + graphviz (graphvizShowGraph p x) dotFile outputFile + +-- --------------------------------------------------------------------- +-- useful utility functions +-- --------------------------------------------------------------------- + +gvNewline :: String +gvNewline = "\\n" + +gvUnlines :: [String] -> String +gvUnlines = concat . (intersperse gvNewline) + +gvSubgraph :: String -> String +gvSubgraph g = "subgraph {\n" ++ g ++ "}\n" + +-- | The Graphviz string for a node. Note that we make absolutely no +-- effort to escape any characters for you; so if you need to protect +-- anything from graphviz, you're on your own +gvNode :: String -- ^ the node name + -> String -- ^ the label (may be empty) + -> [(String,String)] -- ^ any other parameters + -> String +gvNode name label params = + " " ++ name ++ " " ++ (gvLabelAndParams label params) ++ "\n" + +-- | The Graphviz string for a connection between two nodes. +-- Same disclaimer as 'gvNode' applies. +gvEdge :: String -- ^ the 'from' node + -> String -- ^ the 'to' node + -> String -- ^ the label (may be empty) + -> [(String,String)] -- ^ any other parameters + -> String +gvEdge from to label params = + " " ++ from ++ " -> " ++ to ++ (gvLabelAndParams label params) ++ "\n" + +gvLabelAndParams :: String -> [(String,String)] -> String +gvLabelAndParams l p = + gvParams $ if null l then p else ("label", l) : p + +gvParams :: [(String,String)] -> String +gvParams [] = "" +gvParams p = "[ " ++ (concat $ intersperse ", " $ map showPair p) ++ " ]" + where showPair (a,v) = a ++ "=\"" ++ v ++ "\"" + +-- --------------------------------------------------------------------- +-- some instances +-- --------------------------------------------------------------------- + +instance (GraphvizShow f b) => GraphvizShow f (Maybe b) where + graphvizShowAsSubgraph _ _ Nothing = "" + graphvizShowAsSubgraph f p (Just b) = graphvizShowAsSubgraph f p b + + graphvizLabel _ Nothing = "" + graphvizLabel f (Just b) = graphvizLabel f b + + graphvizParams _ Nothing = [] + graphvizParams f (Just b) = graphvizParams f b + +-- | Displays a tree in graphviz format. +{- Note that we could make this an + instance of GraphvizShow, but I'm not too sure about the wisdom of + such a move. + + Maybe if we had some really super-sophisticated types in Haskell, where + we can define this as the default instance which could be overrided by + something more specific, that would be cool. + + The prefix argument is interpreted as the name of the top node. Node + names below are basically Gorn addresses (e.g. n0x2x3 means 3rd child of + the 2nd child of the root) to keep them distinct. Note : We use the + letter `x' as seperator because graphviz will choke on `.' or `-', even + underscore. -} +gvShowTree :: (GraphvizShowNode f n) => + (n->[(String,String)]) -- ^ function to convert a node to a list of graphviz parameters for the edge + -> f -- ^ GraphvizShow flag + -> String -- ^ node prefix + -> (Tree n) -- ^ the tree + -> String +gvShowTree edgeFn f prefix t = + "edge [ arrowhead = none ]\n" ++ gvShowTreeHelper edgeFn f prefix t + +gvShowTreeHelper :: forall n . forall f . (GraphvizShowNode f n) => (n->[(String,String)]) -> f -> String -> (Tree n) -> String +gvShowTreeHelper edgeFn f prefix (Node node l) = + let showNode = graphvizShowNode f prefix + showKid :: Integer -> Tree n -> String + showKid index kid = + gvShowTreeHelper edgeFn f kidname kid ++ " " + ++ (gvEdge prefix kidname "" (edgeFn node)) + where kidname = prefix ++ "x" ++ (show index) + in showNode node ++ "\n" ++ (concat $ zipWith showKid [0..] l) + +-- --------------------------------------------------------------------- +-- invocation +-- --------------------------------------------------------------------- + +-- | Calls graphviz. If the second argument is the empty string, then we +-- just send stuff directly to dot's stdin + +graphviz :: String -- ^ graphviz's dot format. + -> String -- ^ the name of the file graphviz should write the dot + -> String -- ^ the name of the file graphviz should write its output + -> IO ExitCode + +-- We write the dot String to a temporary file which we then feed to graphviz. +-- This is avoid complications with fork and pipes. We use png output even +-- though it's uglier, because we don't have a wxhaskell widget that can +-- display postscript... do we? + +graphviz dot dotFile outputFile = do + let dotArgs' = ["-Gfontname=courier", + "-Nfontname=courier", + "-Efontname=courier", + "-Gcharset=latin1", -- FIXME: should really output UTF-8 instead + "-Tpng", "-o" ++ outputFile ] + dotArgs = dotArgs' ++ (if (null dotFile) then [] else [dotFile]) + -- putStrLn ("sending to graphviz:\n" ++ dot) + when (not $ null dotFile) $ writeFile dotFile dot + (_, toGV, _, pid) <- runInteractiveProcess "dot" dotArgs Nothing Nothing + when (null dotFile) $ do + hPutStrLn toGV dot + hClose toGV + waitForProcess pid diff --git a/src/NLP/GenI/GraphvizShow.lhs b/src/NLP/GenI/GraphvizShow.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GraphvizShow.lhs @@ -0,0 +1,222 @@ +% 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 NLP.GenI.Tags + ( TagElem, TagDerivation, idname, + tsemantics, ttree, + ) +import NLP.GenI.Btypes (GeniVal(GConst), AvPair, + GNode(..), GType(..), Flist, + isConst, + showSem, + ) +import NLP.GenI.General (wordsBy) +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 () (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 = + case [ av | av <- getFeat gn, fst av == attr ] of + [] -> Nothing + (av:_) -> Just (snd av) + +-- | 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 (\ (_,c,(p,_)) -> [c,p]) deriv +\end{code} + +\begin{code} +graphvizShowDerivation' :: (Char, String, (String, String)) -> String +graphvizShowDerivation' (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/GraphvizShowPolarity.lhs b/src/NLP/GenI/GraphvizShowPolarity.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GraphvizShowPolarity.lhs @@ -0,0 +1,130 @@ +% 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. + +\begin{code} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.GenI.GraphvizShowPolarity +where + +import Data.List (intersperse) +import qualified Data.Map as Map + +import NLP.GenI.Btypes(showSem) +import NLP.GenI.General(showInterval, isEmptyIntersect) +import NLP.GenI.Polarity(PolAut, PolState(PolSt), NFA(states, transitions), finalSt) +import NLP.GenI.Graphviz(GraphvizShow(..), gvUnlines, gvNewline, gvNode, gvEdge) +import NLP.GenI.Tags(idname) +\end{code} + +\begin{code} +instance GraphvizShow () PolAut where + -- we want a directed graph (arrows) + graphvizShowGraph f aut = + "digraph aut {\n" + ++ "rankdir=LR\n" + ++ "ranksep = 0.02\n" + ++ "pack=1\n" + ++ "edge [ fontsize=10 ]\n" + ++ "node [ fontsize=10 ]\n" + ++ graphvizShowAsSubgraph f "aut" aut + ++ "}" + + -- + graphvizShowAsSubgraph _ prefix aut = + let st = (concat.states) aut + ids = map (\x -> prefix ++ show x) ([0..] :: [Int]) + -- map which permits us to assign an id to a state + stmap = Map.fromList $ zip st ids + in -- + gvShowFinal aut stmap + -- any other state should be an ellipse + ++ "node [ shape = ellipse, peripheries = 1 ]\n" + -- draw the states and transitions + ++ (concat $ zipWith gvShowState ids st) + ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) +\end{code} + +\begin{code} +gvShowState :: String -> PolState -> String +gvShowState stId st = + -- note that we pass the label param explicitly to allow for null label + gvNode stId "" [ ("label", showSt st) ] + where showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po + showPr _ = "" -- (_,pr,_) = pr ++ gvNewline + showPo po = concat $ intersperse "," $ map showInterval po + showEx ex = if null ex then "" else showSem ex ++ gvNewline +\end{code} + +Specify that the final states are drawn with a double circle + +\begin{code} +gvShowFinal :: PolAut -> Map.Map PolState String -> String +gvShowFinal aut stmap = + if isEmptyIntersect (concat $ states aut) fin + then "" + else "node [ peripheries = 2 ]; " + ++ concatMap (\x -> " " ++ lookupId x) fin + ++ "\n" + where fin = finalSt aut + lookupId x = Map.findWithDefault "error_final" x stmap +\end{code} + +Each transition is displayed with the name of the tree. If there is more +than one transition to the same state, they are displayed on a single +label. + +\begin{code} +gvShowTrans :: PolAut -> Map.Map PolState String + -> String -> PolState -> String +gvShowTrans aut stmap idFrom st = + let -- outgoing transition labels from st + trans = Map.findWithDefault Map.empty st $ transitions aut + -- returns the graphviz dot command to draw a labeled transition + drawTrans (stTo,x) = case Map.lookup stTo stmap of + Nothing -> drawTrans' ("id_error_" ++ (sem_ stTo)) x + Just idTo -> drawTrans' idTo x + where sem_ (PolSt i _ _) = show i + --showSem (PolSt (_,pred,_) _ _) = pred + drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] + drawLabel labels = gvUnlines labs + where + lablen = length labels + maxlabs = 6 + excess = "...and " ++ (show $ lablen - maxlabs) ++ " more" + -- + labstrs = map fn labels + fn Nothing = "EMPTY" + fn (Just x) = idname x + -- + labs = if lablen > maxlabs + then take maxlabs labstrs ++ [ excess ] + else labstrs + in unlines $ map drawTrans $ Map.toList trans +\end{code} + +%gvShowTransPred te = +% let p = tpredictors te +% charge fv = case () of _ | c == -1 -> "-" +% | c == 1 -> "+" +% | c > 0 -> "+" ++ (show c) +% | otherwise -> (show c) +% where c = lookupWithDefaultFM p 0 fv +% showfv (f,v) = charge (f,v) ++ f +% ++ (if (null v) then "" else ":" ++ v) +% in map showfv $ Map.keys p + diff --git a/src/NLP/GenI/Gui.lhs b/src/NLP/GenI/Gui.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Gui.lhs @@ -0,0 +1,756 @@ +% 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. + +\chapter{Graphical User Interface} + +\begin{code} +{-# LANGUAGE FlexibleContexts #-} +module NLP.GenI.Gui(guiGeni) where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX + +import qualified Control.Monad as Monad +import qualified Data.Map as Map + +import Data.IORef +import Data.List (isPrefixOf, nub, delete, (\\), find) +import Data.Maybe (isJust) +import System.Directory +import System.Exit (exitWith, ExitCode(ExitSuccess)) + +import qualified NLP.GenI.Builder as B +import qualified NLP.GenI.BuilderGui as BG +import NLP.GenI.Geni + ( ProgState(..), ProgStateRef, combine, initGeni + , loadEverything, loadTestSuite, loadTargetSemStr) +import NLP.GenI.General (boundsCheck, geniBug, trim, fst3) +import NLP.GenI.Btypes (ILexEntry(isemantics), TestCase(..), showFlist,) +import NLP.GenI.Tags (idname, tpolarities, tsemantics, TagElem) +import NLP.GenI.GeniShow (geniShow) +import NLP.GenI.Configuration + ( Params(..), Instruction, hasOpt + , hasFlagP, deleteFlagP, setFlagP, getFlagP, getListFlagP + , parseFlagWithParsec + -- + , ExtraPolaritiesFlg(..) + , IgnoreSemanticsFlg(..) + , LexiconFlg(..) + , MacrosFlg(..) + , MaxTreesFlg(..) + , MorphCmdFlg(..) + , MorphInfoFlg(..) + , OptimisationsFlg(..) + , RootFeatureFlg(..) + , TestSuiteFlg(..) + , TestCaseFlg(..) + , TestInstructionsFlg(..) + , ViewCmdFlg(..) + -- + , Optimisation(..) + , BuilderType(..), mainBuilderTypes ) +import NLP.GenI.GeniParsers +import NLP.GenI.GuiHelper + +import NLP.GenI.Polarity +import NLP.GenI.Simple.SimpleGui +import NLP.GenI.CkyEarley.CkyGui + + +\end{code} +} + +\section{Main Gui} + +\begin{code} +guiGeni :: ProgStateRef -> IO() +guiGeni pstRef = start $ mainGui pstRef +\end{code} + +When you first start GenI, you will see this screen: +[[FIXME:screenshot wanted]] + +It allows you to type in an input semantics (or to modify the one that was +automatically loaded up), twiddle some optimisations and run the realiser. You +can also opt to run the debugger instead of the realiser; see page +\pageref{sec:gui:debugger}. + +\begin{code} +mainGui :: ProgStateRef -> IO () +mainGui pstRef + = do -- + pst <- readIORef pstRef + -- Top Window + f <- frame [text := "Geni Project"] + -- create statusbar field + status <- statusField [] + -- create the file menu + fileMen <- menuPane [text := "&File"] + loadMenIt <- menuItem fileMen [text := "&Open files or configure GenI"] + quitMenIt <- menuQuit fileMen [text := "&Quit"] + set quitMenIt [on command := close f ] + -- create the tools menu + toolsMen <- menuPane [text := "&Tools"] + gbrowserMenIt <- menuItem toolsMen [ text := "&Inspect grammar" + , help := "Displays the trees in the grammar" ] + -- create the help menu + helpMen <- menuPane [text := "&Help"] + aboutMeIt <- menuAbout helpMen [help := "About"] + -- Tie the menu to this window + set f [ statusBar := [status] + , menuBar := [fileMen, toolsMen, helpMen] + -- put the menu event handler for an about box on the frame. + , on (menu aboutMeIt) := infoDialog f "About GenI" "The GenI generator.\nhttp://wiki.loria.fr/wiki/GenI" + -- event handler for the tree browser + , on (menu gbrowserMenIt) := do { loadEverything pstRef; treeBrowserGui pstRef } + ] + -- ----------------------------------------------------------------- + -- buttons + -- ----------------------------------------------------------------- + let config = pa pst + hasSem = hasFlagP TestSuiteFlg config + ignoreSem = hasFlagP IgnoreSemanticsFlg config + -- Target Semantics + testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ] + tsTextBox <- textCtrl f [ wrap := WrapWord + , clientSize := sz 400 80 + , enabled := hasSem + , text := if ignoreSem + then "% --ignoresemantics set" else "" ] + testCaseChoice <- choice f [ selection := 0 + , enabled := hasSem ] + -- Box and Frame for files loaded + macrosFileLabel <- staticText f [ text := getListFlagP MacrosFlg config ] + lexiconFileLabel <- staticText f [ text := getListFlagP LexiconFlg config ] + -- Generate and Debug + let genfn = doGenerate f pstRef tsTextBox + pauseOnLexChk <- checkBox f [ text := "Inspect lex", tooltip := "Affects debugger only" ] + debugBt <- button f [ text := "Debug" + , on command := get pauseOnLexChk checked >>= genfn True ] + genBt <- button f [text := "Generate", on command := genfn False False ] + quitBt <- button f [ text := "Quit", + on command := close f] + -- ----------------------------------------------------------------- + -- optimisations + -- ----------------------------------------------------------------- + algoChoiceBox <- radioBox f Vertical (map show mainBuilderTypes) + [ selection := case builderType config of + SimpleBuilder -> 0 + SimpleOnePhaseBuilder -> 1 + CkyBuilder -> 2 + EarleyBuilder -> 3 + NullBuilder -> 0 ] + set algoChoiceBox [ on select := toggleAlgo pstRef algoChoiceBox ] + polChk <- optCheckBox Polarised pstRef f + [ text := "Polarities" + , tooltip := "Use the polarity optimisation" + ] + useSemConstraintsChk <- antiOptCheckBox NoConstraints pstRef f + [ text := "Sem constraints" + , tooltip := "Use any sem constraints the user provides" + ] + iafChk <- optCheckBox Iaf pstRef f + [ text := "Idx acc filter" + , tooltip := "Only available in CKY/Earley for now" + ] + semfilterChk <- optCheckBox SemFiltered pstRef f + [ text := "Semantic filters" + , tooltip := "(2p only) Filter away semantically incomplete structures before adjunction phase" + ] + rootfilterChk <- optCheckBox RootCatFiltered pstRef f + [ text := "Root filters" + , tooltip := "(2p only) Filter away non-root structures before adjunction phase" + ] + extrapolText <- staticText f + [ text := maybe "" showLitePm $ getFlagP ExtraPolaritiesFlg config + , tooltip := "Use the following additional polarities" + ] + -- commands for the checkboxes + let togglePolStuff = do c <- get polChk checked + set extrapolText [ enabled := c ] + set polChk [on command :~ (>> togglePolStuff) ] + -- ----------------------------------------------------------------- + -- layout; packing it all together + -- ----------------------------------------------------------------- + -- set any last minute handlers, run any last minute functions + let onLoad = readConfig f pstRef macrosFileLabel lexiconFileLabel testSuiteChoice tsTextBox testCaseChoice + set loadMenIt [ on command := do configGui pstRef onLoad ] + onLoad + togglePolStuff + -- + let labeledRow l w = row 1 [ label l, hfill (widget w) ] + let gramsemBox = boxed "Files last loaded" $ + hfill $ column 1 + [ labeledRow "trees:" macrosFileLabel + , labeledRow "lexicon:" lexiconFileLabel + ] + optimBox = --boxed "Optimisations " $ -- can't used boxed with wxwidgets 2.6 -- bug? + column 5 [ label "Algorithm" + , dynamic $ widget algoChoiceBox + , label "Optimisations" + , dynamic $ widget polChk + , row 5 [ label " ", column 5 + [ dynamic $ row 5 [ label "Extra: ", widget extrapolText ] ] ] + , dynamic $ widget useSemConstraintsChk + , dynamic $ widget semfilterChk + , dynamic $ widget rootfilterChk + , dynamic $ widget iafChk + ] + set f [layout := column 5 [ gramsemBox + , row 5 [ fill $ -- boxed "Input Semantics" $ + hfill $ column 5 + [ labeledRow "test suite: " testSuiteChoice + , labeledRow "test case: " testCaseChoice + , fill $ widget tsTextBox ] + , vfill optimBox ] + -- ----------------------------- Generate and quit + , row 1 [ widget quitBt + , hfloatRight $ row 5 [ widget pauseOnLexChk, widget debugBt, widget genBt ]] ] + , clientSize := sz 525 325 + , on closing := exitWith ExitSuccess + ] +\end{code} + +\subsection{Configuration} + +Most of the optimisations are availalable as checkboxes. Note the following +point about anti-optimisations: An anti-optimisation disables a default +behaviour which is assumed to be ``optimisation''. But of course we don't +want to confuse the GUI user, so we confuse the programmer instead: +Given an anti-optimisation DisableFoo, we have a check box UseFoo. If UseFoo +is checked, we remove DisableFoo from the list; if it is unchecked, we add +it to the list. This is the opposite of the default behaviour, but the +result, I hope, is intuitive for the user. + +\begin{code} +toggleAlgo :: (Selection a, Items a String) => ProgStateRef -> a -> IO () +toggleAlgo pstRef box = + do asel <- get box selection + aitems <- get box items + let selected = aitems !! asel + btable = zip (map show mainBuilderTypes) mainBuilderTypes + btype = case [ b | (name, b) <- btable, name == selected ] of + [] -> geniBug $ "Unknown builder type " ++ selected + [b] -> b + _ -> geniBug $ "More than one builder has the name " ++ selected + modifyIORef pstRef (\x -> x { pa = (pa x) { builderType = btype } }) + +optCheckBox, antiOptCheckBox :: + Optimisation -> ProgStateRef + -> Window a -> [Prop (CheckBox ())] + -> IO (CheckBox ()) + +-- | Checkbox for enabling or disabling an optimisation +-- You need not set the checked or on command attributes +-- as this is done for you (but you can if you want, +-- setting checked will override the default, and any +-- command you set will be run before the toggle stuff) +optCheckBox = optCheckBoxHelper id + +-- | Same as 'optCheckBox' but for anti-optimisations +antiOptCheckBox = optCheckBoxHelper not + +optCheckBoxHelper :: (Bool -> Bool) -> Optimisation -> ProgStateRef + -> Window a -> [Prop (CheckBox ())] + -> IO (CheckBox ()) +optCheckBoxHelper idOrNot o pstRef f as = + do pst <- readIORef pstRef + chk <- checkBox f $ [ checked := idOrNot $ hasOpt o $ pa pst ] ++ as + set chk [ on command :~ (>> onCheck chk) ] + return chk + where + onCheck chk = + do isChecked <- get chk checked + pst <- readIORef pstRef + let config = pa pst + modopt = if idOrNot isChecked then (o:) else delete o + newopts = nub.modopt $ getListFlagP OptimisationsFlg config + modifyIORef pstRef (\x -> x{pa = setFlagP OptimisationsFlg newopts (pa x)}) +\end{code} + +% -------------------------------------------------------------------- +\section{Loading files} +% -------------------------------------------------------------------- + +\paragraph{readConfig} is used to update the graphical interface after +you run the \fnref{configGui}. It is also called when you first launch +the GUI + +\begin{code} +readConfig :: (Textual l, Textual t, Able ch, Items ch String, Selection ch, Selecting ch) + => Window w -> ProgStateRef -> l -> l -> ch -> t -> ch -> IO () +readConfig f pstRef macrosFileLabel lexiconFileLabel suiteChoice tsBox caseChoice = + do pst <- readIORef pstRef + let config = pa pst + -- errHandler title err = errorDialog f title (show err) + set macrosFileLabel [ text := getListFlagP MacrosFlg config ] + set lexiconFileLabel [ text := getListFlagP LexiconFlg config ] + -- set tsFileLabel [ text := getListFlagP TestSuiteFlg config ] + -- read the test suite if there is one + case getListFlagP TestInstructionsFlg config of + [] -> + do set suiteChoice [ enabled := False, items := [] ] + set caseChoice [ enabled := False, items := [] ] + is -> + do -- handler for selecting a test suite + let imap = Map.fromList $ zip [0..] is + onTestSuiteChoice = do + sel <- get suiteChoice selection + case Map.lookup sel imap of + Nothing -> geniBug $ "No such index in test suite selector (gui): " ++ show sel + Just t -> loadTestSuiteAndRefresh f pstRef t tsBox caseChoice + set suiteChoice [ enabled := True, items := map fst is + , on select := onTestSuiteChoice, selection := 0 ] + set caseChoice [ enabled := True ] + onTestSuiteChoice -- load the first suite + +-- | Load the given test suite and update the GUI accordingly. +-- This is used when you first start the graphical interface +-- or when you run the configuration menu. +loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String) + => Window w -> ProgStateRef -> Instruction -> a -> b -> IO () +loadTestSuiteAndRefresh f pstRef (suitePath,mcs) tsBox caseChoice = + do modifyIORef pstRef $ \pst -> + pst { pa = setFlagP TestSuiteFlg suitePath + $ deleteFlagP TestCaseFlg -- shouldn't change anything + $ pa pst } + catch + (loadTestSuite pstRef) + (\e -> errorDialog f ("Error reading test suite " ++ suitePath) (show e)) + pst <- readIORef pstRef + let suite = tsuite pst + theCase = tcase pst + filterCases = + case mcs of + Nothing -> id + Just cs -> filter (\c -> tcName c `elem` cs) + suiteCases = filterCases suite + suiteCaseNames = map tcName suiteCases + -- we number the cases for easy identification, putting + -- a star to highlight the selected test case (if available) + let numfn :: Int -> String -> String + numfn n t = (if t == theCase then "* " else "") + ++ (show n) ++ ". " ++ t + tcaseLabels = zipWith numfn [1..] suiteCaseNames + -- we select the first case in cases_, if available + let fstInCases _ [] = 0 + fstInCases n (x:xs) = + if (x == theCase) then n else fstInCases (n+1) xs + caseSel = if null theCase then 0 + else fstInCases 0 suiteCaseNames + ---------------------------------------------------- + -- handler for selecting a test case + ---------------------------------------------------- + let displaySemInput (TestCase { tcSem = si, tcSemString = str }) = + geniShow $ toSemInputString si str + let onTestCaseChoice = do + csel <- get caseChoice selection + if (boundsCheck csel suite) + then do let s = (suiteCases !! csel) + set tsBox [ text :~ (\_ -> displaySemInput s) ] + else geniBug $ "Gui: test case selector bounds check error: " ++ + show csel ++ " of " ++ show suite ++ "\n" + ---------------------------------------------------- + set caseChoice [ items := tcaseLabels + , selection := caseSel + , on select := onTestCaseChoice ] + when (not $ null suite) onTestCaseChoice -- run this once +\end{code} + +% -------------------------------------------------------------------- +\section{Configuration} +% -------------------------------------------------------------------- + +\paragraph{configGui}\label{fn:configGui} provides a graphical interface which +aims to be a complete substitute for the command line switches. In addition to +the program state \fnparam{pstRef}, it takes a continuation \fnparam{loadFn} +which tells what to do when the user closes the window. + +The only thing which are not provided in this GUI are a list of optimisations +and a test case selector (which are already handled by the main interface). +This GUI is a standalone window with two tabbed sections. Note: one thing +you may want to note is that we do not divide the same way between basic +and advanced options as with the console interface. + +\begin{code} +configGui :: ProgStateRef -> IO () -> IO () +configGui pstRef loadFn = do + pst <- readIORef pstRef + let config = pa pst + -- + f <- frame [] + p <- panel f [] + nb <- notebook p [] + let browseTxt = "Browse" + -- + let fakeBoxed title lst = hstretch $ column 3 $ map hfill $ + [ hrule 1 , alignRight $ label title, vspace 5 ] + ++ map hfill lst + let shortSize = sz 10 25 + let longSize = sz 20 25 +\end{code} + +The first tab contains only the basic options: + +\begin{code} + pbas <- panel nb [] + -- files loaded (labels) + macrosFileLabel <- staticText pbas [ text := getListFlagP MacrosFlg config ] + lexiconFileLabel <- staticText pbas [ text := getListFlagP LexiconFlg config ] + tsFileLabel <- staticText pbas [ text := getListFlagP TestSuiteFlg config ] + -- "Browse buttons" + macrosBrowseBt <- button pbas [ text := browseTxt ] + lexiconBrowseBt <- button pbas [ text := browseTxt ] + tsBrowseBt <- button pbas [ text := browseTxt ] + -- root feature + rootFeatTxt <- entry pbas + [ text := showFlist $ getListFlagP RootFeatureFlg config + , size := longSize ] + let layFiles = [ row 1 [ label "trees:" + , fill $ widget macrosFileLabel + , widget macrosBrowseBt ] + , row 1 [ label "lexicon:" + , fill $ widget lexiconFileLabel + , widget lexiconBrowseBt ] + , row 1 [ label "test suite:" + , fill $ widget tsFileLabel + , widget tsBrowseBt ] + , hspace 5 + , hfill $ vrule 1 + , row 3 [ label "root features" + , hglue + , rigid $ widget rootFeatTxt ] + ] + -- the layout for the basic stuff + let layBasic = dynamic $ container pbas $ -- boxed "Basic options" $ + hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) $ layFiles +\end{code} + +The second tab contains more advanced options. Maybe we should split this +into more tabs? + +\begin{code} + padv <- panel nb [] + -- XMG tools + viewCmdTxt <- entry padv + [ tooltip := "Command used for XMG tree viewing" + , text := getListFlagP ViewCmdFlg config ] + let layXMG = fakeBoxed "XMG tools" + [ row 3 [ label "XMG view command" + , marginRight $ hfill $ widget viewCmdTxt ] ] + -- polarities + extraPolsTxt <- entry padv + [ text := maybe "" showLitePm $ getFlagP ExtraPolaritiesFlg config + , size := shortSize ] + let layPolarities = fakeBoxed "Polarities" [ hfill $ row 1 + [ label "extra polarities", rigid $ widget extraPolsTxt ] ] + -- morphology + morphFileLabel <- staticText padv [ text := getListFlagP MorphInfoFlg config ] + morphFileBrowseBt <- button padv [ text := browseTxt ] + morphCmdTxt <- entry padv + [ tooltip := "Commmand used for morphological generation" + , text := getListFlagP MorphCmdFlg config ] + let layMorph = fakeBoxed "Morphology" + [ row 3 [ label "morph info:" + , expand $ hfill $ widget morphFileLabel + , widget morphFileBrowseBt ] + , row 3 [ label "morph command" + , (marginRight.hfill) $ widget morphCmdTxt ] ] + -- ignore semantics + ignoreSemChk <- checkBox padv + [ text := "Ignore semantics" + , tooltip := "Useful as a corpus generator" + , checked := hasFlagP IgnoreSemanticsFlg config ] + let maxTreesStr = maybe "" show $ getFlagP MaxTreesFlg config + maxTreesText <- entry padv + [ text := maxTreesStr + , tooltip := "Limit number of elementary trees in a derived tree" + , size := shortSize ] + let layIgnoreSem = fakeBoxed "Ignore Semantics Mode" + [ row 3 [ widget ignoreSemChk + , hspace 5 + , label "max trees", rigid $ widget maxTreesText ] ] + -- put the whole darn thing together + let layAdvanced = hfloatLeft $ container padv $ column 10 + $ [ layXMG, layPolarities, layMorph, layIgnoreSem ] +\end{code} + +When the user clicks on a Browse button, an open file dialogue should pop up. +It gets its value from the file label on its left (passed in as an argument), +and updates said label when the user has made a selection. + +\begin{code} + -- helper functions + curDir <- getCurrentDirectory + let curDir2 = curDir ++ "/" + trim2 pth = if curDir2 `isPrefixOf` pth2 + then drop (length curDir2) pth2 + else pth2 + where pth2 = trim pth + let onBrowse theLabel + = do rawFilename <- get theLabel text + let filename = trim2 rawFilename + filetypes = [("Any file",["*","*.*"])] + fsel <- fileOpenDialog f False True + "Choose your file..." filetypes "" filename + case fsel of + -- if the user does not select any file there are no changes + Nothing -> return () + Just file -> set theLabel [ text := trim2 file ] + -- end onBrowse + -- activate those "Browse" buttons + let setBrowse w l = set w [ on command := onBrowse l ] + setBrowse macrosBrowseBt macrosFileLabel + setBrowse lexiconBrowseBt lexiconFileLabel + setBrowse tsBrowseBt tsFileLabel + setBrowse morphFileBrowseBt morphFileLabel +\end{code} + +Let's not forget the layout which puts the whole configGui together and the +command that makes everything ``work'': + +\begin{code} + let parsePol = parseFlagWithParsec "polarities" geniPolarities + parseRF = parseFlagWithParsec "root features" geniFeats + onLoad + = do macrosVal <- get macrosFileLabel text + lexconVal <- get lexiconFileLabel text + tsVal <- get tsFileLabel text + -- + rootCatVal <- get rootFeatTxt text + extraPolVal <- get extraPolsTxt text + -- + viewVal <- get viewCmdTxt text + -- + morphCmdVal <- get morphCmdTxt text + morphInfoVal <- get morphFileLabel text + -- + ignoreVal <- get ignoreSemChk checked + maxTreesVal <- get maxTreesText text + -- + let maybeSet fl fn x = + if null x then deleteFlagP fl else setFlagP fl (fn x) + maybeSetStr fl x = maybeSet fl id x + toggleFlag fl b = if b then setFlagP fl () else deleteFlagP fl + let setConfig = id + . (maybeSet MaxTreesFlg read maxTreesVal) + . (toggleFlag IgnoreSemanticsFlg ignoreVal) + . (maybeSetStr MacrosFlg macrosVal) + . (maybeSetStr LexiconFlg lexconVal) + . (maybeSetStr TestSuiteFlg tsVal) + . (maybeSet RootFeatureFlg parseRF rootCatVal) + . (maybeSet ExtraPolaritiesFlg parsePol extraPolVal) + . (maybeSetStr ViewCmdFlg viewVal) + . (maybeSetStr MorphCmdFlg morphCmdVal) + . (maybeSetStr MorphInfoFlg morphInfoVal) + modifyIORef pstRef $ \x -> x { pa = setConfig (pa x) } + loadFn + -- end onLoad + -- the button bar + cancelBt <- button p + [ text := "Cancel", on command := close f ] + loadBt <- button p + [ text := "Load", on command := do { onLoad; close f } ] + let layButtons = hfill $ row 1 + [ hfloatLeft $ widget cancelBt + , hfloatRight $ widget loadBt ] + -- + set f [ layout := dynamic $ fill $ container p $ column 0 + [ fill $ tabs nb [ tab "Basic" layBasic + , tab "Advanced" layAdvanced ] + , hfill $ layButtons ] + ] +\end{code} + +% -------------------------------------------------------------------- +\section{Running the generator} +% -------------------------------------------------------------------- + +\paragraph{doGenerate} parses the target semantics, then calls the +generator and displays the result in a results gui (below). + +\begin{code} +doGenerate :: Textual b => Window a -> ProgStateRef -> b -> Bool -> Bool -> IO () +doGenerate f pstRef sembox useDebugger pauseOnLex = + do loadEverything pstRef + sem <- get sembox text + loadTargetSemStr pstRef sem + -- + pst <- readIORef pstRef + let config = pa pst + withBuilderGui a = + case builderType config of + NullBuilder -> error "No gui available for NullBuilder" + SimpleBuilder -> a simpleGui_2p + SimpleOnePhaseBuilder -> a simpleGui_1p + CkyBuilder -> a ckyGui + EarleyBuilder -> a earleyGui + -- + let doDebugger bg = debugGui bg pstRef pauseOnLex + doResults bg = resultsGui bg pstRef + do catch (withBuilderGui $ if useDebugger then doDebugger else doResults) + (handler "Error during realisation") + -- FIXME: it would be nice to distinguish between generation and ts + -- parsing errors + `catch` (handler "Error parsing the input semantics") + where + handler title err = errorDialog f title (show err) +\end{code} + +\paragraph{resultsGui} displays generation result in a window. The window +consists of various tabs for intermediary results in lexical +selection, derived trees, derivation trees and generation statistics. + +\begin{code} +resultsGui :: BG.BuilderGui -> ProgStateRef -> IO () +resultsGui builderGui pstRef = + do -- results window + f <- frame [ text := "Results" + , fullRepaintOnResize := False + , layout := stretch $ label "Generating..." + , clientSize := sz 300 300 + ] + p <- panel f [] + nb <- notebook p [] + -- realisations tab + (results,stats,resTab) <- BG.resultsPnl builderGui pstRef nb + -- statistics tab + let sentences = (fst . unzip) results + statTab <- statsGui nb sentences stats + -- pack it all together + set f [ layout := container p $ column 0 [ tabs nb + -- we put the realisations tab last because of what + -- seems to be buggy behaviour wrt to wxhaskell + -- or wxWidgets 2.4 and the splitter + [ tab "summary" statTab + , tab "realisations" resTab ] ] + , clientSize := sz 700 600 ] + return () +\end{code} + +\paragraph{debuggerGui} All GenI builders can make use of an interactive +graphical debugger. We provide here a universal debugging interface, +which makes use of some parameterisable bits as defined in the BuilderGui +module. This window shows a seperate tab for each surface realisation +task (lexical selection, filtering, building). We also rely heavily on +helper code defined in \ref{sec:debugger_helpers}. + +\begin{code} +debugGui :: BG.BuilderGui -> ProgStateRef -> Bool -> IO () +debugGui builderGui pstRef pauseOnLex = + do pst <- readIORef pstRef + let config = pa pst + btype = show $ builderType config + -- + f <- frame [ text := "GenI Debugger - " ++ btype ++ " edition" + , fullRepaintOnResize := False + , clientSize := sz 300 300 ] + p <- panel f [] + nb <- notebook p [] + -- generation step 1 + initStuff <- initGeni pstRef + let (tsem,_,_) = B.inSemInput initStuff + (cand,_) = unzip $ B.inCands initStuff + lexonly = B.inLex initStuff + -- continuation for candidate selection tab + let step2 newCands = + do -- generation step 2.A (run polarity stuff) + let newInitStuff = initStuff { B.inCands = map (\x -> (x, -1)) newCands } + (input2, _, autstuff) = B.preInit newInitStuff config + -- automata tab + let (auts, _, finalaut, _) = autstuff + autPnl <- if hasOpt Polarised config + then fst3 `fmap` polarityGui nb auts finalaut + else messageGui nb "polarity filtering disabled" + -- generation step 2.B (start the generator for each path) + debugPnl <- BG.debuggerPnl builderGui nb config input2 btype + let autTab = tab "automata" autPnl + debugTab = tab (btype ++ "-session") debugPnl + genTabs = if hasOpt Polarised config + then [ autTab, debugTab ] else [ debugTab ] + -- + set f [ layout := container p $ tabs nb genTabs + , clientSize := sz 700 600 ] + return () + -- candidate selection tab + let missedSem = tsem \\ (nub $ concatMap tsemantics cand) + -- we assume that for a tree to correspond to a lexical item, + -- it must have the same semantics + hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand + where lsem = isemantics l + missedLex = [ l | l <- lexonly, (not.hasTree) l ] + (canPnl,_,_) <- if pauseOnLex + then pauseOnLexGui pst nb cand missedSem missedLex step2 + else candidateGui pst nb cand missedSem missedLex + -- basic tabs + let basicTabs = [ tab "lexical selection" canPnl ] + -- + set f [ layout := container p $ tabs nb basicTabs + , clientSize := sz 700 600 ] + -- display all tabs if we are not told to pause on lex selection + when (not pauseOnLex) (step2 cand) +\end{code} + + + +% -------------------------------------------------------------------- +\section{Tree browser} +\label{sec:treebrowser_gui} +% -------------------------------------------------------------------- + +This is a very simple semantically-separated browser for all the +trees in the grammar. Note that we can't just reuse candidateGui's +code because we label and sort the trees differently. Here we +ignore the arguments in tree semantics, and we display the tree +polarities in its label. + +\begin{code} +treeBrowserGui :: ProgStateRef -> IO () +treeBrowserGui pstRef = do + pst <- readIORef pstRef + -- ALL THE TREES in the grammar... muahahaha! + let semmap = combine (gr pst) (le pst) + -- browser window + f <- frame [ text := "Tree Browser" + , fullRepaintOnResize := False + ] + -- the heavy GUI artillery + let sem = Map.keys semmap + -- + lookupTr k = Map.findWithDefault [] k semmap + treesfor k = Nothing : (map Just $ lookupTr k) + labsfor k = ("___" ++ k ++ "___") : (map fn $ lookupTr k) + where fn t = idname t ++ polfn (tpolarities t) + polfn p = if Map.null p + then "" + else " (" ++ showLitePm p ++ ")" + -- + trees = concatMap treesfor sem + itNlabl = zip trees (concatMap labsfor sem) + (browser,_,_) <- tagViewerGui pst f "tree browser" "grambrowser" itNlabl + -- the button panel + let count = length trees - length sem + quitBt <- button f [ text := "Close", on command := close f ] + -- pack it all together + set f [ layout := column 5 [ browser, + row 5 [ label ("number of trees: " ++ show count) + , hfloatRight $ widget quitBt ] ] + , clientSize := sz 700 600 ] + return () +\end{code} diff --git a/src/NLP/GenI/GuiHelper.lhs b/src/NLP/GenI/GuiHelper.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GuiHelper.lhs @@ -0,0 +1,860 @@ +% 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. + +\chapter{GUI Helper} + +This module provides helper functions for building the GenI graphical +user interface + +\begin{code} +{-# LANGUAGE FlexibleContexts #-} +module NLP.GenI.GuiHelper where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX +-- import Graphics.UI.WXCore + +import qualified Control.Monad as Monad +import Control.Monad.State ( execStateT, runState ) +import qualified Data.Map as Map + +import Data.IORef +import Data.List (intersperse) +import System.Directory +import System.FilePath ((<.>),(),dropExtensions) +import System.Process (runProcess) +import Text.ParserCombinators.Parsec (parseFromFile) + +import NLP.GenI.Graphviz +import NLP.GenI.Automaton (numStates, numTransitions) +import NLP.GenI.Statistics (Statistics, showFinalStats) + +import NLP.GenI.Configuration ( getFlagP, MacrosFlg(..), ViewCmdFlg(..) ) +import NLP.GenI.GeniShow(geniShow) +import NLP.GenI.GraphvizShow () +import NLP.GenI.Tags (TagItem(tgIdName), tagLeaves) +import NLP.GenI.Geni + ( ProgState(..), showRealisations ) +import NLP.GenI.GeniParsers ( geniTagElems ) +import NLP.GenI.General + (geniBug, boundsCheck, dropTillIncluding, ePutStrLn) +import NLP.GenI.Btypes + ( showAv, showPred, showSem, showLexeme, Sem, ILexEntry(iword, ifamname), ) +import NLP.GenI.Tags + ( idname, mapBySem, TagElem(ttrace, tinterface) ) + +import NLP.GenI.Configuration + ( Params(..), MetricsFlg(..), setFlagP ) + +import qualified NLP.GenI.Builder as B +import NLP.GenI.Builder (queryCounter, num_iterations, chart_size, + num_comparisons) +import NLP.GenI.Polarity (PolAut, detectPolFeatures) +import NLP.GenI.GraphvizShowPolarity () +\end{code} +} + +\subsection{Lexically selected items} + +We have a browser for the lexically selected items. We group the lexically +selected items by the semantics they subsume, inserting along the way some +fake trees and labels for the semantics. + +The arguments \fnparam{missedSem} and \fnparam{missedLex} are used to +indicate to the user respectively if any bits of the input semantics +have not been accounted for, or if there have been lexically selected +items for which no tree has been found. + +\begin{code} +candidateGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry] + -> GvIO Bool (Maybe TagElem) +candidateGui pst f xs missedSem missedLex = do + p <- panel f [] + (tb,gvRef,updater) <- tagViewerGui pst p "lexically selected item" "candidates" + $ sectionsBySem xs + let warningSem = if null missedSem then "" + else "WARNING: no lexical selection for " ++ showSem missedSem + warningLex = if null missedLex then "" + else "WARNING: '" ++ (concat $ intersperse ", " $ map showLex missedLex) + ++ "' were lexically selected, but are not anchored to" + ++ " any trees" + where showLex l = (showLexeme $ iword l) ++ "-" ++ (ifamname l) + -- + polFeats = "Polarity attributes detected: " ++ (unwords.detectPolFeatures) xs + warning = unlines $ filter (not.null) [ warningSem, warningLex, polFeats ] + -- side panel + sidePnl <- panel p [] + ifaceLst <- singleListBox sidePnl [ tooltip := "interface for this tree (double-click me!)" ] + traceLst <- singleListBox sidePnl [ tooltip := "trace for this tree (double-click me!)" ] + tNoted <- textCtrl sidePnl [ wrap := WrapWord, text := "Hint: copy from below and paste into the sem:\n" ] + let laySide = container sidePnl $ column 2 + [ label "interface" + , fill $ widget ifaceLst + , label "trace" + , fill $ widget traceLst + , label "notes" + , fill $ widget tNoted ] + -- handlers + let addLine :: String -> String -> String + addLine x y = y ++ "\n" ++ x + -- + addToNoted w = + do sel <- get w selection + things <- get w items + when (sel > 0) $ set tNoted [ text :~ addLine (things !! sel) ] + set ifaceLst [ on doubleClick := \_ -> addToNoted ifaceLst ] + set traceLst [ on doubleClick := \_ -> addToNoted traceLst ] + -- updaters : what happens when the user selects an item + let updateTrace = gvOnSelect (return ()) + (\s -> set traceLst [ items := ttrace s ]) + updateIface = gvOnSelect (return ()) + (\s -> set ifaceLst [ items := map showAv $ tinterface s ]) + Monad.unless (null xs) $ do + addGvHandler gvRef updateTrace + addGvHandler gvRef updateIface + -- first time run + gvSt <- readIORef gvRef + updateIface gvSt + updateTrace gvSt + -- + let layMain = fill $ row 2 [ fill tb, vfill laySide ] + theItems = if null warning then [ layMain ] else [ hfill (label warning) , layMain ] + lay = fill $ container p $ column 5 theItems + return (lay, gvRef, updater) + +sectionsBySem :: (TagItem t) => [t] -> [ (Maybe t, String) ] +sectionsBySem tsem = + let semmap = mapBySem tsem + sem = Map.keys semmap + -- + lookupTr k = Map.findWithDefault [] k semmap + section k = (Nothing, header) : (map tlab $ lookupTr k) + where header = "___" ++ showPred k ++ "___" + tlab t = (Just t, tgIdName t) + in concatMap section sem +\end{code} + +\subsection{Polarity Automata} + +A browser to see the automata constructed during the polarity optimisation +step. + +\begin{code} +polarityGui :: (Window a) -> [(String,PolAut,PolAut)] -> PolAut + -> GvIO () PolAut +polarityGui f xs final = do + let stats a = " (" ++ (show $ numStates a) ++ "st " ++ (show $ numTransitions a) ++ "tr)" + aut2 (_ , a1, a2) = [ a1, a2 ] + autLabel (fv,a1,a2) = [ fv ++ stats a1, fv ++ " pruned" ++ stats a2] + autlist = (concatMap aut2 xs) ++ [ final ] + labels = (concatMap autLabel xs) ++ [ "final" ++ stats final ] + -- + gvRef <- newGvRef () labels "automata" + setGvDrawables gvRef autlist + graphvizGui f "polarity" gvRef +\end{code} + +\paragraph{statsGui} displays the generation statistics and provides a +handy button for saving results to a text file. + +\begin{code} +statsGui :: (Window a) -> [String] -> Statistics -> IO Layout +statsGui f sentences stats = + do let msg = showRealisations sentences + -- + p <- panel f [] + t <- textCtrl p [ text := msg, enabled := False ] + statsTxt <- staticText p [ text := showFinalStats stats ] + -- + saveBt <- button p [ text := "Save to file" + , on command := maybeSaveAsFile f msg ] + return $ fill $ container p $ column 1 $ + [ hfill $ label "Performance data" + , hfill $ widget statsTxt + , hfill $ label "Realisations" + , fill $ widget t + , hfloatRight $ widget saveBt ] +\end{code} + +\subsection{TAG trees} + +Our graphical interfaces have to display a great variety of items. To +keep things nicely factorised, we define some type classes to describe +the things that these items may have in common. + +\begin{code} +-- | Any data structure which has corresponds to a TAG tree and which +-- has some notion of derivation +class XMGDerivation a where + getSourceTrees :: a -> [String] + +instance XMGDerivation TagElem where + getSourceTrees te = [idname te] +\end{code} + +\fnlabel{toSentence} almost displays a TagElem as a sentence, but only +good enough for debugging needs. The problem is that each leaf may be +an atomic disjunction. Our solution is just to display each choice and +use some delimiter to seperate them. We also do not do any +morphological processing. + +\begin{code} +toSentence :: TagElem -> String +toSentence = unwords . map squishLeaf . tagLeaves + +squishLeaf :: (a,([String], b)) -> String +squishLeaf = showLexeme.fst.snd +\end{code} + +\subsection{TAG viewer} + +A TAG viewer is a graphvizGui that lets the user toggle the display +of TAG feature structures. + +\begin{code} +tagViewerGui :: (GraphvizShow Bool t, TagItem t, XMGDerivation t) + => ProgState -> (Window a) -> String -> String -> [(Maybe t,String)] + -> GvIO Bool (Maybe t) +tagViewerGui pst f tip cachedir itNlab = do + p <- panel f [] + let (tagelems,labels) = unzip itNlab + gvRef <- newGvRef False labels tip + setGvDrawables gvRef tagelems + (lay,ref,updaterFn) <- graphvizGui p cachedir gvRef + -- button bar widgets + detailsChk <- checkBox p [ text := "Show features" + , checked := False ] + viewTagLay <- viewTagWidgets p gvRef (pa pst) + -- handlers + let onDetailsChk = + do isDetailed <- get detailsChk checked + setGvParams gvRef isDetailed + updaterFn + set detailsChk [ on command := onDetailsChk ] + -- pack it all in + let cmdBar = hfill $ row 5 + [ dynamic $ widget detailsChk + , viewTagLay ] + lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ] + return (lay2,ref,updaterFn) +\end{code} + +\subsection{XMG Metagrammar stuff} + +XMG trees are produced by the XMG metagrammar system +(\url{http://sourcesup.cru.fr/xmg/}). To debug these grammars, it is useful, +given a TAG tree, to see what its metagrammar origins are. We provide here an +interface to Yannick Parmentier's handy visualisation tool ViewTAG. + +\begin{code} +viewTagWidgets :: (GraphvizShow Bool t, TagItem t, XMGDerivation t) + => Window a -> GraphvizRef (Maybe t) Bool -> Params + -> IO Layout +viewTagWidgets p gvRef config = + do viewTagBtn <- button p [ text := "ViewTAG" ] + viewTagCom <- choice p [ tooltip := "derivation tree" ] + -- handlers + let onViewTag = readIORef gvRef >>= + gvOnSelect (return ()) + (\t -> do let derv = getSourceTrees t + ds <- get viewTagCom selection + if boundsCheck ds derv + then runViewTag config (derv !! ds) + else geniBug $ "Gui: bounds check in onViewTag" + ) + set viewTagBtn [ on command := onViewTag ] + -- when the user selects a tree, we want to update the list of derivations + let updateDerivationList = gvOnSelect + (set viewTagCom [ enabled := False ]) + (\s -> set viewTagCom [ enabled := True + , items := getSourceTrees s + , selection := 0] ) + addGvHandler gvRef updateDerivationList + updateDerivationList =<< readIORef gvRef + -- + return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ] + +runViewTag :: Params -> String -> IO () +runViewTag params drName = + case getFlagP MacrosFlg params of + Nothing -> ePutStrLn "Warning: No macros files specified (runViewTag)" + Just f -> do + -- figure out what grammar file to use + let gramfile = dropExtensions f <.> "rec" + treenameOnly = takeWhile (/= ':') . dropTillIncluding ':' . dropTillIncluding ':' + -- run the viewer + case getFlagP ViewCmdFlg params of + Nothing -> ePutStrLn "Warning: No viewcmd specified (runViewTag)" + Just c -> do -- run the viewer + runProcess c [gramfile, treenameOnly drName] + Nothing Nothing Nothing Nothing Nothing + return () +\end{code} + +% -------------------------------------------------------------------- +\section{Graphical debugger} +\label{sec:debugger_helpers} +% -------------------------------------------------------------------- + +All GenI builders can make use of an interactive graphical debugger. In +this section, we provide some helper code to build such a debugger. + +\paragraph{pauseOnLexGui} sometimes it is useful for the user to see the +lexical selection only and either dump it to file or read replace it by +the contents of some other file. We provide an optional wrapper around +\fnref{candidateGui} which adds this extra functionality. The wrapper +also includes a "Begin" button which runs your continuation on the new +lexical selection. + +\begin{code} +pauseOnLexGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry] + -> ([TagElem] -> IO ()) -- ^ continuation + -> GvIO Bool (Maybe TagElem) +pauseOnLexGui pst f xs missedSem missedLex job = do + p <- panel f [] + candV <- varCreate xs + (tb, ref, updater) <- candidateGui pst p xs missedSem missedLex + -- supplementary button bar + let saveCmd = + do c <- varGet candV + let cStr = unlines $ map geniShow c + maybeSaveAsFile f cStr + loadCmd = + do let filetypes = [("Any file",["*","*.*"])] + fsel <- fileOpenDialog f False True "Choose your file..." filetypes "" "" + case fsel of + Nothing -> return () + Just file -> + do parsed <- parseFromFile geniTagElems file + case parsed of + Left err -> errorDialog f "" (show err) + Right c -> do varSet candV c + setGvDrawables2 ref (sectionsBySem c) + updater + -- + saveBt <- button p [ text := "Save to file", on command := saveCmd ] + loadBt <- button p [ text := "Load from file", on command := loadCmd ] + nextBt <- button p [ text := "Begin" ] + let disableW w = set w [ enabled := False ] + set nextBt [ on command := do mapM disableW [ saveBt, loadBt, nextBt ] + varGet candV >>= job ] + -- + let lay = fill $ container p $ column 5 + [ fill tb, hfill (vrule 1) + , row 0 [ row 5 [ widget saveBt, widget loadBt ] + , hfloatRight $ widget nextBt ] ] + return (lay, ref, updater) +\end{code} + +\paragraph{debuggerTab} is potentially the most useful part of the +debugger. It shows you the contents of chart, agenda and other +such structures used during the actual surface realisation process. +This may be a bit complicated to use because there is lots of extra +stuff you need to pass in order to parameterise the whole deal. + +The function \fnreflite{debuggerTab} fills the parent window with the +standard components of a graphical debugger: +\begin{itemize} +\item An item viewer which allows the user to select one of the items + in the builder state. +\item An item bar which provides some options on how to view the + currently selected item, for example, if you want to display the + features or not. +\item A dashboard which lets the user do things like ``go ahead 6 + steps''. +\end{itemize} + +See the API for more details. + +\begin{code} +type DebuggerItemBar flg itm + = (Panel ()) -- ^ parent panel + -> GraphvizRef (Maybe itm) flg + -- ^ gv ref to use + -> GvUpdater -- ^ updaterFn + -> IO Layout + +-- | A generic graphical debugger widget for GenI +-- +-- Besides the Builder, there are two functions you need to pass in make this +-- work: +-- +-- 1. a 'stateToGv' which converts the builder state into a list of items +-- and labels the way 'graphvizGui' likes it +-- +-- 2. an 'item bar' function which lets you control what bits you display +-- of a selected item (for example, if you want a detailed view or not) +-- the item bar should return a layout +-- +-- Note that we don't constrain the type of item returned by the builder to +-- be the same as the type handled by your gui: that's quite normal because +-- you might want to decorate the type with some other information +debuggerPanel :: (GraphvizShow flg itm) + => B.Builder st itm2 Params -- ^ builder to use + -> flg -- ^ initial value for the flag argument in GraphvizShow + -> (st -> [(Maybe itm, String)]) + -- ^ function to convert a Builder state into lists of items + -- and their labels, the way graphvizGui likes it + -> (DebuggerItemBar flg itm) + -- ^ 'itemBar' function returning a control panel configuring + -- how you want the currently selected item in the debugger + -- to be displayed + -> (Window a) -- ^ parent window + -> Params -- ^ geni params + -> B.Input -- ^ builder input + -> String -- ^ graphviz cache directory + -> IO Layout +debuggerPanel builder gvInitial stateToGv itemBar f config input cachedir = + do let initBuilder = B.init builder + nextStep = B.step builder + allSteps = B.stepAll builder + -- + let (initS, initStats) = initBuilder input config2 + config2 = setFlagP MetricsFlg (B.defaultMetricNames) config + (theItems,labels) = unzip $ stateToGv initS + p <- panel f [] + -- --------------------------------------------------------- + -- item viewer: select and display an item + -- --------------------------------------------------------- + gvRef <- newGvRef gvInitial labels "debugger session" + setGvDrawables gvRef theItems + (layItemViewer,_,updaterFn) <- graphvizGui p cachedir gvRef + -- ---------------------------------------------------------- + -- item bar: controls for how an individual item is displayed + -- ---------------------------------------------------------- + layItemBar <- itemBar p gvRef updaterFn + -- ------------------------------------------- + -- dashboard: controls for the debugger itself + -- ------------------------------------------- + db <- panel p [] + restartBt <- button db [text := "Start over"] + nextBt <- button db [text := "Step by..."] + leapVal <- entry db [ text := "1", clientSize := sz 30 25 ] + finishBt <- button db [text := "Leap to end"] + statsTxt <- staticText db [] + -- dashboard commands + let showQuery c gs = case queryCounter c gs of + Nothing -> "???" + Just q -> show q + updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ] + txtStats gs = "itr " ++ (showQuery num_iterations gs) ++ " " + ++ "chart sz: " ++ (showQuery chart_size gs) + ++ "\ncomparisons: " ++ (showQuery num_comparisons gs) + let genStep _ (st,stats) = runState (execStateT nextStep st) stats + let showNext s_stats = + do leapTxt <- get leapVal text + let leapInt :: Integer + leapInt = read leapTxt + (s2,stats2) = foldr genStep s_stats [1..leapInt] + setGvDrawables2 gvRef (stateToGv s2) + setGvSel gvRef 1 + updaterFn + updateStatsTxt stats2 + set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ] + let showLast = + do -- redo generation from scratch + let (s2, stats2) = runState (execStateT allSteps initS) initStats + setGvDrawables2 gvRef (stateToGv s2) + updaterFn + updateStatsTxt stats2 + let showReset = + do set nextBt [ on command := showNext (initS, initStats) ] + updateStatsTxt initStats + setGvDrawables2 gvRef (stateToGv initS) + setGvSel gvRef 1 + updaterFn + -- dashboard handlers + set finishBt [ on command := showLast ] + set restartBt [ on command := showReset ] + showReset + -- dashboard layout + let layCmdBar = hfill $ container db $ row 5 + [ widget statsTxt, hfloatRight $ row 5 + [ widget restartBt, widget nextBt + , widget leapVal, label " step(s)" + , widget finishBt ] ] + -- ------------------------------------------- + -- overall layout + -- ------------------------------------------- + return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ] +\end{code} + +% -------------------------------------------------------------------- +\section{Graphviz GUI} +\label{sec:graphviz_gui} +% -------------------------------------------------------------------- + +A general-purpose GUI for displaying a list of items graphically via +AT\&T's excellent Graphviz utility. We have a list box where we display +all the labels the user provided. If the user selects an entry from +this box, then the item corresponding to that label will be displayed. +See section \ref{sec:draw_item}. + +\paragraph{gvRef} + +We use IORef as a way to keep track of the gui state and to provide you +the possibility for modifying the contents of the GUI. The idea is that + +\begin{enumerate} +\item you create a GvRef with newGvRef +\item you call graphvizGui and get back an updater function +\item whenever you want to modify something, you use setGvWhatever + and call the updater function +\item if you want to react to the selection being changed, + you should set gvhandler +\end{enumerate} + +\begin{code} +data GraphvizOrder = GvoParams | GvoItems | GvoSel + deriving Eq +data GraphvizGuiSt a b = + GvSt { gvitems :: Map.Map Int a, + gvparams :: b, + gvlabels :: [String], + -- tooltip for the selection box + gvtip :: String, + -- handler function to call when the selection is + -- updated (note: before displaying the object) + gvhandler :: Maybe (GraphvizGuiSt a b -> IO ()), + gvsel :: Int, + gvorders :: [GraphvizOrder] } +type GraphvizRef a b = IORef (GraphvizGuiSt a b) + +newGvRef :: forall a . forall b . b -> [String] -> String -> IO (GraphvizRef a b) +newGvRef p l t = + let st = GvSt { gvparams = p, + gvitems = Map.empty, + gvlabels = l, + gvhandler = Nothing, + gvtip = t, + gvsel = 0, + gvorders = [] } + in newIORef st + +setGvSel :: GraphvizRef a b -> Int -> IO () +setGvSel gvref s = + do let fn x = x { gvsel = s, + gvorders = GvoSel : (gvorders x) } + modifyIORef gvref fn + +setGvParams :: GraphvizRef a b -> b -> IO () +setGvParams gvref c = + do let fn x = x { gvparams = c, + gvorders = GvoParams : (gvorders x) } + modifyIORef gvref fn + +modifyGvParams :: GraphvizRef a b -> (b -> b) -> IO () +modifyGvParams gvref fn = + do gvSt <- readIORef gvref + setGvParams gvref (fn $ gvparams gvSt) + +setGvDrawables :: GraphvizRef a b -> [a] -> IO () +setGvDrawables gvref it = + do let fn x = x { gvitems = Map.fromList $ zip [0..] it, + gvorders = GvoItems : (gvorders x) } + modifyIORef gvref fn + +setGvDrawables2 :: GraphvizRef a b -> [(a,String)] -> IO () +setGvDrawables2 gvref itlb = + do let (it,lb) = unzip itlb + fn x = x { gvlabels = lb } + modifyIORef gvref fn + setGvDrawables gvref it + +-- | Helper function for making selection handlers (see 'addGvHandler') +-- Note that this was designed for cases where the contents is a Maybe +gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt (Maybe a) b -> IO () +gvOnSelect onNothing onJust gvSt = + let sel = gvsel gvSt + things = gvitems gvSt + in case Map.lookup sel things of + Just (Just s) -> onJust s + _ -> onNothing + +setGvHandler :: GraphvizRef a b -> Maybe (GraphvizGuiSt a b -> IO ()) -> IO () +setGvHandler gvref mh = + do gvSt <- readIORef gvref + modifyIORef gvref (\x -> x { gvhandler = mh }) + case mh of + Nothing -> return () + Just fn -> fn gvSt + +-- | add a selection handler - if there already is a handler +-- this handler will be called before the new one +addGvHandler :: GraphvizRef a b -> (GraphvizGuiSt a b -> IO ()) -> IO () +addGvHandler gvref h = + do gvSt <- readIORef gvref + let newH = case gvhandler gvSt of + Nothing -> Just h + Just oldH -> Just (\g -> oldH g >> h g) + setGvHandler gvref newH +\end{code} + +\paragraph{graphvizGui} returns a layout (wxhaskell container) and a +function for updating the contents of this GUI. + +Arguments: +\begin{enumerate} +\item f - (parent window) the GUI is provided as a panel within the parent. + Note: we use window in the WxWidget's sense, meaning it could be + anything as simple as a another panel, or a notebook tab. +\item glab - (gui labels) a tuple of strings (tooltip, next button text) +\item cachedir - the cache subdirectory. We intialise this by creating a cache + directory for images which will be generated from the results +\item gvRef - see above +\end{enumerate} + +Returns: a function for updating the GUI. FIXME: it's not entirely clear +what the updater function is for; note that it's not the same as the +handler function! + +\begin{code} +graphvizGui :: (GraphvizShow f d) => + (Window a) -> String -> GraphvizRef d f -> GvIO f d +type GvIO f d = IO (Layout, GraphvizRef d f, GvUpdater) +type GvUpdater = IO () + +graphvizGui f cachedir gvRef = do + initGvSt <- readIORef gvRef + -- widgets + p <- panel f [ fullRepaintOnResize := False ] + split <- splitterWindow p [] + (dtBitmap,sw) <- scrolledBitmap split + rchoice <- singleListBox split [tooltip := gvtip initGvSt] + -- set handlers + let openFn = openImage sw dtBitmap + -- pack it all together + let lay = fill $ container p $ margin 1 $ fill $ + vsplit split 5 200 (widget rchoice) (widget sw) + set p [ on closing := closeImage dtBitmap ] + -- bind an action to rchoice + let showItem = do createAndOpenImage cachedir p gvRef openFn + `catch` \e -> errorDialog f "" (show e) + ------------------------------------------------ + -- create an updater function + ------------------------------------------------ + let updaterFn = do + gvSt <- readIORef gvRef + let orders = gvorders gvSt + labels = gvlabels gvSt + sel = gvsel gvSt + initCacheDir cachedir + Monad.when (GvoItems `elem` orders) $ + set rchoice [ items :~ (\_ -> labels) ] + Monad.when (GvoSel `elem` orders) $ + set rchoice [ selection :~ (\_ -> sel) ] + modifyIORef gvRef (\x -> x { gvorders = []}) + -- putStrLn "updaterFn called" + showItem + ------------------------------------------------ + -- enable the tree selector + -- FIXME: not sure that this is correct + ------------------------------------------------ + let selectAndShow = do + -- putStrLn "selectAndShow called" + sel <- get rchoice selection + -- note: do not use setGvSel (infinite loop) + modifyIORef gvRef (\x -> x { gvsel = sel }) + -- call the handler if there is one + gvSt <- readIORef gvRef + case (gvhandler gvSt) of + Nothing -> return () + Just h -> h gvSt + -- now do the update + updaterFn + ------------------------------------------------ + set rchoice [ on select := selectAndShow ] + -- call the updater function for the first time + -- setGvSel gvRef 1 + updaterFn + -- return the layout, the gvRef, and an updater function + -- The gvRef is to make it easier for users to muck around with the + -- state of the gui. Here, it's trivial, but when people combine guis + -- together, it might be easier to keep track of when returned + return (lay, gvRef, updaterFn) +\end{code} + +\subsection{Scroll bitmap} + +Bitmap with a scrollbar + +\begin{code} +scrolledBitmap :: Window a -> IO(VarBitmap, ScrolledWindow ()) +scrolledBitmap p = do + dtBitmap <- variable [value := Nothing] + sw <- scrolledWindow p [scrollRate := sz 10 10, bgcolor := white, + on paint := onPaint dtBitmap, + fullRepaintOnResize := False ] + return (dtBitmap, sw) +\end{code} + +\subsection{Bitmap functions} + +The following helper functions were taken directly from the WxHaskell +sample code. + +\begin{code} +type OpenImageFn = FilePath -> IO () +type VarBitmap = Var (Maybe (Bitmap ())) + +openImage :: Window a -> VarBitmap -> OpenImageFn +openImage sw vbitmap fname = do + -- load the new bitmap + bm <- bitmapCreateFromFile fname -- can fail with exception + closeImage vbitmap + set vbitmap [value := Just bm] + -- reset the scrollbars + bmsize <- get bm size + set sw [virtualSize := bmsize] + repaint sw + `catch` \_ -> repaint sw + +closeImage :: VarBitmap -> IO () +closeImage vbitmap = do + mbBitmap <- swap vbitmap value Nothing + case mbBitmap of + Nothing -> return () + Just bm -> objectDelete bm + +onPaint :: VarBitmap -> DC a -> b -> IO () +onPaint vbitmap dc _ = do + mbBitmap <- get vbitmap value + case mbBitmap of + Nothing -> return () + Just bm -> do dcClear dc + drawBitmap dc bm pointZero False [] +\end{code} + +\subsection{Drawing stuff} +\label{sec:draw_item} + +\paragraph{createAndOpenImage} Attempts to draw an image +(or retrieve it from cache) and opens it if we succeed. Otherwise, it +does nothing at all; the creation function will display an error message +if it fails. + +\begin{code} +createAndOpenImage :: (GraphvizShow f b) => + FilePath -> Window a -> GraphvizRef b f -> OpenImageFn -> IO () +createAndOpenImage cachedir f gvref openFn = do + let errormsg g = "The file " ++ g ++ " was not created!\n" + ++ "Is graphviz installed?" + r <- createImage cachedir f gvref + case r of + Just graphic -> do exists <- doesFileExist graphic + if exists + then openFn graphic + else fail (errormsg graphic) + Nothing -> return () + +-- | Creates a graphical visualisation for anything which can be displayed +-- by graphviz. +createImage :: (GraphvizShow f b) + => FilePath -- ^ cache directory + -> Window a -- ^ parent window + -> GraphvizRef b f -- ^ stuff to display + -> IO (Maybe FilePath) +createImage cachedir f gvref = do + gvSt <- readIORef gvref + -- putStrLn $ "creating image via graphviz" + let drawables = gvitems gvSt + sel = gvsel gvSt + config = gvparams gvSt + dotFile <- createDotPath cachedir (show sel) + graphicFile <- createImagePath cachedir (show sel) + let create x = do toGraphviz config x dotFile graphicFile + return (Just graphicFile) + handler err = do errorDialog f "Error calling graphviz" (show err) + return Nothing + exists <- doesFileExist graphicFile + -- we only call graphviz if the image is not in the cache + if exists + then return (Just graphicFile) + else case Map.lookup sel drawables of + Nothing -> return Nothing + Just it -> create it `catch` handler +\end{code} + +\subsection{Cache directory} + +We create a directory to put image files in so that we can avoid regenerating +images. If the directory already exists, we can just delete all the files +in it. + +\begin{code} +initCacheDir :: String -> IO() +initCacheDir cachesubdir = do + mainCacheDir <- gv_CACHEDIR + cmainExists <- doesDirectoryExist mainCacheDir + Monad.when (not cmainExists) $ createDirectory mainCacheDir + -- + let cachedir = mainCacheDir cachesubdir + cExists <- doesDirectoryExist cachedir + if (cExists) + then do let notdot x = (x /= "." && x /= "..") + contents <- getDirectoryContents cachedir + olddir <- getCurrentDirectory + setCurrentDirectory cachedir + mapM removeFile $ filter notdot contents + setCurrentDirectory olddir + return () + else createDirectory cachedir +\end{code} + +\section{Miscellaneous} +\label{sec:gui_misc} + +\begin{code} +-- | Save the given string to a file, if the user selets one via the file save +-- dialog. Otherwise, don't do anything. +maybeSaveAsFile :: (Window a) -> String -> IO () +maybeSaveAsFile f msg = + do let filetypes = [("Any file",["*","*.*"])] + fsel <- fileSaveDialog f False True "Save to" filetypes "" "" + case fsel of + Nothing -> return () + Just file -> writeFile file msg + +-- | A message panel for use by the Results gui panels. +messageGui :: (Window a) -> String -> IO Layout +messageGui f msg = do + p <- panel f [] + -- sw <- scrolledWindow p [scrollRate := sz 10 10 ] + t <- textCtrl p [ text := msg, enabled := False ] + return (fill $ container p $ column 1 $ [ fill $ widget t ]) +\end{code} + +\begin{code} +gv_CACHEDIR :: IO String +gv_CACHEDIR = do + home <- getHomeDirectory + return $ home ".gvcache" + +createImagePath :: String -> String -> IO String +createImagePath subdir name = do + cdir <- gv_CACHEDIR + return $ cdir subdir name <.> "png" + +createDotPath :: String -> String -> IO String +createDotPath subdir name = do + cdir <- gv_CACHEDIR + return $ cdir subdir name <.> "dot" +\end{code} + + diff --git a/src/NLP/GenI/Morphology.lhs b/src/NLP/GenI/Morphology.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Morphology.lhs @@ -0,0 +1,218 @@ +% 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. + +\chapter{Morphology} +\label{cha:Morphology} + +This module handles mostly everything to do with morphology in Geni. +There are two basic tasks: morphological input and output. +GenI farms out morphology to whatever third party program you +specify in the configuration file. + +\begin{code} +module NLP.GenI.Morphology where +\end{code} + +\ignore{ +\begin{code} +import Data.Maybe (isNothing, isJust) +import Data.List (intersperse) +import Data.Tree +import qualified Data.Map as Map +import System.IO +import System.Process + +import NLP.GenI.Btypes +import NLP.GenI.General +import NLP.GenI.Tags +\end{code} +} + +\begin{code} +type MorphFn = Pred -> Maybe Flist +\end{code} + +\section{Input} + +Morphological input means attaching morphological features on trees. The +user specifies morphological input through the input semantics. Our job +is to identify morphological predicates like \semexpr{plural(x)} and +apply features like \fs{\it num:pl} on the relevant trees. + +\begin{code} +-- | Converts information from a morphological information file into GenI's +-- internal format. +readMorph :: [(String,[AvPair])] -> MorphFn +readMorph minfo pred_ = Map.lookup key fm + where fm = Map.fromList minfo + key = show $ snd3 pred_ + +-- | Filters away from an input semantics any literals whose realisation is +-- strictly morphological. The first argument tells us helps identify the +-- morphological literals -- it associates literals with morphological stuff; +-- if it returns 'Nothing', then it is non-morphological +stripMorphSem :: MorphFn -> Sem -> Sem +stripMorphSem morphfn tsem = + [ l | l <- tsem, (isNothing.morphfn) l ] + +-- | 'attachMorph' @morphfn sem cands@ does the bulk of the morphological +-- input processing. We use @morphfn@ to determine which literals in +-- @sem@ contain morphological information and what information they contain. +-- Then we attach this morphological information to the relevant trees in +-- @cand@. A tree is considered relevant w.r.t to a morphological +-- literal if its semantics contains at least one literal whose first index +-- is the same as the first index of the morphological literal. +attachMorph :: MorphFn -> Sem -> [TagElem] -> [TagElem] +attachMorph morphfn sem cands = + let -- relevance of a tree wrt to an index + relTree i = not.null.relfilt.tsemantics + where relfilt = filter (relLit i) + relLit i l = if null args then False else (head args == i) + where args = thd3 l + -- perform the attachment for a tree if it is relevant + attachHelper :: GeniVal -> Flist -> TagElem -> TagElem + attachHelper i mfs t = + if relTree i t then attachMorphHelper mfs t else t + -- perform all attachments for a literal + attach :: Pred -> [TagElem] -> [TagElem] + attach l cs = + case morphfn l of + Nothing -> cs + Just mfs -> map (attachHelper i mfs) cs + where i = if null args then GAnon else head args + args = thd3 l + in foldr attach cands sem + +-- | Actually unify the morphological features into the anchor node +-- +-- FIXME: we'll need to make sure this still works as promised +-- when we implement co-anchors. +attachMorphHelper :: Flist -> TagElem -> TagElem +attachMorphHelper mfs te = + let -- unification with anchor + tt = ttree te + anchor = head $ filterTree fn tt + where fn a = (ganchor a && gtype a == Lex) + in case unifyFeat mfs (gup anchor) of + Nothing -> error ("Morphological unification failure on " ++ idname te) + Just (unf,subst) -> + let -- perform replacements + te2 = replace subst te + tt2 = ttree te2 + -- replace the anchor with the unification results + newgdown = replace subst (gdown anchor) + newa = anchor { gup = unf, gdown = newgdown } + in te2 { ttree = setMorphAnchor newa tt2 } + +setMorphAnchor :: GNode -> Tree GNode -> Tree GNode +setMorphAnchor n t = + let filt (Node a _) = (gtype a == Lex && ganchor a) + fn (Node _ l) = Node n l + in (head.fst) $ listRepNode fn filt [t] +\end{code} + +\section{Output} + +Output (\jargon{morphological generation}) refers to the actual process +of converting lemmas and morphological information into inflected forms. +We do this by calling some third party software specified by the user. + +The morphological software must accept on stdin a newline delimited list +of lemmas and features, with \verb$----$ (four hyphens) as an intersentence +delimiter: + +\begin{verbatim} +le [num:sg gen:f] +fille [num:sg] +detester [num:sg tense:past] +le [num:pl gen:m] +garcon [num:pl] +---- [] +ce [] +etre [] +le [num:pl] +garcon [num:pl] +que [] +le [num:sg gen:f] +fille [num:sg] +detester [num:sg tense:past] +\end{verbatim} + +It must return inflected forms on stdout, \emph{sentences} delimited by +newlines. Note also that we expect exactly one result for every input. +Notice that the morphological generator can choose to delete +spaces or do other orthographical tricks in between words: + +\begin{verbatim} +la fille detestait les garcons +c'est les garcons que la fille detestait +\end{verbatim} + +If your morphological software does not do this, you could wrap it +with a simple shell or Perl script. + +\begin{code} +-- | Extracts the lemmas from a list of uninflected sentences. This is used +-- when the morphological generator is unavailable, doesn't work, etc. +sansMorph :: [(String,Flist)] -> [String] +sansMorph = singleton . unwords . (map fst) + +type MorphLexicon = [(String, String, Flist)] +type UninflectedDisjunction = (String, Flist) + +-- | Return a list of results for each sentence +inflectSentencesUsingLex :: MorphLexicon -> [[UninflectedDisjunction]] -> [[String]] +inflectSentencesUsingLex mlex = map (inflectSentenceUsingLex mlex) + +inflectSentenceUsingLex :: MorphLexicon -> [UninflectedDisjunction] -> [String] +inflectSentenceUsingLex mlex = map unwords . mapM (inflectWordUsingLex mlex) + +-- | Return only n matches, but note any excessive ambiguities or missing matches +inflectWordUsingLex :: MorphLexicon -> UninflectedDisjunction -> [String] +inflectWordUsingLex mlex (lem,fs) + | null matches = [ lem ++ "-" ] -- no matches = lemma plus little icon + | length matches > 2 = [ lem ++ "*" ] -- too many matches! + | otherwise = matches + where + matches = [ word | (word, mLem, mFs) <- mlex, lem == mLem, isJust $ fs `unifyFeat` mFs ] + +-- | Converts a list of uninflected sentences into inflected ones by calling +--- the third party software. +-- FIXME: this doesn't actually support lists-of-results per input +-- will need to work it out +inflectSentencesUsingCmd :: String -> [[UninflectedDisjunction]] -> IO [[String]] +inflectSentencesUsingCmd morphcmd sentences = + do -- add intersential delimiters + let delim = [("----",[])] + morphlst = concat (intersperse delim sentences) + -- format the stuff as input to the inflector + let fn (lem,fs) = lem ++ " " ++ showFlist fs + order = unlines $ map fn morphlst + -- run the inflector + (toP, fromP, _, pid) <- runInteractiveCommand morphcmd + hPutStrLn toP order + hClose toP + waitForProcess pid + -- read the inflector output back as a list of strings + (map (singleton . trim) . lines) `fmap` hGetContents fromP + `catch` \e -> do ePutStrLn "Error calling morphological generator" + ePutStrLn $ show e + return $ map sansMorph sentences + +singleton :: a -> [a] +singleton x = [x] +\end{code} diff --git a/src/NLP/GenI/Polarity.lhs b/src/NLP/GenI/Polarity.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Polarity.lhs @@ -0,0 +1,1167 @@ +% 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. + +\chapter{Polarity Optimisation} +\label{cha:Polarity} + +We introduce a notion of polarities as a means of pre-detecting +incompatibilities between candidate trees for different propositions. +This optimisation is inserted between candidate selection +(section \ref{sec:candidate_selection}) +and chart generation. The input to this optimisation is the +\jargon{target semantics} and the corresponding \jargon{candidate + trees}. + +This whole optimisation is based on adding polarities to the grammar. +We have a set of strings which we call \jargon{polarity keys}, and some +positive or negative integers which we call \jargon{charges}. Each tree +in the grammar may assign a charge to some number of polarity keys. For +example, here is a simple grammar that uses the polarity keys n and v. + +\begin{tabular}{|l|l|} +\hline +tree & polarity effects \\ +\hline +s(n$\downarrow$, v$\downarrow$, n$\downarrow$) & -2n -v\\ +v(hates) & +v\\ +n(mary) & +n\\ +n(john) & +n\\ +\hline +\end{tabular} + +For now, these annotations are done by hand, and are based on syntactic +criteria (substitution and root node categories) but one could envisage +alternate criteria or an eventual means of automating the process. + +The basic idea is to use the polarity keys to determine which subsets of +candidate trees are incompatible with each other and rule them out. We +construct a finite state automaton which uses polarity keys to +pre-calculate the compatibility of sets of trees. At the end of the +optimisation, we are left with an automaton, each path of which is a +potentially compatible set of trees. We then preform surface +realisation seperately, treating each path as a set of candidate trees. + +\emph{Important note}: one thing that may be confusing in this chapter +is that we refer to polarities (charges) as single integers, e.g, $-2n$. +In reality, to account for weird stuff like atomic disjunction, we do +not use simple integers, but polarities intervals, so more something +like $(-2,-2)n$! But for the most part, the intervals are zero length, +and you can just think of $-2n$ as shorthand for $(-2,-2)n$. + +\begin{code} +module NLP.GenI.Polarity( + -- * Entry point + PolAut, PolState(PolSt), AutDebug, PolResult, + buildAutomaton, + + -- * Inner stuff (exported for debugging?) + makePolAut, + fixPronouns, + detectSansIdx, detectPolFeatures, detectPols, detectPolPaths, + declareIdxConstraints, detectIdxConstraints, + showLite, showLitePm, showPolPaths, showPolPaths', + + -- re-exported from Automaton + automatonPaths, finalSt, + NFA(states, transitions), + ) +where +\end{code} + +\begin{code} +import Data.Bits +import qualified Data.Map as Map +import Data.List +import Data.Maybe (isNothing) +import Data.Tree (flatten) +import qualified Data.Set as Set + +import NLP.GenI.Automaton +import NLP.GenI.Btypes(Pred, SemInput, Sem, Flist, AvPair, showAv, + GeniVal(GAnon), fromGConst, isConst, + Replacable(..), + emptyPred, Ptype(Initial), + showFlist, showSem, sortSem, + root, gup, gdown, gtype, GType(Subs), + SemPols, unifyFeat, rootUpd) +import NLP.GenI.General( + BitVector, isEmptyIntersect, thd3, + Interval, ival, (!+!), showInterval) +import NLP.GenI.Tags(TagElem(..), TagItem(..), setTidnums) +\end{code} + +\section{Interface} + +\begin{code} +-- | intermediate auts, seed aut, final aut, potentially modified sem +type PolResult = ([AutDebug], PolAut, PolAut, Sem) +type AutDebug = (String, PolAut, PolAut) + +-- | Constructs a polarity automaton from the surface realiser's input: input +-- semantics, lexical selection, extra polarities and index constraints. For +-- debugging purposes, it returns all the intermediate automata produced by +-- the construction algorithm. +buildAutomaton :: SemInput -> [TagElem] -> Flist -> PolMap -> PolResult +buildAutomaton (tsem,tres,_) candRaw rootFeat extrapol = + let -- root categories, index constraints, and external polarities + rcatPol :: Map.Map String Interval + rcatPol = Map.fromList $ polarise (-1) $ getval __cat__ rootFeat + allExtraPols = Map.unionsWith (!+!) [ extrapol, inputRest, rcatPol ] + -- index constraints on candidate trees + detect = detectIdxConstraints tres + constrain t = t { tpolarities = Map.unionWith (!+!) p r + } --, tinterface = [] } + where p = tpolarities t + r = (detect . tinterface) t + candRest = map constrain candRaw + inputRest = declareIdxConstraints tres + -- polarity detection + cand = detectPols candRest + -- building the automaton + in makePolAut cand tsem allExtraPols +\end{code} + +\section{The automaton itself - outline} +\label{polarity:overview} + +We start with the controller function (the general architecture) and +detail the individual steps in the following sections. The basic +architecture is as follows: + +\begin{enumerate} +\item Build a seed automaton (section \ref{sec:seed_automaton}). +\item For each polarity key, elaborate the + automaton with the polarity information for that key + (section \ref{sec:automaton_construction}) and minimise + the automaton (section \ref{sec:automaton_pruning}). +\end{enumerate} + +The above process can be thought of as a more efficient way of +constructing an automaton for each polarity key, minimising said +automaton, and then taking their intersection. In any case, +we return everything a tuple with (1) a list of the automota that +were created (2) the final automaton (3) a possibly modified +input semantics. The first item is only neccesary for debugging; only +the last two are important. + +Note: +\begin{itemize} +\item the \fnparam{extraPol} argument is a map containing any initial + values for polarity keys. This is useful to impose external filters + like ``I only want expressions where the object is topicalised''. +\item to recuperate something useful from these automaton, it might + be helpful to call \fnref{automatonPaths} on it. +\end{itemize} + +\begin{code} +makePolAut :: [TagElem] -> Sem -> PolMap -> PolResult +makePolAut candsRaw tsemRaw extraPol = + let -- polarity items + ksCands = concatMap ((Map.keys).tpolarities) cands + ksExtra = Map.keys extraPol + ks = sortBy (flip compare) $ nub $ ksCands ++ ksExtra + -- perform index counting + (tsem, cands') = fixPronouns (tsemRaw,candsRaw) + cands = setTidnums cands' + -- sorted semantics (for more efficient construction) + sortedsem = sortSemByFreq tsem cands + -- the seed automaton + smap = buildColumns cands sortedsem + seed = buildSeedAut smap sortedsem + -- building and remembering the automata + build k xs = (k,aut,prune aut):xs + where aut = buildPolAut k initK (thd3 $ head xs) + initK = Map.findWithDefault (ival 0) k extraPol + res = foldr build [("(seed)",seed,prune seed)] ks + in (reverse res, seed, thd3 $ head res, tsem) +\end{code} + +% ==================================================================== +\section{Polarity automaton} +\label{sec:polarity_automaton} +% ==================================================================== + +We construct a finite state automaton for each polarity key that is in +the set of trees. It helps to imagine a table where each column +corresponds to a single proposition. + +\begin{center} +\begin{tabular}{|c|c|c|} +\hline +\semexpr{gift(g)} & \semexpr{cost(g,x)} & \semexpr{high(x)} \\ +\hline +\natlang{the gift} \color{blue}{+1np} & +\natlang{the cost of} & +\natlang{is high} \color{red}{-1np} \\ +% +\natlang{the present} \color{blue}{+1np} & +\natlang{costs} \color{red}{-1np} & +\natlang{a lot} \\ +% +&& \natlang{much} \\ +\hline +\end{tabular} +\end{center} + +Each column (proposition) has a different number of cells which +corresponds to the lexical ambiguity for that proposition, more +concretely, the number of candidate trees for that proposition. The +\jargon{polarity automaton} describes the different ways we can traverse +the table from column to column, choosing a cell to pass through at each +step and accumulating polarity along the way. Each state represents the +polarity at a column and each transition represents the tree we chose to +get there. All transitions from one columns $i$ to the next $i+1$ that +lead to the same accumulated polarity lead to the same state. + +% ---------------------------------------------------------------------- +\subsection{Columns} +% ---------------------------------------------------------------------- + +We build the columns for the polarity automaton as follows. Given a +input semantics \texttt{sem} and a list of trees \texttt{cands}, we +group the trees by the first literal of sem that is part of their tree +semantics. + +Note: this is not the same function as Tags.mapBySem! The fact that we +preserve the order of the input semantics is important for our handling +of multi-literal semantics and for semantic frequency sorting. + +\begin{code} +buildColumns :: (TagItem t) => [t] -> Sem -> Map.Map Pred [t] +buildColumns cands [] = + Map.singleton emptyPred e + where e = filter (null.tgSemantics) cands + +buildColumns cands (l:ls) = + let matchfn t = l `elem` tgSemantics t + (match, cands2) = partition matchfn cands + next = buildColumns cands2 ls + in Map.insert l match next +\end{code} + +% ---------------------------------------------------------------------- +\subsection{Initial Automaton} +\label{sec:seed_automaton} +% ---------------------------------------------------------------------- + +We first construct a relatively trivial polarity automaton without any +polarity effects. Each state except the start state corresponds +to a literal in the target semantics, and the transitions to a state +consist of the trees whose semantics is subsumed by that literal. + +\begin{code} +buildSeedAut :: SemMap -> Sem -> PolAut +buildSeedAut cands tsem = + let start = polstart [] + hasZero (x,y) = x <= 0 && y >= 0 + isFinal (PolSt c _ pols) = + c == length tsem && all hasZero pols + initAut = NFA + { startSt = start + , isFinalSt = Just isFinal + , finalStList = [] + , states = [[start]] + , transitions = Map.empty } + in nubAut $ buildSeedAut' cands tsem 1 initAut + +-- for each literal... +buildSeedAut' :: SemMap -> Sem -> Int -> PolAut -> PolAut +buildSeedAut' _ [] _ aut = aut +buildSeedAut' cands (l:ls) i aut = + let -- previously created candidates + prev = head $ states aut + -- candidates that match the target semantics + tcands = Map.findWithDefault [] l cands + -- create the next batch of states + fn st ap = buildSeedAutHelper tcands l i st ap + (newAut,newStates) = foldr fn (aut,[]) prev + next = (nub newStates):(states aut) + -- recursive step to the next literal + in buildSeedAut' cands ls (i+1) (newAut { states = next }) + +-- for each candidate corresponding to literal l... +buildSeedAutHelper :: [TagElem] -> Pred -> Int -> PolState -> (PolAut,[PolState]) -> (PolAut,[PolState]) +buildSeedAutHelper cs l i st (aut,prev) = + let -- get the extra semantics from the last state + (PolSt _ ex1 _) = st + -- candidates that match the target semantics and which + -- do not overlap the extra baggage semantics + tcand = [ Just t | t <- cs + , isEmptyIntersect ex1 (tsemantics t) ] + -- add the transitions out of the current state + addT tr (a,n) = (addTrans a st tr st2, st2:n) + where + st2 = PolSt i (delete l $ ex1 ++ ex2) [] + ex2 = case tr of + Nothing -> [] + Just tr_ -> tsemantics tr_ + in if (l `elem` ex1) + then addT Nothing (aut,prev) + else foldr addT (aut,prev) tcand +\end{code} + +% ---------------------------------------------------------------------- +\subsection{Construction} +\label{sec:automaton_construction} +\label{sec:automaton_intersection} +% ---------------------------------------------------------------------- + +The goal is to construct a polarity automaton which accounts for a +given polarity key $k$. The basic idea is that given +literals $p_1..p_n$ in the target semantics, we create a start state, +calculate the states/transitions to $p_1$ and succesively calculate +the states/transitions from proposition $p_x$ to $p_{x+1}$ for all +$1 < x < n$. + +The ultimate goal is to construct an automaton that accounts for +multiple polarity keys. The simplest approach would be to +calculate a seperate automaton for each key, prune them all and +then intersect the pruned automaton together, but we can do much +better than that. Since the pruned automata are generally much +smaller in size, we perform an iterative intersection by using +a previously pruned automaton as the skeleton for the current +automaton. This is why we don't pass any literals or candidates +to the construction step; it takes them directly from the previous +automaton. See also section \ref{sec:seed_automaton} for the seed +automaton that you can use when there is no ``previous automaton''. + +\begin{code} +buildPolAut :: String -> Interval -> PolAut -> PolAut +buildPolAut k initK skelAut = + let concatPol p (PolSt pr b pol) = PolSt pr b (p:pol) + newStart = concatPol initK $ startSt skelAut + -- + initAut = skelAut + { startSt = newStart + , states = [[newStart]] + , transitions = Map.empty } + -- cand' = observe "candidate map" cand + in nubAut $ buildPolAut' k (transitions skelAut) initAut +\end{code} + +Our helper function looks at a single state in the skeleton automaton +and at one of the states in the new automaton which correspond to it. +We use the transitions from the old automaton to determine which states +to construct. Note: there can be more than one state in the automaton +which corresponds to a state in the old automaton. This is because we +are looking at a different polarity key, so that whereas two candidates +automaton may transition to the same state in the old automaton, their +polarity effects for the new key will make them diverge in the new +automaton. + +\begin{code} +buildPolAut' :: String -> PolTransFn -> PolAut -> PolAut +-- for each literal... (this is implicit in the automaton state grouping) +buildPolAut' fk skeleton aut = + let -- previously created candidates + prev = head $ states aut + -- create the next batch of states + fn st ap = buildPolAutHelper fk skeleton st ap + (newAut,newStates) = foldr fn (aut,Set.empty) prev + next = (Set.toList $ newStates):(states aut) + -- recursive step to the next literal + in if Set.null newStates + then aut + else buildPolAut' fk skeleton (newAut { states = next }) + +-- given a previously created state... +buildPolAutHelper :: String -> PolTransFn -> PolState -> (PolAut,Set.Set PolState) -> (PolAut,Set.Set PolState) +buildPolAutHelper fk skeleton st (aut,prev) = + let -- reconstruct the skeleton state used to build st + PolSt pr ex (po1:skelpo1) = st + skelSt = PolSt pr ex skelpo1 + -- for each transition out of the current state + -- nb: a transition is (next state, [labels to that state]) + trans = Map.toList $ Map.findWithDefault Map.empty skelSt skeleton + result = foldr addT (aut,prev) trans + -- . for each label to the next state st2 + addT (oldSt2,trs) (a,n) = foldr (addTS oldSt2) (a,n) trs + -- .. calculate a new state and add a transition to it + addTS skel2 tr (a,n) = (addTrans a st tr st2, Set.insert st2 n) + where st2 = newSt tr skel2 + -- + newSt :: Maybe TagElem -> PolState -> PolState + newSt t skel2 = PolSt pr2 ex2 (po2:skelPo2) + where + PolSt pr2 ex2 skelPo2 = skel2 + po2 = po1 !+! (Map.findWithDefault (ival 0) fk pol) + pol = case t of Nothing -> Map.empty + Just t2 -> tpolarities t2 + in result +\end{code} + +% ---------------------------------------------------------------------- +\subsection{Pruning} +\label{sec:automaton_pruning} +% ---------------------------------------------------------------------- + +Any path through the automaton which does not lead to final +polarity of zero sum can now be eliminated. We do this by stepping +recursively backwards from the final states: + +\begin{code} +prune :: PolAut -> PolAut +prune aut = + let theStates = states aut + final = finalSt aut + -- (remember that states is a list of lists) + lastStates = head theStates + nextStates = tail theStates + nonFinal = (lastStates \\ final) + -- the helper function will rebuild the state list + firstAut = aut { states = [] } + pruned = prune' (nonFinal:nextStates) firstAut + -- re-add the final state! + statesPruned = states pruned + headPruned = head statesPruned + tailPruned = tail statesPruned + in if (null theStates) + then aut + else pruned { states = (headPruned ++ final) : tailPruned } +\end{code} + +The pruning algorithm takes as arguments a list of states to process. +Among these, any state which does not have outgoing transitions is +placed on the blacklist. We remove all transitions to the blacklist and +all states that only transition to the blacklist, and then we repeat +pruning, with a next batch of states. + +Finally, we return the pruned automaton. Note: in order for this to +work, it is essential that the final states are *not* included in the +list of states to process. + +\begin{code} +prune' :: [[PolState]] -> PolAut -> PolAut +prune' [] oldAut = oldAut { states = reverse $ states oldAut } +prune' (sts:next) oldAut = + let -- calculate the blacklist + oldT = transitions oldAut + oldSt = states oldAut + transFrom st = Map.lookup st oldT + blacklist = filter (isNothing.transFrom) sts + -- given a st: filter out all transitions to the blacklist + allTrans = Map.toList $ transitions oldAut + -- delete all transitions to the blacklist + miniTrim = Map.filterWithKey (\k _ -> not (k `elem` blacklist)) + -- extra cleanup: delete from map states that only transition to the blacklist + trim = Map.filterWithKey (\k m -> not (k `elem` blacklist || Map.null m)) + -- execute the kill and miniKill filters + newT = trim $ Map.fromList [ (st2, miniTrim m) | (st2,m) <- allTrans ] + -- new list of states and new automaton + newSts = sts \\ blacklist + newAut = oldAut { transitions = newT, + states = newSts : oldSt } + {- + -- debugging code + debugstr = "blacklist: [\n" ++ debugstr' ++ "]" + debugstr' = concat $ intersperse "\n" $ map showSt blacklist + showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po + showPr (_,pr,_) = pr ++ " " + showPo po = concat $ intersperse "," $ map show po + showEx ex = if (null ex) then "" else (showSem ex) + -} + -- recursive step + in if null blacklist + then oldAut { states = (reverse oldSt) ++ (sts:next) } + else prune' next newAut +\end{code} + +% ==================================================================== +\section{Zero-literal semantics} +\label{sec:multiuse} +\label{semantic_weights} +\label{sec:nullsem} +\label{sec:co-anchors} +% ==================================================================== + +Lexical items with a \jargon{null semantics} typically correspond to +functions words: complementisers \natlang{(John likes \textbf{to} +read.)}, subcategorised prepositions \natlang{(Mary accuses John +\textbf{of} cheating.)}. Such items need not be lexical items at all. +We can exploit TAG's support for trees with multiple anchors, by +treating them as co-anchors to some primary lexical item. The English +infinitival \natlang{to}, for example, can appear in the tree +\tautree{to~take} as \koweytree{s(comp(to),v(take),np$\downarrow$)}. + +On the other hand, pronouns have a \jargon{zero-literal} semantics, one +which is not null, but which consists only of a variable index. For +example, the pronoun \natlang{she} in (\ref{ex:pronoun_pol_she}) has +semantics \semexpr{s} and in (\ref{ex:pronoun_pol_control}), +\natlang{he} has the semantics \semexpr{j}. + +{\footnotesize +\eenumsentence{\label{ex:pronoun_pol} +\item \label{ex:pronoun_pol_sue} +\semexpr{joe(j), sue(s), book(b), lend(l,j,b,s), boring(b) } +\\ \natlang{Joe lends Sue a boring book.} + +% Note for visually impaired readers: ignore anything with \color{white}. +% It is used as a form of indentation to help sighted users. +\item \label{ex:pronoun_pol_she} +\semexpr{joe(j), {\color{white}sue(s),} book(b), lend(l,j,b,s), boring(b) } +\\ \natlang{Joe lends her a boring book.} +} +\eenumsentence{\label{ex:pronoun_pol_control} +\item[{\color{white}a.}] \label{ex:pronoun_pol_control_inf} +\semexpr{joe(j), sue(s), leave(l,j), promise(p,j,s,l)} +\\ \natlang{Joe promises Sue to leave.} +\\ or \natlang{Joe promises Sue that he would leave.} +}} + +In figure \ref{fig:polarity_automaton_zerolit_bad}, we compare the +construction of polarity automata for (\ref{ex:pronoun_pol_sue}, left) +and (\ref{ex:pronoun_pol_she}, right). Building an automaton for +(\ref{ex:pronoun_pol_she}) fails because \tautree{sue} is not available +to cancel the negative polarities for \tautree{lends}; instead, a +pronoun must be used to take its place. The problem is that the +selection of a lexical items is only triggered when the construction +algorithm visits one of its semantic literals. Since pronoun semantics +have zero literals, they are \emph{never} selected. Making pronouns +visible to the construction algorithm would require us to count the +indices from the input semantics. Each index refers to an entity. This +entity must be ``consumed'' by a syntactic functor (e.g. a verb) and +``provided'' by a syntactic argument (e.g. a noun). + +%\footnote{This also holds true for sentences like \natlang{Joe sings +%badly and Sue sings well}, \semexpr{sing(s1,j) good(s1), sing(s2,m), +%bad(s2)} because each usage of \natlang{sings} actually corresponds to a +%different lexical item, \tautree{sings1} with the semantics +%\semexpr{sings(s1,j)} and \tautree{sings2} with \semexpr{sings(s2,m)}.}. + +\begin{figure}[htpb] +\begin{center} +\includegraphics[scale=0.25]{images/zeroaut-noun.pdf} +\includegraphics[scale=0.25]{images/zeroaut-sans.pdf} +\end{center} +\vspace{-0.4cm} +\caption{Difficulty with zero-literal semantics.} +\label{fig:polarity_automaton_zerolit_bad} +\end{figure} + +We make this explicit by annotating the semantics of the lexical input +(that is the set of lexical items selected on the basis of the input +semantics) with a form of polarities. Roughly, nouns provide +indices\footnote{except for predicative nouns, which like verbs, are +semantic functors} ($+$), modifiers leave them unaffected, and verbs +consume them ($-$). Predicting pronouns is then a matter of counting +the indices. If the positive and negative indices cancel each other +out, no pronouns are required. If there are more negative indices than +positive ones, then as many pronouns are required as there are negative +excess indices. In the table below, we show how the example semantics +above may be annotated and how many negative excess indices result: + +\begin{center} +{\footnotesize +\begin{tabular}{|l|r|r|r|} +\hline +\multicolumn{1}{|c|}{\bf semantics} & +{\bf \tt b} & +{\bf \tt j} & +{\bf \tt s} \\ +\hline +\semexpr{joe(+j) sue(+s) book(+b) lend(l,-j,-b,-s) boring(b)} & +\semexpr{0} & +\semexpr{0} & +\semexpr{0} \\ +\hline +\semexpr{joe(+j) {\color{white}sue(+s)} book(+b) lend(l,-j,-b,-s) boring(b)} & +\semexpr{0} & +\semexpr{0} & +\semexpr{1} \\ +\hline +\semexpr{joe(+j) sue(+s) leave(l,-j,-s) promise(p,{\color{white}-}j,-s,l)} & +\semexpr{0} & +\semexpr{0} & +\semexpr{0} \\ +\hline +\semexpr{joe(+j) sue(+s) leave(l,-j,-s) promise(p,-j,-s,l)} & +\semexpr{0} & +\semexpr{1} & +\semexpr{0} \\ +\hline +\end{tabular} +} +\end{center} + +Counting surplus indices allows us to establish the number of pronouns +used and thus gives us the information needed to build polarity +automata. We implement this by introducing a virtual literal for +negative excess index, and having that literal be realised by pronouns. +Building the polarity automaton as normal yields lexical combinations +with the required number of pronouns, as in figure +\ref{fig:polarity_automaton_zerolit}. + +\begin{figure}[htpb] +\begin{center} +\includegraphics[scale=0.25]{images/zeroaut-pron.pdf} +\end{center} +\vspace{-0.4cm} +\caption{Constructing a polarity automaton with zero-literal semantics.} +\label{fig:polarity_automaton_zerolit} +\end{figure} + +\label{different_sem_annotations} +The sitation is more complicated where the lexical input +contains lexical items with different annotations for the same +semantics. For instance, the control verb \natlang{promise} has two +forms: one which solicits an infinitive as in \natlang{promise to +leave}, and one which solicits a declarative clause as in +\natlang{promise that he would leave}. This means two different counts +of subject index \semexpr{j} in (\ref{ex:pronoun_pol_control}) : zero +for the form that subcategorises for the infinitive, or one for the +declarative. But to build a single automaton, these counts must be +reconciled, i.e., how many virtual literals do we introduce for +\semexpr{j}, zero or one? The answer is to introduce enough virtual +literals to satisfy the largest demand, and then use the multi-literal +extension to support alternate forms with a smaller demand. To handle +example (\ref{ex:pronoun_pol_control}), we introduce one virtual literal +for \semexpr{j} so that the declarative form can be produced, and treat +the soliciting \natlang{promise} as though its semantics includes that +literal along with its regular semantics (figure +\ref{fig:polarity_automaton_zerolit_promise}). In other words, the +infinitive-soliciting form is treated as if it already fulfils the role +of a pronoun, and does not need one in its lexical combination. + +\begin{figure}[htpb] +\begin{center} +\includegraphics[scale=0.25]{images/zeroaut-promise.pdf} +\end{center} +\vspace{-0.4cm} +\caption{Constructing a polarity automaton with zero-literal semantics.} +\label{fig:polarity_automaton_zerolit_promise} +\end{figure} + +We insert pronouns into the input semantics using the following process: +\begin{enumerate} +\item For each literal in the input semantics, establish the + smallest charge for each of its semantic indices. +\item Cancel out the polarities for every index in the input + semantics. +\item Compensate for any uncancelled negative polarities by an + adding an additional literal to the input semantics -- a pronoun -- + for every negative charge. +\item Finally, deal with the problem of lexical items who require fewer + pronouns than predicted by inserting the excess pronouns in their extra + literal semantics (see page \pageref{different_sem_annotations}) +\end{enumerate} + +\begin{code} +type PredLite = (String,[GeniVal]) -- handle is head of arg list +type SemWeightMap = Map.Map PredLite SemPols + +-- | Returns a modified input semantics and lexical selection in which pronouns +-- are properly accounted for. +fixPronouns :: (Sem,[TagElem]) -> (Sem,[TagElem]) +fixPronouns (tsem,cands) = + let -- part 1 (for each literal get smallest charge for each idx) + getpols :: TagElem -> [ (PredLite,SemPols) ] + getpols x = zip [ (show p, h:as) | (h,p,as) <- tsemantics x ] (tsempols x) + sempols :: [ (PredLite,SemPols) ] + sempols = concatMap getpols cands + usagemap :: SemWeightMap + usagemap = Map.fromListWith (zipWith min) sempols + -- part 2 (cancel sem polarities) + chargemap :: Map.Map GeniVal Int -- index to charge + chargemap = Map.fromListWith (+) $ concatMap clump $ Map.toList usagemap + where clump ((_,is),ps) = zip is ps + -- part 3 (adding extra semantics) + indices = concatMap fn (Map.toList chargemap) + where fn (i,c) = replicate (0-c) i + -- the extra columns + extraSem = map indexPred indices + tsem2 = sortSem (tsem ++ extraSem) + -- zero-literal semantic items to realise the extra columns + zlit = filter (null.tsemantics) cands + cands2 = (cands \\ zlit) ++ (concatMap fn indices) + where fn i = map (tweak i) zlit + tweak i x = assignIndex i $ x { tsemantics = [indexPred i] } + -- part 4 (insert excess pronouns in tree sem) + comparefn :: GeniVal -> Int -> Int -> [GeniVal] + comparefn i ct cm = if (cm < ct) then extra else [] + where maxNeeded = Map.findWithDefault 0 i chargemap -- cap the number added + extra = replicate (min (0 - maxNeeded) (ct - cm)) i + comparePron :: (PredLite,SemPols) -> [GeniVal] + comparePron (lit,c1) = concat $ zipWith3 comparefn idxs c1 c2 + where idxs = snd lit + c2 = Map.findWithDefault [] lit usagemap + addextra :: TagElem -> TagElem + addextra c = c { tsemantics = sortSem (sem ++ extra) } + where sem = tsemantics c + extra = map indexPred $ concatMap comparePron (getpols c) + cands3 = map addextra cands2 + in (tsem2, cands3) + +-- | Builds a fake semantic predicate that the index counting mechanism uses to +-- represent extra columns. +indexPred :: GeniVal -> Pred +indexPred x = (x, GAnon, []) + +-- Returns True if the given literal was introduced by the index counting mechanism +isExtraCol :: Pred -> Bool +isExtraCol (_,GAnon,[]) = True +isExtraCol _ = False +\end{code} + +\paragraph{assignIndex} is a useful way to restrict the behaviour of +null semantic items like pronouns using the information generated by +the index counting mechanism. The problem with null semantic items +is that their indices are not set, which means that they could +potentially combine with any other tree. To make things more +efficient, we can set the index of these items and thus reduce the +number of spurious combinations. + +Notes +\begin{itemize} +%\item These combinations could produce false results if the +%input has to use multiple pronouns. For example, if you wanted to say +%something like \natlang{John promises Mary to convince Paul to give her +% his book}, these combinations could instead produce \natlang{give him +% \textbf{her} book}. +\item This function works by FS unification on the root node of the + tree with the \fs{\it idx:i\\}. If unification is not possible, + we simply return the tree as is. +\item This function renames the tree by appending the index to its name +\end{itemize} + +\begin{code} +assignIndex :: GeniVal -> TagElem -> TagElem +assignIndex i te = + let idxfs = [ (__idx__, i) ] + oldt = ttree te + oldr = root oldt + tfup = gup oldr + -- + in case unifyFeat tfup idxfs of + Nothing -> te + Just (gup2, sub) -> replace sub $ te { ttree = newt } + where newt = rootUpd oldt $ oldr { gup = gup2 } +\end{code} + + +% ==================================================================== +\section{Further optimisations} +% ==================================================================== + +\subsection{Lexical filtering} \label{fn:detectIdxConstraints} + +Lexical filtering allows the user to constrain the lexical selection +to only those items that contain a certain property, for example, the +realising an item as a cleft. + +The idea is that the user provides an input like +\verb$idxconstraints:[cleft:j]$, +which means that the lexical selection must include exactly one tree +with the property cleft:j in its interface. This mechanism works as +pre-processing step after lexical selection and before polarity +automaton construction, in conjuction with the ExtraPolarities +mechanism. What we do is + +\begin{enumerate} +\item Preprocess the lexically selected trees; any tree which has a + a desired property (e.g. cleft:j) in its interface is assigned + a positive polarity for that property (+cleft:j) +\item Add all the index constraints as negative extra polarities (-cleft:j) +\end{enumerate} + +Note: we assume the index constraints and interface are sorted; also, we +prefix the index constraint polarities with a ``.'' because they are likely to +be very powerful filters and we would like them to be used first. + +\begin{code} +detectIdxConstraints :: Flist -> Flist -> PolMap +detectIdxConstraints cs interface = + let matches = intersect cs interface + matchStr = map showIdxConstraint matches + in Map.fromList $ zip matchStr ((repeat.ival) 1) + +declareIdxConstraints :: Flist -> PolMap +declareIdxConstraints = Map.fromList . (map declare) where + declare c = (showIdxConstraint c, minusone) + minusone = ival (-1) + +showIdxConstraint :: AvPair -> String +showIdxConstraint = ('.' :) . showAv +\end{code} + +\subsection{Automatic detection} + +Automatic detection is not an optimisation in itself, but a means to +make grammar development with polarities more convenient. + +\paragraph{Which attributes should we use?} Our detection process looks for +attributes which are defined on \emph{all} subst and root nodes of the +lexically selected items. Note that this should typically give you the +\verb!cat! and \verb!idx! polarities. + +\begin{code} +detectPolFeatures :: [TagElem] -> [String] +detectPolFeatures tes = + let -- only initial trees need be counted; in aux trees, the + -- root node is implicitly canceled by the foot node + rfeats, sfeats :: [Flist] + rfeats = map (gdown.root.ttree) $ filter (\t -> ttype t == Initial) tes + sfeats = [ concat s | s <- map substTops tes, (not.null) s ] + -- + attrs :: Flist -> [String] + attrs avs = [ a | (a,v) <- avs, isConst v ] + theAttributes = map attrs $ rfeats ++ sfeats + in if null tes then [] else foldr1 intersect theAttributes + +-- FIXME: temporary HACKY code - delete me as soon as possible (written +-- 2006-03-30 +-- +-- only initial trees need be counted; in aux trees, the +-- root node is implicitly canceled by the foot node +detectSansIdx :: [TagElem] -> [TagElem] +detectSansIdx = + let rfeats t = (gdown.root.ttree) t + feats t | ttype t == Initial = concat $ (rfeats t) : (substTops t) + feats t = concat $ substTops t + attrs avs = [ a | (a,v) <- avs, isConst v ] + hasIdx t = __idx__ `elem` (attrs.feats $ t) || (ttype t /= Initial && (null $ substTops t)) + in filter (not.hasIdx) +\end{code} + +\paragraph{The polarity values} +First the simplified explanation: we assign every tree with a $-1$ charge for +every category for every substitution node it has. Additionally, we assign +every initial tree with a $+1$ charge for the category of its root node. So +for example, the tree s(n$\downarrow$, cl$\downarrow$, v(aime), n$\downarrow$) +should have the following polarities: s +1, cl -1, n -2. These charges are +added to any that previously been defined in the grammar. + +Now what really happens: we treat automaton polarities as intervals, not +as single integers! For the most part, nothing changes from the simplified +explanation. Where we added a $-1$ charge before, we now add a $(-1,-1)$ +charge. Similarly, we where added a $+1$ charge, we now add $(1,1)$. So +what's the point of all this? It helps us deal with atomic disjunction. + +\subparagraph{Atomic disjunction} Say we encounter a substitution node +whose category is either cl or n. What we do is add the polarities +$cl (-1,0), n (-1,0)$ which means that there are anywhere from -1 to +0 cl, and for n. +FIXME: What kind of sucks about all this though is that this slightly worsens +the filter because it allows for both cl and n to be $-1$ (or $0$) at the same +time. It would be nice to have some kind of mutual exclusion working. + +\begin{code} +detectPols :: [TagElem] -> [TagElem] +detectPols = map detectPols' + +detectPols' :: TagElem -> TagElem +detectPols' te = + let otherFeats = [] --, __idx__ ] + feats = __cat__ : otherFeats + -- + rootdown = (gdown.root.ttree) te + rootup = (gup.root.ttree) te + rstuff :: [[String]] + rstuff = getval __cat__ rootup -- cat is special, see below + ++ (concatMap (\v -> getval v rootdown) otherFeats) + -- re:above, cat it is considered global to the whole tree + -- to be robust, we grab it from the top feature + substuff :: [[String]] + substuff = concatMap (\v -> concatMap (getval v) (substTops te)) feats + -- + -- substs nodes only + commonPols :: [ (String,Interval) ] + commonPols = polarise (-1) substuff + -- substs and roots + pols :: [ (String,Interval) ] + pols = case ttype te of + Initial -> commonPols ++ polarise 1 rstuff + _ -> commonPols + -- + oldfm = tpolarities te + in te { tpolarities = foldr addPol oldfm pols } + +__cat__, __idx__ :: String +__cat__ = "cat" +__idx__ = "idx" + +getval :: String -> Flist -> [[String]] +getval att fl = + case [ v | (a,v) <- fl, a == att ] of + [] -> error $ "[polarities] No instances of " ++ att ++ " in " ++ showFlist fl ++ "." + vs -> if all isConst vs + then map (prefixWith att . fromGConst) vs + else error $ "[polarities] Not all values for feature " ++ att ++ " are instantiated." + +toZero :: Int -> Interval +toZero x | x < 0 = (x, 0) + | otherwise = (0, x) + +prefixWith :: String -> [String] -> [String] +prefixWith att = map (\x -> att ++ ('_' : x)) + +polarise :: Int -> [[String]] -> [ (String, Interval) ] +polarise i = concatMap fn + where + fn [x] = [ (x, one) ] + fn amb = for amb $ \x -> (x, oneZero) + one = ival i + oneZero = toZero i + +for :: [a] -> (a -> b) -> [b] +for = flip map + +substTops :: TagElem -> [Flist] +substTops t = [ gup gn | gn <- (flatten.ttree) t, gtype gn == Subs ] +\end{code} + +\subsection{Chart sharing} + +Chart sharing is based on the idea that instead of performing a +seperate generation task for each automaton path, we should do +single generation task, but annotate each tree with set of the +automata paths it appears on. We then allow trees on the +same paths to be compared only if they are on the same path. +Note: chart sharing involves some mucking around with the generation +engine (see page \pageref{fn:Builder:preInit}) + +\begin{code} +-- | Given a list of paths (i.e. a list of list of trees) +-- return a list of trees such that each tree is annotated with the paths it +-- belongs to. +detectPolPaths :: [[TagElem]] -> [(TagElem,BitVector)] +detectPolPaths paths = + let pathFM = detectPolPaths' Map.empty 0 paths + lookupTr k = Map.findWithDefault 0 k pathFM + in map (\k -> (k, lookupTr k)) $ Map.keys pathFM + +type PolPathMap = Map.Map TagElem BitVector +detectPolPaths' :: PolPathMap -> Int -> [[TagElem]] -> PolPathMap + +detectPolPaths' accFM _ [] = accFM +detectPolPaths' accFM counter (path:ps) = + let currentBits = shiftL 1 counter -- shift counter times the 1 bit + fn f [] = f + fn f (t:ts) = fn (Map.insertWith (.|.) t currentBits f) ts + newFM = fn accFM path + in detectPolPaths' newFM (counter+1) ps + +-- | Render the list of polarity automaton paths as a string +showPolPaths :: BitVector -> String +showPolPaths paths = + let pathlist = showPolPaths' paths 1 + in concat $ intersperse ", " $ map show pathlist + +showPolPaths' :: BitVector -> Int -> [Int] +showPolPaths' 0 _ = [] +showPolPaths' bv counter = + if b then (counter:next) else next + where b = testBit bv 0 + next = showPolPaths' (shiftR bv 1) (counter + 1) +\end{code} + +\subsection{Semantic sorting} + +To minimise the number of states in the polarity automaton, we could +also sort the literals in the target semantics by the number of +corresponding lexically selected items. The idea is to delay branching +as much as possible so as to mimimise the number of states in the +automaton. + +Let's take a hypothetical example with two semantic literals: +bar (having two trees with polarties 0 and +1). +foo (having one tree with polarity -1) and +If we arbitrarily explored bar before foo (no semantic sorting), the +resulting automaton could look like this: + +\begin{verbatim} + bar foo +(0)--+---(0)------(-1) + | + +---(1)------(0) +\end{verbatim} + +With semantic sorting, we would explore foo before bar because foo has +fewer items and is less likely to branch. The resulting automaton +would have fewer states. + +\begin{verbatim} + foo bar +(0)-----(-1)--+---(-1) + | + +---(0) +\end{verbatim} + +The hope is that this would make the polarity automata a bit +faster to build, especially considering that we are working over +multiple polarity keys. + +Note: we have to take care to count each literal for each lexical +entry's semantics or else the multi-literal semantic code will choke. + +\begin{code} +sortSemByFreq :: Sem -> [TagElem] -> Sem +sortSemByFreq tsem cands = + let counts = map lenfn tsem + lenfn l = length $ filter fn cands + where fn x = l `elem` (tsemantics x) + -- note: we introduce an extra hack to push + -- index-counted extra columns to the end; just for UI reasons + sortfn a b + | isX a && isX b = compare (snd a) (snd b) + | isX a = GT + | isX b = LT + | otherwise = compare (snd a) (snd b) + where isX = isExtraCol.fst + sorted = sortBy sortfn $ zip tsem counts + in (fst.unzip) sorted +\end{code} + +% ---------------------------------------------------------------------- +\section{Types} +% ---------------------------------------------------------------------- + +\begin{code} +type SemMap = Map.Map Pred [TagElem] +type PolMap = Map.Map String Interval + +-- | Adds a new polarity item to a 'PolMap'. If there already is a polarity +-- for that item, it is summed with the new polarity. +addPol :: (String,Interval) -> PolMap -> PolMap +addPol (p,c) m = Map.insertWith (!+!) p c m + +-- | Ensures that all states and transitions in the polarity automaton +-- are unique. This is a slight optimisation so that we don't have to +-- repeatedly check the automaton for state uniqueness during its +-- construction, but it is essential that this check be done after +-- construction +nubAut :: (Ord ab, Ord st) => NFA st ab -> NFA st ab +nubAut aut = + aut { + transitions = Map.map (\e -> Map.map nub e) (transitions aut) + } +\end{code} + +\subsection{Polarity NFA} + +We can define the polarity automaton as a NFA, or a five-tuple +$(Q, \Sigma, \delta, q_0, q_n)$ such that + +\begin{enumerate} +\item $Q$ is a set of states, each state being a tuple $(i,e,p)$ where $i$ +is an integer (representing a single literal in the target semantics), +$e$ is a list of extra literals +which are known by the state, and $p$ is a polarity. +\item $\Sigma$ is the union of the sets of candidate trees for all +propositions +\item $q_0$ is the start state $(0,[0,0])$ which does not correspond to any +propositions and is used strictly as a starting point. +\item $q_n$ is the final state $(n,[x,y])$ which corresponds to the last +proposition, with polarity $x \leq 0 \leq y$. +\item $\delta$ is the transition function between states, which we +define below. +\end{enumerate} + +Note: +\begin{itemize} +\item For convenience during automaton intersection, we actually define + the states as being $(i, [(p_x,p_y)])$ where $[(p_x,p_y)]$ is a list of + polarity intervals. +\item We use integer $i$ for each state instead of literals directly, + because it is possible for the target semantics to contain the + same literal twice (at least, with the index counting mechanism + in place) +\end{itemize} + +\begin{code} +data PolState = PolSt Int [Pred] [(Int,Int)] + -- ^ position in the input semantics, extra semantics, + -- polarity interval + deriving (Eq) +type PolTrans = TagElem +type PolAut = NFA PolState PolTrans +type PolTransFn = Map.Map PolState (Map.Map PolState [Maybe PolTrans]) + +instance Show PolState + where show (PolSt pr ex po) = show pr ++ " " ++ showSem ex ++ show po +-- showPred pr ++ " " ++ showSem ex ++ show po + +instance Ord PolState where + compare (PolSt pr1 ex1 po1) (PolSt pr2 ex2 po2) = + let prC = compare pr1 pr2 + expoC = compare (ex1,po1) (ex2,po2) + in if (prC == EQ) then expoC else prC +\end{code} + +We include also some fake states which are useful for general +housekeeping during the main algortihms. + +\begin{code} +fakestate :: Int -> [Interval] -> PolState +fakestate s pol = PolSt s [] pol --PolSt (0, s, [""]) [] pol + +-- | an initial state for polarity automata +polstart :: [Interval] -> PolState +polstart pol = fakestate 0 pol -- fakestate "START" pol +\end{code} + +% ---------------------------------------------------------------------- +\section{Display code} +\label{sec:display_pol} +% ---------------------------------------------------------------------- + +\begin{code} +-- | 'showLite' is like Show but it's only used for debugging +-- TODO: is this true? +class ShowLite a where + showLite :: a -> String + +instance (ShowLite a) => ShowLite [a] where + showLite x = "[" ++ (concat $ intersperse ", " $ map showLite x) ++ "]" +instance (ShowLite a, ShowLite b) => ShowLite (a,b) where + showLite (x,y) = "(" ++ (showLite x) ++ "," ++ (showLite y) ++ ")" + +instance ShowLite Int where showLite = show +instance ShowLite Char where showLite = show +\end{code} + +%\begin{code} +%instance (Show st, ShowLite ab) => ShowLite (NFA st ab) where +% showLite aut = +% concatMap showTrans $ toList (transitions aut) +% where showTrans ((st1, x), st2) = show st1 ++ showArrow x +% ++ show st2 ++ "\n" +% showArrow x = " --" ++ showLite x ++ "--> " +% -- showSt (PolSt pr po) = show po +%\end{code} + +\begin{code} +instance ShowLite TagElem where + showLite = idname + +{- +-- | Display a SemMap in human readable text. +showLiteSm :: SemMap -> String +showLiteSm sm = + concatMap showPair $ toList sm + where showPair (pr, cs) = showPred pr ++ "\t: " ++ showPair' cs ++ "\n" + showPair' [] = "" + showPair' (te:cs) = tlIdname te ++ "[" ++ showLitePm (tpolarities te) ++ "]" + ++ " " ++ showPair' cs +-} + +-- | Display a PolMap in human-friendly text. +-- The advantage is that it displays fewer quotation marks. +showLitePm :: PolMap -> String +showLitePm pm = + let showPair (f, pol) = showInterval pol ++ f + in concat $ intersperse " " $ map showPair $ Map.toList pm +\end{code} diff --git a/src/NLP/GenI/Simple/SimpleBuilder.lhs b/src/NLP/GenI/Simple/SimpleBuilder.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Simple/SimpleBuilder.lhs @@ -0,0 +1,1205 @@ +% 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. + +\chapter{SimpleBuilder} +\label{cha:SimpleBuilder} + +A SimpleBuilder is a Builder which constructs derived trees using a +simple agenda control mechanism and two-phase realisation (substitution +before adjunction). There is no packing strategy whatsoever; each chart +item is a derived tree. + +\begin{code} +{-# LANGUAGE LiberalTypeSynonyms #-} +module NLP.GenI.Simple.SimpleBuilder ( + -- Types + Agenda, AuxAgenda, Chart, SimpleStatus, SimpleState, + SimpleItem(..), + + -- From SimpleStatus + simpleBuilder_1p, simpleBuilder_2p, simpleBuilder, + theAgenda, theAuxAgenda, theChart, theResults, + initSimpleBuilder, + addToAgenda, addToChart, + genconfig, + +#ifndef DISABLE_GUI + SimpleGuiItem(..), + theTrash, unpackResult, +#endif + ) +where +\end{code} + + +\ignore{ +\begin{code} +import Control.Monad (when, liftM2) +import Control.Monad.State + (get, put, modify, gets, runState, execStateT) + +import Data.List + (partition, delete, foldl', unfoldr, sortBy) +import Data.Maybe (isJust, isNothing) +import Data.Ord (comparing) +import Data.Bits +import qualified Data.Map as Map +import Data.Tree + +import NLP.GenI.Statistics (Statistics) + +import NLP.GenI.Automaton ( automatonPaths, NFA(..), addTrans ) +import NLP.GenI.Btypes + ( Ptype(Initial,Auxiliar) + , Replacable(..), replaceOneAsMap + , GNode(..), NodeName + , root, foot + , plugTree, spliceTree + , unifyFeat, Flist, Subst, mergeSubst + ) +import NLP.GenI.Builder ( + incrCounter, num_iterations, num_comparisons, chart_size, + SemBitMap, defineSemanticBits, semToBitVector, bitVectorToSem, + DispatchFilter, (>-->), condFilter, nullFilter, + semToIafMap, IafAble(..), IafMap, fromUniConst, getIdx, + recalculateAccesibility, iafBadSem, ts_iafFailure, + ) +import qualified NLP.GenI.Builder as B + +import NLP.GenI.Tags (TagElem, TagSite(TagSite), + tagLeaves, tidnum, + ttree, ttype, tsemantics, + detectSites, + TagDerivation, + ts_rootFeatureMismatch, + ) +import NLP.GenI.Configuration +import NLP.GenI.General + ( BitVector, mapMaybeM, mapTree', geniBug, preTerminals, ) + +#ifndef DISABLE_GUI +import NLP.GenI.Btypes ( GType(Other), sortSem, Sem, gnnameIs ) +import NLP.GenI.General ( repList, ) +import NLP.GenI.Tags ( idname, + ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure, + ) +#endif +\end{code} +} + +% -------------------------------------------------------------------- +\section{The Builder interface} +% -------------------------------------------------------------------- + +Here is our implementation of Builder. + +\begin{code} +type SimpleBuilder = B.Builder SimpleStatus SimpleItem Params +simpleBuilder_2p, simpleBuilder_1p :: SimpleBuilder +simpleBuilder_2p = simpleBuilder True +simpleBuilder_1p = simpleBuilder False + +simpleBuilder :: Bool -> SimpleBuilder +simpleBuilder twophase = B.Builder + { B.init = initSimpleBuilder twophase + , B.step = if twophase then generateStep_2p else generateStep_1p + , B.stepAll = B.defaultStepAll (simpleBuilder twophase) + , B.finished = \s -> (null.theAgenda) s && (not twophase || step s == Auxiliar) + , B.unpack = unpackResults.theResults + , B.partial = unpackResults.partialResults + } +\end{code} + +% -------------------------------------------------------------------- +\section{Key types} +% -------------------------------------------------------------------- + +\begin{code} +type Agenda = [SimpleItem] +type AuxAgenda = [SimpleItem] +type Chart = [SimpleItem] +#ifndef DISABLE_GUI +type Trash = [SimpleItem] +#endif +\end{code} + +\subsection{SimpleState and SimpleStatus} + +The \fnreflite{SimpleState} is a state monad where the state being +thread through is a \fnreflite{SimpleStatus}. The two are named +deliberately alike to indicate their close relationship. + +To prevent confusion, we ought to keep a somewhat consistent naming +scheme across the builders: FooState for the state monad, FooStatus for +the state monad's ``contents'', and FooItem for the chart items +manipulated. + +Note the theTrash is not actually essential to the operation of the +generator; it is for pratical debugging of grammars. Instead of +trees dissapearing off the face of the debugger; they go into the +trash where the user can inspect them and try to figure out why they +went wrong. + +\begin{code} +type SimpleState a = B.BuilderState SimpleStatus a + +data SimpleStatus = S + { theAgenda :: Agenda + , theAuxAgenda :: AuxAgenda + , theChart :: Chart +#ifndef DISABLE_GUI + , theTrash :: Trash +#endif + , theResults :: [SimpleItem] + , theIafMap :: IafMap -- for index accessibility filtering + , tsem :: BitVector + , step :: Ptype + , gencounter :: Integer + , genconfig :: Params + -- we keep a SemBitMap strictly to help display the semantics + , semBitMap :: SemBitMap + } + deriving Show +\end{code} + +\subsubsection{SimpleStatus updaters} + +\begin{code} +addToAgenda :: SimpleItem -> SimpleState () +addToAgenda te = do + modify $ \s -> s{theAgenda = te:(theAgenda s) } + +updateAgenda :: Agenda -> SimpleState () +updateAgenda a = do + modify $ \s -> s{theAgenda = a} + +addToAuxAgenda :: SimpleItem -> SimpleState () +addToAuxAgenda te = do + s <- get + -- each new tree gets a unique id... this makes comparisons faster + let counter = (gencounter s) + 1 + te2 = te { siId = counter } + put s{gencounter = counter, + theAuxAgenda = te2:(theAuxAgenda s) } + +addToChart :: SimpleItem -> SimpleState () +addToChart te = do + modify $ \s -> s { theChart = te:(theChart s) } + incrCounter chart_size 1 + +#ifndef DISABLE_GUI +addToTrash :: SimpleItem -> String -> SimpleState () +addToTrash te err = do + let te2 = modifyGuiStuff (\g -> g { siDiagnostic = err:(siDiagnostic g) }) te + modify $ \s -> s { theTrash = te2 : (theTrash s) } +#endif + +addToResults :: SimpleItem -> SimpleState () +addToResults te = do + modify $ \s -> s { theResults = te : (theResults s) } +\end{code} + +\subsection{SimpleItem} + +\begin{code} +data SimpleItem = SimpleItem + { siId :: ChartId + -- + , siSubstnodes :: ![TagSite] + , siAdjnodes :: ![TagSite] + -- + , siSemantics :: !BitVector + , siPolpaths :: !BitVector + -- for generation sans semantics + -- , siAdjlist :: [(String,Integer)] -- (node name, auxiliary tree id) + -- for index accesibility filtering (one-phase only) + , siAccesible :: [ String ] -- it's acc/inacc/undetermined + , siInaccessible :: [ String ] -- that's why you want both + -- + -- | actually: a set of pre-terminals and their leaves + , siLeaves :: [(String, B.UninflectedDisjunction)] + , siDerived :: Tree String + , siRoot :: TagSite + , siFoot :: Maybe TagSite + -- + , siPendingTb :: [ TagSite ] -- only for one-phase + -- how was this item produced? + , siDerivation :: TagDerivation +#ifndef DISABLE_GUI + -- for the debugger only + , siGuiStuff :: SimpleGuiItem +#endif + } deriving Show + +#ifndef DISABLE_GUI +-- | Things whose only use is within the graphical debugger +data SimpleGuiItem = SimpleGuiItem + { siHighlight :: [String] -- ^ nodes to highlight + , siNodes :: [GNode] -- ^ actually a set + -- if there are things wrong with this item, what? + , siDiagnostic :: [String] + , siFullSem :: Sem + , siIdname :: String + } deriving Show + +modifyGuiStuff :: (SimpleGuiItem -> SimpleGuiItem) -> SimpleItem -> SimpleItem +modifyGuiStuff fn i = i { siGuiStuff = fn . siGuiStuff $ i } +#endif + +type ChartId = Integer + +instance Replacable SimpleItem where + replaceMap s i = + i { siSubstnodes = replaceMap s (siSubstnodes i) + , siAdjnodes = replaceMap s (siAdjnodes i) + , siLeaves = replaceMap s (siLeaves i) + , siRoot = replaceMap s (siRoot i) + , siFoot = replaceMap s (siFoot i) + , siPendingTb = replaceMap s (siPendingTb i) +#ifndef DISABLE_GUI + , siGuiStuff = replaceMap s (siGuiStuff i) +#endif + } + replaceOne = replaceOneAsMap + +#ifndef DISABLE_GUI +instance Replacable SimpleGuiItem where + replaceMap s i = i { siNodes = replaceMap s (siNodes i) } + replaceOne = replaceOneAsMap +#endif +\end{code} + +\begin{code} +{-# INLINE closedAux #-} + +-- | True if the chart item has no open substitution nodes +closed :: SimpleItem -> Bool +closed = null.siSubstnodes + +-- | True if the chart item is an auxiliary tree +aux :: SimpleItem -> Bool +aux = isJust . siFoot + +-- | True if both 'closed' and 'aux' are True +closedAux :: SimpleItem -> Bool +closedAux x = (aux x) && (closed x) + +adjdone :: SimpleItem -> Bool +adjdone = null.siAdjnodes + +siInitial :: SimpleItem -> Bool +siInitial = isNothing . siFoot +\end{code} + +% -------------------------------------------------------------------- +\section{Initialisation} +% -------------------------------------------------------------------- + +\begin{code} +-- | Creates an initial SimpleStatus. +initSimpleBuilder :: Bool -> B.Input -> Params -> (SimpleStatus, Statistics) +initSimpleBuilder twophase input config = + let cands = map (initSimpleItem bmap) $ B.inCands input + (sem,_,_) = B.inSemInput input + bmap = defineSemanticBits sem + -- FIXME: I don't know if this matters for one-phase + -- because of on-the-fly tb unification (in 2p), we + -- need an initial tb step that only addresses the + -- nodes with null adjunction constraints + simpleDp = if twophase then simpleDispatch_2p + else simpleDispatch_1p (isIaf config) + initialDp = dpTbFailure >--> simpleDp + -- + initS = S{ theAgenda = [] + , theAuxAgenda = [] + , theChart = [] +#ifndef DISABLE_GUI + , theTrash = [] +#endif + , theResults = [] + , semBitMap = bmap + , tsem = semToBitVector bmap sem + , theIafMap = semToIafMap sem + , step = Initial + , gencounter = toInteger $ length cands + , genconfig = config } + -- + in B.unlessEmptySem input config $ + runState (execStateT (mapM initialDp cands) initS) (B.initStats config) + + +initSimpleItem :: SemBitMap -> (TagElem, BitVector) -> SimpleItem +initSimpleItem bmap (teRaw,pp) = + let (te,tlite) = renameNodesWithTidnum teRaw in + case detectSites (ttree te) of + (snodes,anodes,nullAdjNodes) -> setIaf $ SimpleItem + { siId = tidnum te + , siSemantics = semToBitVector bmap (tsemantics te) + , siSubstnodes = snodes + , siAdjnodes = anodes + , siPolpaths = pp + -- for index accesibility filtering + , siAccesible = [] -- see below + , siInaccessible = [] + -- for generation sans semantics + -- , siAdjlist = [] + , siLeaves = tagLeaves te + , siDerived = tlite + , siRoot = ncopy.root $ theTree + , siFoot = if ttype te == Initial then Nothing + else Just . ncopy.foot $ theTree + , siDerivation = [] + -- note: see comment in initSimpleBuilder re: tb unification + , siPendingTb = nullAdjNodes + -- +#ifndef DISABLE_GUI + , siGuiStuff = initSimpleGuiItem te +#endif + } + where setIaf i = i { siAccesible = iafNewAcc i } + theTree = ttree te + +#ifndef DISABLE_GUI +initSimpleGuiItem :: TagElem -> SimpleGuiItem +initSimpleGuiItem te = SimpleGuiItem + { siHighlight = [] + , siNodes = flatten.ttree $ te + , siDiagnostic = [] + , siFullSem = tsemantics te + , siIdname = idname te } +#endif + +renameNodesWithTidnum :: TagElem -> (TagElem, Tree NodeName) +renameNodesWithTidnum te = + ( te { ttree = mapTree' renameNode theTree } + , mapTree' newName theTree ) + where theTree = ttree te + renameNode n = n { gnname = newName n } + newName n = gnname n ++ "-" ++ tidstr + tidstr = show . tidnum $ te +\end{code} + +% -------------------------------------------------------------------- +\section{Generate} +% -------------------------------------------------------------------- + +\subsection{One-phase generation} + +This is a standard chart-and-agenda mechanism, where each iteration +consists of picking an item off the agenda and combining it with +elements from the chart. + +\begin{code} +generateStep_1p :: SimpleState () +generateStep_1p = + do isDone <- gets (null.theAgenda) + iaf <- gets (isIaf.genconfig) + let dispatch = mapM (simpleDispatch_1p iaf) + if isDone + then return () + else do incrCounter num_iterations 1 + given <- selectGiven + -- do both substitution and adjunction + applySubstitution1p given >>= dispatch + passiveAdjunction1p given >>= dispatch + activeAdjunction1p given >>= dispatch + sansAdjunction1p given >>= dispatch + -- determine which of the res should go in the agenda + -- (monadic state) and which should go in the result (res') + addToChart given +\end{code} + +\subsection{Two-phase generation} + +Following \cite{carroll1999ecg}, we could also separate realisation into +two distinct phases. This requires that we maintain two seperate +agendas and process them sequentially, one loop after the other. See +\fnref{switchToAux} for details. + +\begin{itemize} +\item If both Agenda and AuxAgenda are empty then there is nothing to do, + otherwise, if Agenda is empty then we switch to the application of the + Adjunction rule. +\item After the rule is applied we classify solutions into those that are complete + and cover the semantics and those that don't. The first ones are returned + and added to the result, while the others are sent back to Agenda. +\item Notice that if we are applying the Substitution rule then the + current agenda item is added to the chart, otherwise it is deleted. +\end{itemize} + +\begin{code} +generateStep_2p :: SimpleState () +generateStep_2p = do + nir <- gets (null.theAgenda) + curStep <- gets step + -- this check may seem redundant with generate, but it's needed + -- to protect against a user who calls generateStep_2p on a finished + -- state + if (nir && curStep == Auxiliar) + then return () + else do incrCounter num_iterations 1 + -- this triggers exactly once in the whole process + if nir + then switchToAux + else generateStep_2p' + +generateStep_2p' :: SimpleState () +generateStep_2p' = + do -- choose an item from the agenda + given <- selectGiven + -- have we triggered the switch to aux yet? + curStep <- gets step + -- do either substitution or adjunction + res <- if (curStep == Initial) + then applySubstitution given + else liftM2 (++) (sansAdjunction2p given) (applyAdjunction2p given) + + -- determine which of the res should go in the agenda + -- (monadic state) and which should go in the result (res') + mapM simpleDispatch_2p res + -- put the given into the chart untouched + if (curStep == Initial) + then addToChart given + else when (adjdone given) $ trashIt given +\end{code} + +\subsection{Helpers for the generateSteps} + +\begin{code} +trashIt :: SimpleItem -> SimpleState () +#ifdef DISABLE_GUI +trashIt _ = return () +#else +trashIt item = + do s <- get + let bmap = semBitMap s + itemSem = siSemantics item + inputSem = tsem s + reason = if inputSem == itemSem + then "unknown reason!" + else ts_semIncomplete $ bitVectorToSem bmap $ inputSem `xor` itemSem + addToTrash item reason +#endif + +-- | Arbitrarily selects and removes an element from the agenda and +-- returns it. +selectGiven :: SimpleState SimpleItem +selectGiven = do + agenda <- gets theAgenda + case agenda of + [] -> geniBug "null agenda in selectGiven" + (a:atail) -> updateAgenda atail >> return a +\end{code} + +\subsection{Switching phases} + +\fnlabel{switchToAux} When all substitutions has been done, tags with +substitution nodes still open are deleted, then the auxiliars tags are put in +Chart and the (initial) tags in the repository are moved into the Agenda. The +step is then changed to Auxiliary + +\begin{code} +switchToAux :: SimpleState () +switchToAux = do + st <- get + let chart = theChart st + config = genconfig st + -- You might be wondering why we ignore the auxiliary trees in the + -- chart; this is because all the syntactically complete auxiliary + -- trees have already been filtered away by calls to classifyNew + initialT = filter siInitial chart + res1@(compT1, incompT1) = + partition (null.siSubstnodes) initialT + -- + auxAgenda = theAuxAgenda st + (compT2, incompT2) = + if semfiltered config + then semfilter (tsem st) auxAgenda compT1 + else res1 + -- + compT = compT2 + put st{ theAgenda = [] + , theAuxAgenda = [] + , theChart = auxAgenda + , step = Auxiliar} + -- the root cat filter by Claire + let switchFilter = + if rootcatfiltered config + then dpRootFeatFailure2 >--> dpToAgenda + else dpToAgenda + mapM switchFilter compT + -- toss the syntactically incomplete stuff in the trash +#ifndef DISABLE_GUI + mapM (\t -> addToTrash t ts_synIncomplete) incompT1 + mapM (\t -> addToTrash t "sem-filtered") incompT2 +#endif + return () +\end{code} + +\subsubsection{SemFilter Optimisation} +\label{sec:semfilter} + +The purpose of the semantic filter optimisation is to take full +advantage of Carroll's delayed adjunction. Consider the semantics +\semexpr{def(m), poor(m), brokenhearted(m), man(m), def(w), woman(w), +beautiful(w), heartless(w), rejects(w,m)}. At the switchToAux step, we +are left with the initial trees \natlang{man}, \natlang{woman}, \natlang{the + woman rejects the man}. + +It would be nice to filter out the structures \natlang{man} and \natlang{woman} +since we know that they are not going to be semantically complete even with +adjunction. More precisely, on the switch to adjunction, we do the following: + +\begin{itemize} +\item Take the union of the semantics of all auxiliary trees; which + we call $\phi^*$ +\item Delete any initial tree with semantics $\phi^s$ such that + $\phi^s \cup \phi^*$ is not the target semantics +\end{itemize} + +In other words, we delete all initial trees that cannot produce a semantically +complete result even with the help of auxiliary trees. + +FIXME: comment 2006-04-18: sem filter each polarity path separately (this is +more aggressive; it gives us much more filtering) + +\begin{code} +semfilter :: BitVector -> [SimpleItem] -> [SimpleItem] -> ([SimpleItem], [SimpleItem]) +semfilter inputsem auxs initial = + let auxsem x = foldl' (.|.) 0 [ siSemantics a | a <- auxs, siPolpaths a .&. siPolpaths x /= 0 ] + -- lite, here, means sans auxiliary semantics + notjunk x = (siSemantics x) .&. inputsemLite == inputsemLite + where inputsemLite = inputsem `xor` (auxsem x) + -- note that we can't just compare against siSemantics because + -- that would exclude trees that have stuff in the aux semantics + -- which would be overzealous + in partition notjunk initial +\end{code} + +% -------------------------------------------------------------------- +\section{Operations} +% -------------------------------------------------------------------- + +We implement the two TAG operations, substitution and adjunction, below. +These are the only two operations we have, because we're working with a +very simple builder that constructs derived trees. + +% -------------------------------------------------------------------- +\subsection{Substitution} +\label{sec:substitution} +% -------------------------------------------------------------------- + +\paragraph{applySubstitution} Given a SimpleItem it returns the list of all +possible substitutions between it and the elements in Chart + +\begin{code} +applySubstitution :: SimpleItem -> SimpleState ([SimpleItem]) +applySubstitution item = + do gr <- lookupChart item + active <- mapM (\x -> iapplySubst True item x) gr + passive <- mapM (\x -> iapplySubst True x item) gr + let res = concat $ active ++ passive + incrCounter num_comparisons (2 * (length gr)) + return res + +applySubstitution1p :: SimpleItem -> SimpleState ([SimpleItem]) +applySubstitution1p item = + do gr <- lookupChart item + active <- if adjdone item then return [] + else mapM (\x -> iapplySubst False item x) gr + passive <- mapM (\x -> iapplySubst False x item) $ filter adjdone gr + let res = concat $ active ++ passive + incrCounter num_comparisons (2 * (length gr)) + return res + +-- | Note: returns ONE possible substitution (the head node) +-- of the first in the second. As all substitutions nodes should +-- be substituted we force substitution in order. +iapplySubst :: Bool -> SimpleItem -> SimpleItem -> SimpleState [SimpleItem] +iapplySubst twophase item1 item2 | siInitial item1 && closed item1 = {-# SCC "applySubstitution" #-} + case siSubstnodes item2 of + [] -> return [] + ((TagSite n fu fd nOrigin) : stail) -> + let doIt = + do -- Maybe monad + let r@(TagSite rn ru rd rOrigin) = siRoot item1 + (newU, subst1) <- unifyFeat ru fu + (newD, subst2) <- unifyFeat (replace subst1 rd) + (replace subst1 fd) + let subst = mergeSubst subst1 subst2 + nr = TagSite rn newU newD rOrigin + adj1 = nr : (delete r $ siAdjnodes item1) + adj2 = siAdjnodes item2 +#ifdef DISABLE_GUI + item1g = item1 +#else + item1g = item1 { siGuiStuff = g2 } + where g2 = g { siNodes = repList (gnnameIs rn) newRoot (siNodes g) } + g = siGuiStuff item1 + -- gui stuff + newRoot g = g { gup = newU, gdown = newD, gtype = Other } +#endif + let pending = if twophase then [] + else nr : ((siPendingTb item1) ++ (siPendingTb item2)) + return $! replace subst $ combineSimpleItems [rn] item1g $ + item2 { siSubstnodes = stail ++ (siSubstnodes item1) + , siAdjnodes = adj2 ++ adj1 + , siDerived = plugTree (siDerived item1) n (siDerived item2) + , siDerivation = addToDerivation 's' (item1g,rOrigin) (item2,nOrigin,n) + , siLeaves = (siLeaves item1) ++ (siLeaves item2) + , siPendingTb = pending + } + in case doIt of + Nothing -> return [] + Just x -> do incrCounter "substitutions" 1 + return [x] +iapplySubst _ _ _ = return [] +\end{code} + +% -------------------------------------------------------------------- +\subsection{Adjunction} +\label{sec:adjunction} +\label{sec:ordered_adjunction} +\label{sec:foot_constraint} +% --------------------------------------------------------------- + +\paragraph{applyAdjunction2p} Given a SimpleItem, it returns the list of all +possible adjunctions between it and the elements in Chart. +The Chart contains Auxiliars, while SimpleItem is an Initial + +Note: as of 13 april 2005 - only uses ordered adjunction as described in +\cite{kow04a} +\begin{code} +applyAdjunction2p :: SimpleItem -> SimpleState ([SimpleItem]) +applyAdjunction2p item = {-# SCC "applyAdjunction2p" #-} + do gr <-lookupChart item + incrCounter num_comparisons (length gr) + mapMaybeM (\a -> tryAdj True a item) gr + +passiveAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] +passiveAdjunction1p item | closed item && siInitial item = + do gr <- lookupChart item + mapMaybeM (\a -> tryAdj False a item) $ filter validAux gr +passiveAdjunction1p _ = return [] + +activeAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] +activeAdjunction1p item | validAux item = + do gr <- lookupChart item + mapMaybeM (\p -> tryAdj False item p) $ filter (\x -> siInitial x && closed x) gr +activeAdjunction1p _ = return [] + +validAux :: SimpleItem -> Bool +validAux t = closedAux t && adjdone t + +tryAdj :: Bool -> SimpleItem -> SimpleItem -> SimpleState (Maybe SimpleItem) +tryAdj twophase aItem pItem = + do case iapplyAdjNode twophase aItem pItem of + Just x -> do incrCounter "adjunctions" 1 + return $ Just x + Nothing -> return Nothing +\end{code} + +Note that in the one-phase variant of non-adjunction, we can't do top/bot +unification on the fly, because afaik we can't tell that a node will never +be revisited. One example of this is if you try to adjoin into the root + +\begin{code} +-- | Ignore the next adjunction node +sansAdjunction1p, sansAdjunction2p :: SimpleItem -> SimpleState [SimpleItem] +sansAdjunction1p item | closed item = + case siAdjnodes item of + [] -> return [] + (ahead : atail) -> + return $ [item { siAdjnodes = atail + , siPendingTb = ahead : (siPendingTb item) } ] +sansAdjunction1p _ = return [] + +-- | Ignore the next adjunction node +sansAdjunction2p item | closed item = + case siAdjnodes item of + [] -> return [] + (TagSite gn t b o: atail) -> do + -- do top/bottom unification on the node + case unifyFeat t b of + Nothing -> +#ifndef DISABLE_GUI + do addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item) + ts_tbUnificationFailure +#endif + return [] + Just (tb,s) -> + let item1 = if isRootOf item gn + then item { siRoot = TagSite gn tb [] o } + else item +#ifdef DISABLE_GUI + item2 = item1 +#else + item2 = modifyGuiStuff (constrainAdj gn tb) item1 +#endif + in return $! [replace s $! item2 { siAdjnodes = atail }] +sansAdjunction2p _ = return [] +\end{code} + +The main work for adjunction is done in the helper function below +(see also figure \ref{fig:adjunction}). +Auxiliary tree \texttt{te1} has a root node \texttt{r} and a foot +node \texttt{f}. Main tree \texttt{te2} has an adjunction site \texttt{an}. +The resulting tree \texttt{res} is a result of splicing \texttt{te1} into +\texttt{te2}. We replace \texttt{s} with the nodes \texttt{anr} and +\texttt{anf} (which are the results of unifying \texttt{an} with \texttt{r} + and \texttt{f} respectively). + +\begin{figure} +\begin{center} +\includegraphics[scale=0.5]{images/adjunction.pdf} +\label{fig:adjunction} +\caption{iapplyAdjNode} +\end{center} +\end{figure} + +In addition to the trees proper, we have to consider that each tree has +a list with a copy of its adjunction sites. The adjunction list of the +result (\texttt{adjnodes res}) should then contain \texttt{adjnodes te1} +and \texttt{adjnodes te2}, but replacing \texttt{r} and \texttt{an} +with \texttt{anr}. + +\begin{code} +iapplyAdjNode :: Bool -> SimpleItem -> SimpleItem -> Maybe SimpleItem +iapplyAdjNode twophase aItem pItem = {-# SCC "iapplyAdjNode" #-} + case siAdjnodes pItem of + [] -> Nothing + (TagSite an_name an_up an_down nOrigin : atail) -> do + -- block repeated adjunctions of the same SimpleItem (for ignore semantics mode) + -- guard $ not $ (an_name, siId aItem) `elem` (siAdjlist pItem) + -- let's go! + let r@(TagSite r_name r_up r_down rOrigin) = siRoot aItem -- auxiliary tree, eh? + (TagSite f_name f_up f_down _) <- siFoot aItem -- should really be an error if fails + (anr_up', subst1) <- unifyFeat r_up an_up + (anf_down, subst2) <- unifyFeat (replace subst1 f_down) (replace subst1 an_down) + let -- combined substitution list and success condition + subst12 = mergeSubst subst1 subst2 + -- the result of unifying the t1 root and the t2 an + anr = TagSite r_name (replace subst2 anr_up') r_down rOrigin + let anf_up = replace subst12 f_up + -- the new adjunction nodes + auxlite = delete r $ siAdjnodes aItem + newadjnodes = anr : (atail ++ auxlite) + -- +#ifdef DISABLE_GUI + aItem2 = aItem +#else + -- Ugh, this is horrible: this is just to make sure the GUI gets + -- updated accordingly. The code used to be a lot simpler, but + -- I started trying to move stuff out of the way in the interests + -- of efficiency, and to pack as much gui-related stuff as possible + -- into a single tuple. + aItem2 = aItem { siGuiStuff = fixNodes $ siGuiStuff aItem } + where fixNodes g = g { siNodes = map (setSites anr) (siNodes g) } + setSites (TagSite n u d _) gn = + if gnname gn == n then gn { gup = u, gdown = d } + else gn +#endif + rawCombined = + combineSimpleItems [r_name, an_name] aItem2 $ pItem + { siAdjnodes = newadjnodes + , siLeaves = siLeaves aItem ++ siLeaves pItem + , siDerived = spliceTree f_name (siDerived aItem) an_name (siDerived pItem) + , siDerivation = addToDerivation 'a' (aItem,rOrigin) (pItem,nOrigin,an_name) + -- , siAdjlist = (n, (tidnum te1)):(siAdjlist item2) + -- if we adjoin into the root, the new root is that of the aux + -- tree (affects 1p only) + , siRoot = if isRootOf pItem an_name then r else siRoot pItem + , siPendingTb = + if twophase then [] + else (TagSite an_name anf_up anf_down nOrigin) : (siPendingTb pItem) ++ (siPendingTb aItem) + } + -- one phase = postpone tb unification + -- two phase = do tb unification on the fly + finalRes1p = return $ replace subst12 rawCombined + finalRes2p = + do -- tb on the former foot + tbRes <- unifyFeat anf_up anf_down +#ifdef DISABLE_GUI + let (_, subst3) = tbRes + myRes = res' +#else + let (anf_tb, subst3) = tbRes + myRes = modifyGuiStuff (constrainAdj an_name anf_tb) res' +#endif + -- apply the substitutions + res' = replace (mergeSubst subst12 subst3) rawCombined + return myRes + -- --------------- + if twophase then finalRes2p else finalRes1p +\end{code} + +% -------------------------------------------------------------------- +\subsection{Helper functions for operations} +% -------------------------------------------------------------------- + +\begin{code} +ncopy :: GNode -> TagSite +ncopy x = TagSite (gnname x) (gup x) (gdown x) (gorigin x) + +isRootOf :: SimpleItem -> String -> Bool +isRootOf item n = n == rname + where (TagSite rname _ _ _) = siRoot item + +-- | Retrieves a list of trees from the chart which could be combined with the given agenda tree. +-- The current implementation searches for trees which +-- * do not have overlapping semantics with the given +-- * are on the some of the same polarity automaton paths as the +-- current agenda item +lookupChart :: SimpleItem -> SimpleState [SimpleItem] +lookupChart given = do + chart <- gets theChart + let gpaths = siPolpaths given + gsem = siSemantics given + return [ i | i <- chart + -- should be on the same polarity path (chart sharing) + , (siPolpaths i) .&. gpaths /= 0 + -- semantics should not be overlapping + && (siSemantics i .&. gsem ) == 0 + ] + +-- | Helper function for when chart operations succeed. +combineSimpleItems :: [NodeName] -- ^ nodes to highlight + -> SimpleItem -> SimpleItem -> SimpleItem +combineSimpleItems hi item1 item2 = {-# SCC "combineSimpleItems" #-} + item2 { siSemantics = (siSemantics item1) .|. (siSemantics item2) + , siPolpaths = (siPolpaths item1) .&. (siPolpaths item2) +#ifndef DISABLE_GUI + , siGuiStuff = combineSimpleGuiItems hi (siGuiStuff item1) (siGuiStuff item2) +#endif + } + +#ifndef DISABLE_GUI +combineSimpleGuiItems :: [NodeName] + -> SimpleGuiItem -> SimpleGuiItem -> SimpleGuiItem +combineSimpleGuiItems hi item1 item2 = + item2 { siFullSem = sortSem $ (siFullSem item1) ++ (siFullSem item2) + , siNodes = (siNodes item1) ++ (siNodes item2) + , siDiagnostic = (siDiagnostic item1) ++ (siDiagnostic item2) + , siHighlight = hi + } + +constrainAdj :: String -> Flist -> SimpleGuiItem -> SimpleGuiItem +constrainAdj gn newT g = + g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) } + where fixIt n = n { gup = newT, gdown = [], gaconstr = True } +#endif +\end{code} + +\subsubsection{Derivation trees} + +We make the simplifying assumption that each chart item is only used once. +This is clearly wrong if we allow for items with an empty semantics, but +since we do not actually allow such a thing, we're ok. + +\begin{code} +addToDerivation :: Char + -> (SimpleItem,String) + -> (SimpleItem,String,String) + -> TagDerivation +addToDerivation op (tc,tcOrigin) (tp,tpOrigin,tpSite) = + let hp = siDerivation tp + hc = siDerivation tc + newnode = (op, tcOrigin, (tpOrigin, tpSite)) + in newnode:hp++hc +\end{code} + + + +% -------------------------------------------------------------------- +\section{Dispatching new results} +% -------------------------------------------------------------------- + +Dispatching is the process where new chart items are assigned to one of +the trash, agenda, auxiliary agenda or chart. The item could be +modified during dispatch-time; for example, we might do top/bottom +unification on it. See \ref{sec:dispatching} for more details. + +\begin{code} +type SimpleDispatchFilter = DispatchFilter SimpleState SimpleItem + +simpleDispatch_2p :: SimpleDispatchFilter +simpleDispatch_2p = + simpleDispatch (dpRootFeatFailure >--> dpToResults) + (dpAux >--> dpToAgenda) + +simpleDispatch_1p :: Bool -> SimpleDispatchFilter +simpleDispatch_1p iaf = + simpleDispatch (dpRootFeatFailure >--> dpTbFailure >--> dpToResults) + (maybeDpIaf >--> dpToAgenda) + where maybeDpIaf = if iaf then dpIafFailure else nullFilter + +simpleDispatch :: SimpleDispatchFilter -> SimpleDispatchFilter -> SimpleDispatchFilter +simpleDispatch resFilter nonResFilter item = + do inputsem <- gets tsem + let synComplete x = siInitial x && closed x && adjdone x + semComplete x = inputsem == siSemantics x + isResult x = synComplete x && semComplete x + condFilter isResult resFilter nonResFilter item + +dpAux, dpToAgenda :: SimpleDispatchFilter +dpTbFailure, dpRootFeatFailure, dpRootFeatFailure2, dpToResults :: SimpleDispatchFilter +dpToTrash :: String -> SimpleDispatchFilter + +dpToAgenda x = addToAgenda x >> return Nothing +dpToResults x = addToResults x >> return Nothing +#ifdef DISABLE_GUI +dpToTrash _ _ = return Nothing +#else +dpToTrash m x = addToTrash x m >> return Nothing +#endif + +dpAux item = + if closedAux item + then addToAuxAgenda item >> return Nothing + else return $ Just item + +{- +-- | Dispatches to the trash and returns Nothing if there is a tree +-- size limit in effect and the item is over that limit. The +-- tree size limit is used in 'IgnoreSemantics' mode. +dpTreeLimit item = + do config <- gets genconfig + case maxTrees config of + Nothing -> return $ Just item + Just lim -> if (length.snd.siDerivation) item > lim + then do addToTrash item (ts_overnumTrees lim) + return Nothing + else return $ Just item + where ts_overnumTrees l = "Over derivation size of " ++ (show l) +-} + +-- | This is only used for the one-phase algorithm +dpTbFailure item = + return $ if tbUnifyTree item then Just item else Nothing + +-- | If the item (ostensibly a result) does not have the correct root +-- category, return Nothing; otherwise return Just item +dpRootFeatFailure = dpRootFeatFailure_ False +dpRootFeatFailure2 = dpRootFeatFailure_ True + +dpRootFeatFailure_ :: Bool -> SimpleDispatchFilter +dpRootFeatFailure_ count item = + do config <- gets genconfig + let rootFeat = getListFlagP RootFeatureFlg config + (TagSite _ top _ _) = siRoot item + case unifyFeat rootFeat top of + Nothing -> + do when count $ incrCounter "root_feat_discards" 1 + dpToTrash (ts_rootFeatureMismatch rootFeat) item + Just (_, s) -> + return . Just $ replace s item +\end{code} +% -------------------------------------------------------------------- +\subsection{Top and bottom unification} +% -------------------------------------------------------------------- + +\paragraph{tbUnifyTree} unifies the top and bottom feature structures +of each node on each tree. Note: this only determines if it is +possible to do so. Actually returning the results is possible +and even easy +(you'll have to look back into the darcs repository and unpull the + patch from 2006-05-21T15:40:51 ``Remove top/bot unification standalone + code.'') +but since it is only used in the one-phase algorithm and for the +graphical interface, I decided not to bother. + +\begin{code} +type TbEither = Either String Subst +tbUnifyTree :: SimpleItem -> Bool +tbUnifyTree item = {-# SCC "tbUnifyTree" #-} + case foldl tbUnifyNode (Right Map.empty) (siPendingTb item) of + Left _ -> False + Right _ -> True +\end{code} + +Our helper function corresponds to the first unification step. It is +meant to be called from a fold. The node argument represents the +current node being explored. The Either argument holds a list of +pending substitutions and a copy of the entire tree. + +There are two things going on in here: + +\begin{enumerate} +\item check if unification is possible - first we apply the pending + substitutions on the node and then we check if unification + of the top and bottom feature structures of that node + succeeds +\item keep track of the substitutions that need to be performed - + any new substitutions that result from unification are + added to the pending list +\end{enumerate} + +Note that we wrap the second argument in a Maybe; this is used to +indicate that if unification suceeds or fails. We also use it to +prevent the function from doing any work if a unification failure +from a previous call has already occured. + +Getting this right was a big pain in the butt, so don't go trying to +simplify this over-complicated code unless you know what you're doing. + +\begin{code} +tbUnifyNode :: TbEither -> TagSite -> TbEither +tbUnifyNode (Right pending) rawSite = + -- apply pending substitutions + case replace pending rawSite of + (TagSite name up down _) -> + -- check top/bottom unification on this node + case unifyFeat up down of + -- stop all future iterations + Nothing -> Left name + -- apply any new substutions to the whole tree + Just (_,sb) -> Right (mergeSubst pending sb) + +-- if earlier we had a failure, don't even bother +tbUnifyNode (Left n) _ = Left n +\end{code} + +% -------------------------------------------------------------------- +\subsection{Index accesibility filtering} +\label{sec:simple:iaf} +% -------------------------------------------------------------------- + +Note that index accesibility filtering only makes sense for the one-phase +algorithm. See also \ref{sec:iaf} for more details about what this is. + +\begin{code} +instance IafAble SimpleItem where + iafAcc = siAccesible + iafInacc = siInaccessible + iafSetAcc a i = i { siAccesible = a } + iafSetInacc a i = i { siInaccessible = a } + iafNewAcc i = + concatMap fromUniConst $ + concat [ getIdx up | (TagSite _ up _ _) <- siSubstnodes i ] + +dpIafFailure :: SimpleDispatchFilter +dpIafFailure item | aux item = return $ Just item +dpIafFailure itemRaw = + do s <- get + let bmap = semBitMap s + item = recalculateAccesibility itemRaw + badSem = iafBadSem (theIafMap s) bmap (tsem s) siSemantics item + inAcc = iafInacc item + if badSem == 0 + then -- can't dispatch, but that's good! + -- (note that we return the item with its iaf criteria updated) + return $ Just item + else dpToTrash (ts_iafFailure inAcc $ bitVectorToSem bmap badSem) item +\end{code} + + +% -------------------------------------------------------------------- +\section{Unpacking the results} +% -------------------------------------------------------------------- + +Unpacking the results consists of converting each result into a sentence +automaton (to take care of atomic disjunction) and reading the paths of +each automaton. + +\begin{code} +unpackResults :: [SimpleItem] -> [B.Output] +unpackResults = concatMap unpackResult + +unpackResult :: SimpleItem -> [B.Output] +unpackResult item = + let leafMap :: Map.Map String B.UninflectedDisjunction + leafMap = Map.fromList . siLeaves $ item + lookupOrBug :: NodeName -> B.UninflectedDisjunction + lookupOrBug k = case Map.lookup k leafMap of + Nothing -> geniBug $ "unpackResult : could not find node " ++ k + Just w -> w + derivation = siDerivation item + paths = automatonPaths . listToSentenceAut $ + [ lookupOrBug k | (k,_) <- (preTerminals . siDerived) item ] + in zip paths (repeat derivation) +\end{code} + +\subsection{Sentence automata} + +\fnlabel{listToSentenceAut} converts a list of GNodes into a sentence +automaton. It's a actually pretty stupid conversion in fact. We pretty +much make a straight path through the automaton, with the only +cleverness being that we provide a different transition for each +atomic disjunction. + +\begin{code} +listToSentenceAut :: [ B.UninflectedDisjunction ] -> B.SentenceAut +listToSentenceAut nodes = + let theStart = 0 + theEnd = (length nodes) - 1 + theStates = [theStart..theEnd] + -- + emptyAut = NFA + { startSt = theStart + , isFinalSt = Nothing + , finalStList = [theEnd] + , states = [theStates] + , transitions = Map.empty } + -- create a transition for each lexeme in the node to the + -- next state... + helper :: (Int, B.UninflectedDisjunction) -> B.SentenceAut -> B.SentenceAut + helper (current, (lemmas, features)) aut = + foldl' addT aut lemmas + where + addT a t = addTrans a current (Just (t, features)) next + next = current + 1 + -- + in foldr helper emptyAut (zip theStates nodes) +\end{code} + +% -------------------------------------------------------------------- +\section{Partial results} +% -------------------------------------------------------------------- + +The user may ask for partial results when realisation fails. We implement this +using a greedy, full-commitment algorithm. Find the discarded result that +matches the largest part of the semantics and output that fragment. If there +are parts of the input semantics not covered by that fragment, search for the +largest chunk that covers the missing semantics. Recurse until there are no +more eligible items. + +\begin{code} +partialResults :: SimpleStatus -> [SimpleItem] +#ifndef DISABLE_GUI +partialResults st = unfoldr getNext 0 + where + inputsem = tsem st + trash = theTrash st + trashC = sortBy (comparing $ negate . fst) $ + map (\t -> (coverage inputsem t, t)) trash + getNext sem = case getItems sem of + [] -> Nothing + (it:_) -> Just (it, siSemantics it .|. sem) + getItems sem = [ i | (_,i) <- trashC, siSemantics i .&. sem == 0 ] + +coverage :: BitVector -> SimpleItem -> Int +coverage sem it = countBits (sem .&. siSemantics it) + +countBits :: Bits a => a -> Int +countBits 0 = 0 +countBits bs = if testBit bs 0 then 1 + next else next + where next = countBits (shiftR bs 1) +#else +partialResults = return [] +#endif +\end{code} + diff --git a/src/NLP/GenI/Simple/SimpleGui.lhs b/src/NLP/GenI/Simple/SimpleGui.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Simple/SimpleGui.lhs @@ -0,0 +1,200 @@ +% 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. + +\chapter{Simple GUI} + +\begin{code} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.GenI.Simple.SimpleGui where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX + +import Data.IORef +import qualified Data.Map as Map + +import NLP.GenI.Statistics (Statistics) + +import NLP.GenI.Btypes (GNode(gnname, gup), emptyGNode, GeniVal(GConst)) +import NLP.GenI.Configuration ( Params(..) ) +import NLP.GenI.General ( snd3 ) +import NLP.GenI.Geni ( ProgStateRef, runGeni, GeniResult ) +import NLP.GenI.Graphviz ( GraphvizShow(..), gvNewline, gvUnlines ) +import NLP.GenI.GuiHelper + ( messageGui, tagViewerGui, + debuggerPanel, DebuggerItemBar, setGvParams, GvIO, newGvRef, + viewTagWidgets, XMGDerivation(getSourceTrees), + ) +import NLP.GenI.Tags (tsemantics, TagElem(idname, ttree), TagItem(..), emptyTE) +import NLP.GenI.GraphvizShow ( graphvizShowDerivation ) + +import qualified NLP.GenI.Builder as B +import qualified NLP.GenI.BuilderGui as BG +import NLP.GenI.Polarity +import NLP.GenI.Simple.SimpleBuilder + ( simpleBuilder, SimpleStatus, SimpleItem(..), SimpleGuiItem(..) + , unpackResult + , theResults, theAgenda, theAuxAgenda, theChart, theTrash) +\end{code} +} + +% -------------------------------------------------------------------- +\section{Interface} +% -------------------------------------------------------------------- + +\begin{code} +simpleGui_2p, simpleGui_1p :: BG.BuilderGui +simpleGui_2p = simpleGui True +simpleGui_1p = simpleGui False + +simpleGui :: Bool -> BG.BuilderGui +simpleGui twophase = BG.BuilderGui { + BG.resultsPnl = resultsPnl twophase + , BG.debuggerPnl = simpleDebuggerTab twophase } + +resultsPnl :: Bool -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) +resultsPnl twophase pstRef f = + do (sentences, stats, st) <- runGeni pstRef (simpleBuilder twophase) + (lay, _, _) <- realisationsGui pstRef f (theResults st) + return (sentences, stats, lay) +\end{code} + +% -------------------------------------------------------------------- +\section{Results} +\label{sec:results_gui} +% -------------------------------------------------------------------- + +\subsection{Derived Trees} + +Browser for derived/derivation trees, except if there are no results, we show a +message box + +\begin{code} +realisationsGui :: ProgStateRef -> (Window a) -> [SimpleItem] + -> GvIO Bool (Maybe SimpleItem) +realisationsGui _ f [] = + do m <- messageGui f "No results found" + g <- newGvRef False [] "" + return (m, g, return ()) +realisationsGui pstRef f resultsRaw = + do let tip = "result" + itNlabl = map (\t -> (Just t, siToSentence t)) resultsRaw + -- + pst <- readIORef pstRef + -- FIXME: have to show the semantics again + tagViewerGui pst f tip "derived" itNlabl +\end{code} + +% -------------------------------------------------------------------- +\section{Debugger} +\label{sec:simple_debugger_gui} +\label{fn:simpleDebugGui} +% -------------------------------------------------------------------- + +\begin{code} +simpleDebuggerTab :: Bool -> (Window a) -> Params -> B.Input -> String -> IO Layout +simpleDebuggerTab twophase x1 (pa@x2) = + debuggerPanel (simpleBuilder twophase) False stToGraphviz (simpleItemBar pa) + x1 x2 + +stToGraphviz :: SimpleStatus -> [(Maybe SimpleItem, String)] +stToGraphviz st = + let agenda = section "AGENDA" $ theAgenda st + auxAgenda = section "AUXILIARY" $ theAuxAgenda st + trash = section "TRASH" $ theTrash st + chart = section "CHART" $ theChart st + results = section "RESULTS" $ theResults st + -- + section n i = hd : (map tlFn i) + where hd = (Nothing, "___" ++ n ++ "___") + tlFn x = (Just x, siToSentence x ++ (showPaths $ siPolpaths x)) + showPaths t = " (" ++ showPolPaths t ++ ")" + in concat [ agenda, auxAgenda, chart, trash, results ] + +simpleItemBar :: Params -> DebuggerItemBar Bool SimpleItem +simpleItemBar pa f gvRef updaterFn = + do ib <- panel f [] + detailsChk <- checkBox ib [ text := "Show features" + , checked := False ] + viewTagLay <- viewTagWidgets ib gvRef pa + -- handlers + let onDetailsChk = + do isDetailed <- get detailsChk checked + setGvParams gvRef isDetailed + updaterFn + set detailsChk [ on command := onDetailsChk ] + -- + return . hfloatCentre . (container ib) . row 5 $ + [ hspace 5 + , widget detailsChk + , hglue + , viewTagLay + , hspace 5 ] +\end{code} + +% -------------------------------------------------------------------- +\section{Miscellaneous} +% ------------------------------------------------------------------- + +\begin{code} +instance TagItem SimpleItem where + tgIdName = siIdname.siGuiStuff + tgIdNum = siId + tgSemantics = siFullSem.siGuiStuff + +instance XMGDerivation SimpleItem where + -- Note: this is XMG-related stuff + getSourceTrees it = tgIdName it : (map snd3 . siDerivation $ it) +\end{code} + +\begin{code} +instance GraphvizShow Bool SimpleItem where + graphvizLabel f c = + graphvizLabel f (toTagElem c) ++ gvNewline ++ (gvUnlines $ siDiagnostic $ siGuiStuff c) + + graphvizParams f c = graphvizParams f (toTagElem c) + graphvizShowAsSubgraph f p it = + let isHiglight n = gnname n `elem` (siHighlight.siGuiStuff) it + info n | isHiglight n = (n, Just "red") + | otherwise = (n, Nothing) + in "\n// ------------------- elementary tree --------------------------\n" + ++ graphvizShowAsSubgraph (f, info) (p ++ "TagElem") (toTagElem it) + ++ "\n// ------------------- derivation tree --------------------------\n" + -- derivation tree is displayed without any decoration + ++ (graphvizShowDerivation . siDerivation $ it) + +toTagElem :: SimpleItem -> TagElem +toTagElem si = + emptyTE { idname = tgIdName si + , tsemantics = tgSemantics si + , ttree = fmap lookupOrBug (siDerived si) } + where + nodes = siNodes.siGuiStuff $ si + nodeMap = Map.fromList $ zip (map gnname nodes) nodes + lookupOrBug k = case Map.lookup k nodeMap of + Nothing -> emptyGNode { gup = [ ("cat",GConst ["error looking up " ++ k]) ] } + Just x -> x +\end{code} + +\begin{code} +siToSentence :: SimpleItem -> String +siToSentence si = case unpackResult si of + [] -> siIdname.siGuiStuff $ si + (h:_) -> unwords . map fst . fst $ h +\end{code} diff --git a/src/NLP/GenI/Statistics.hs b/src/NLP/GenI/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Statistics.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE FlexibleContexts #-} +---------------------------------------------------- +-- -- +-- Statistics.hs: -- +-- Functions that collect and print out -- +-- statistics -- +-- -- +---------------------------------------------------- + +{- +Copyright (C) GenI 2002-2005 (originally from HyLoRes) +Carlos Areces - areces@loria.fr - http://www.loria.fr/~areces +Daniel Gorin - dgorin@dc.uba.ar +Juan Heguiabehere - juanh@inf.unibz.it - http://www.inf.unibz.it/~juanh/ +Eric Kow - kow@loria.fr - http://www.loria.fr/~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. +-} + +module NLP.GenI.Statistics(Statistics, StatisticsState, StatisticsStateIO, + emptyStats, + + printOutAllMetrics, printOutAllMetrics', printOutInspectionMetrics, + showFinalStats, + + initialStatisticsStateFor, + addMetric, addInspectionMetric, setPrintOutInterval, + mergeMetrics, + + Metric(IntMetric), queryMetrics, updateMetrics, + incrIntMetric, queryIntMetric, addIntMetrics, +) where + +import Control.Monad.State +import Data.Maybe (mapMaybe) +import Data.List (intersperse) + +------------------------------------------- +-- Statistics are collections of Metrics +-- which can be printed out (at regular intervals) +------------------------------------------- +data Statistics = Stat{metrics::[Metric], + inspectionMetrics::[Metric], + count::Int, + step::Maybe Int} + +type StatisticsState a = forall m. (MonadState Statistics m) => m a +type StatisticsStateIO a = forall m. (MonadState Statistics m, MonadIO m) => m a + +updateMetrics :: (Metric -> Metric) -> Statistics -> Statistics +updateMetrics f stat = stat{metrics = map f (metrics stat), + inspectionMetrics = map f (inspectionMetrics stat)} + +queryMetrics :: (Metric -> Maybe a) -> Statistics -> [a] +queryMetrics f stat = (mapMaybe f (metrics stat)) + ++ (mapMaybe f (inspectionMetrics stat)) + +mergeMetrics :: (Metric -> Metric -> Metric) -> Statistics -> Statistics -> Statistics +mergeMetrics f s1 s2 = s1 { metrics = zipWith f (metrics s1) (metrics s2) + , inspectionMetrics = zipWith f (inspectionMetrics s1) (inspectionMetrics s2)} + +--updateStep :: Statistics -> Statistics +--updateStep s@(Stat _ [] _ _) = s +--updateStep s@(Stat _ _ _ Nothing) = s +--updateStep stat = stat{count = (count stat)+1} + +needsToPrintOut :: Statistics -> Bool +needsToPrintOut (Stat _ [] _ _) = False +needsToPrintOut (Stat _ _ _ Nothing) = False +needsToPrintOut (Stat _ _ iter (Just toi)) = iter > 0 && iter `mod` toi == 0 + +noStats :: Statistics -> Bool +noStats (Stat [] [] _ _) = True +noStats _ = False + +emptyStats :: Statistics +emptyStats = Stat{metrics=[], + inspectionMetrics=[], + count=0, + step=Nothing} + +--------------------------- Monadic Statistics functions follow ------------------------------ + + +initialStatisticsStateFor :: (MonadState Statistics m) => (m a -> Statistics -> b) -> m a -> b +initialStatisticsStateFor f = flip f emptyStats + +{- | Adds a metric at the end of the list (thus, + metrics are printed out in the order in which they were added -} +addMetric :: Metric -> StatisticsState () +addMetric newMetric = modify (\stat -> stat{metrics = (metrics stat)++[newMetric]}) + +{- | Adds a metric that will be printed out at regular intervals -} +addInspectionMetric :: Metric -> StatisticsState () +addInspectionMetric newMetric = modify (\stat -> stat{inspectionMetrics = (inspectionMetrics stat)++[newMetric]}) + +setPrintOutInterval :: Int -> StatisticsState () +setPrintOutInterval i = modify (resetInterval i) + where resetInterval 0 stat = stat{step = Nothing} + resetInterval x stat = stat{step = Just x} + +printOutAllMetrics :: StatisticsStateIO () +printOutAllMetrics = get >>= (liftIO . printOutAllMetrics') + +printOutAllMetrics' :: Statistics -> IO () +printOutAllMetrics' stats = + do + unless (noStats stats) $ do + liftIO $ putStrLn "(final statistics)" + liftIO $ printOutList (inspectionMetrics stats ++ metrics stats) + +printOutInspectionMetrics :: StatisticsStateIO () +printOutInspectionMetrics = do + shouldPrint <- gets needsToPrintOut + when ( shouldPrint ) $ do + liftIO $ putStr "(partial statistics: iteration " + iter <- gets count + liftIO . putStr . show $ iter + liftIO $ putStrLn ")" + ims <- gets inspectionMetrics + liftIO $ printOutList ims + + +printOutList :: Show a => [a] -> IO () +printOutList ms = unless ( null ms ) $ do + let separator = "\n----------------------------------\n" + putStr "begin" + putStr separator + putStr $ concat $ intersperse separator $ map show ms + putStr separator + putStr "end\n" + +showFinalStats :: Statistics -> String +showFinalStats stats = unlines $ map show $ metrics stats + +-------------------------------------------- +-- Metrics +-------------------------------------------- +data Metric = IntMetric String Int + +instance Show Metric where + show (IntMetric s x) = s ++ " : " ++ (show x) + +incrIntMetric :: String -> Int -> Metric -> Metric +incrIntMetric key i (IntMetric s c) | s == key = IntMetric s (c+i) +incrIntMetric _ _ m = m + +queryIntMetric :: String -> Metric -> Maybe Int +queryIntMetric key (IntMetric s c) | s == key = Just c +queryIntMetric _ _ = Nothing + +addIntMetrics :: Metric -> Metric -> Metric +addIntMetrics (IntMetric s1 c1) (IntMetric s2 c2) | s1 == s2 = IntMetric s1 (c1 + c2) +addIntMetrics s1 _ = s1 + +-- ratio :: Int -> Int -> Float +-- ratio x y = (fromIntegral x) / (fromIntegral y) + diff --git a/src/NLP/GenI/SysGeni.lhs b/src/NLP/GenI/SysGeni.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/SysGeni.lhs @@ -0,0 +1,93 @@ +% 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. + +\chapter{SysGeni} + +The SysGeni module mainly exists for running GenI as an application bundle +under MacOS X. We mostly re-export stuff from System.Process, but if we +are in a MacOS X application bundle, then we add \verb!../Resources/bin! +to the path for all the random crap that we ship with with GenI. + +\begin{code} +{-# LANGUAGE ForeignFunctionInterface #-} +module NLP.GenI.SysGeni +where +\end{code} + +\ignore{ +\begin{code} +import qualified System.Process as S + +import Data.List (isSuffixOf) +import System.FilePath +import System.IO (Handle) +import System.Exit (ExitCode) + +#ifdef __GLASGOW_HASKELL__ +import Foreign +import Foreign.C +import Control.Monad +#include "ghcconfig.h" +#endif +\end{code} +} + +\section{Running a process} + +\begin{code} +waitForProcess :: S.ProcessHandle -> IO ExitCode +waitForProcess = S.waitForProcess +\end{code} + +But one thing special we need to do for Macs is to detect if we're +running from an application bundle. If we are, we assume that any +processes we want to run are in \texttt{../Resources/bin}. + +\begin{code} +runInteractiveProcess :: String -> [String] + -> Maybe FilePath + -> Maybe [(String, String)] + -> IO (Handle, Handle, Handle, S.ProcessHandle) +runInteractiveProcess cmd args x y = do + dirname <- getProgDirName + -- detect if we're in an .app bundle, i.e. if + -- we are running from something.app/Contents/MacOS + let appBundle = ".app/Contents/MacOS/" + resBinCmd = "../Resources/bin" cmd + -- if we're in an .app bundle, we should prefix the + -- path with ../Resources/bin + let cmd2 = if appBundle `isSuffixOf` dirname + then resBinCmd else cmd + S.runInteractiveProcess cmd2 args x y +\end{code} + +\paragraph{Process helpers} + +\begin{code} +foreign import ccall unsafe "getProgArgv" + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +getProgDirName :: IO String +getProgDirName = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getProgArgv p_argc p_argv + argv <- peek p_argv + s <- peekElemOff argv 0 >>= peekCString + return $ takeDirectory s +\end{code} + diff --git a/src/NLP/GenI/Tags.lhs b/src/NLP/GenI/Tags.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Tags.lhs @@ -0,0 +1,332 @@ +% 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. + +\chapter{Tags} +\label{cha:Tags} + +This module provides basic datatypes specific to Tree Adjoining Grammar +(TAG) and some low-level operations. Note that we don't handle +substitution and adjunction here; see sections \ref{sec:substitution} +and \ref{sec:adjunction} instead. + +\begin{code} +module NLP.GenI.Tags( + -- Main Datatypes + Tags, TagElem(..), TagItem(..), TagSite(..), + TagDerivation, emptyTE, + ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure, + ts_rootFeatureMismatch, + + -- Functions from Tags + addToTags, tagLeaves, + + -- Functions from TagElem + setTidnums, + + -- General functions + mapBySem, subsumedBy, showTagSites, + collect, detectSites +) where +\end{code} + +\ignore{ +\begin{code} +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.List (intersperse) +import Data.Tree + +import NLP.GenI.Btypes (Ptype(Initial, Auxiliar), SemPols, + GeniVal(GConst), + GNode(gup, glexeme, gnname, gaconstr, gdown, gtype, gorigin), + GType(Subs), Flist, + Replacable(..), replaceOneAsMap, + Collectable(..), Idable(..), + Sem, Pred, emptyPred, + emptyGNode, + showFlist, showPairs, showSem, lexemeAttributes, + ) +import NLP.GenI.General (groupByFM, preTerminals) +\end{code} +} + +% ---------------------------------------------------------------------- +\section{Tags} +% ---------------------------------------------------------------------- + +\begin{code} +-- | An anchored grammar. +-- The grammar associates a set of semantic predicates to a list of trees each. +type Tags = Map.Map String [TagElem] + +-- | 'addTags' @tags key elem@ adds @elem@ to the the list of elements associated +-- to the key +addToTags :: Tags -> String -> TagElem -> Tags +addToTags t k e = Map.insertWith (++) k [e] t +\end{code} + +% ---------------------------------------------------------------------- +\section{TagElem} +% ---------------------------------------------------------------------- + +Final types used for the combined macros + lexicon. We assume that +a two trees are the same iff they have the same tidnum. To make this +work, we assign each tree with a unique id during the process of +combining macros with lexicon (see section \ref{sec:combine_macros}). + +\begin{code} +data TagSite = TagSite { tsName :: !String + , tsUp :: !Flist + , tsDown :: !Flist + , tsOrigin :: !String + } + deriving (Show, Eq, Ord) + +data TagElem = TE { + idname :: String, + ttreename :: String, + tidnum :: Integer, + ttype :: !Ptype, + ttree :: Tree GNode, + tsemantics :: Sem, + -- optimisation stuff + -- (polarity key to charge interval) + tpolarities :: Map.Map String (Int,Int), + tinterface :: Flist, -- for idxconstraints (pol) + ttrace :: [String], + tsempols :: [SemPols] + } + deriving (Show, Eq) +\end{code} + +A TAG derivation history consists of a list of 3-tuples representing the +operation (s for substitution, a for adjunction), the name of the child tree, +the name of the parent tree and the node affected. + +\begin{code} +type TagDerivation = [ (Char, String, (String, String)) ] +\end{code} + +\begin{code} +instance Ord TagElem where + compare t1 t2 = + case (ttype t1, ttype t2) of + (Initial, Initial) -> compareId + (Initial, Auxiliar) -> LT + (Auxiliar, Initial) -> GT + (Auxiliar, Auxiliar) -> compareId + _ -> error "TagElem compare not exhaustively defined" + where compareId = compare (tidnum t1) (tidnum t2) + +instance Replacable TagElem where + replaceMap s te = + te { tinterface = replaceMap s (tinterface te) + , ttree = replaceMap s (ttree te) + , tsemantics = replaceMap s (tsemantics te) } + replaceOne = replaceOneAsMap + +instance Replacable TagSite where + replaceMap s (TagSite n fu fd o) = TagSite n (replaceMap s fu) (replaceMap s fd) o + replaceOne s (TagSite n fu fd o) = TagSite n (replaceOne s fu) (replaceOne s fd) o + +instance Collectable TagElem where + collect t = (collect $ tinterface t) . (collect $ ttree t) + . (collect $ tsemantics t) + +instance Idable TagElem where + idOf = tidnum +\end{code} + +\begin{code} +emptyTE :: TagElem +emptyTE = TE { idname = "", + ttreename = "", + tidnum = -1, + ttype = Initial, + ttree = Node emptyGNode [], + tsemantics = [], + tpolarities = Map.empty, + tsempols = [], + tinterface = [], + ttrace = [] + } + +-- | Given a tree(GNode) returns a list of substitution or adjunction +-- nodes, as well as remaining nodes with a null adjunction constraint. +detectSites :: Tree GNode -> ([TagSite], [TagSite], [TagSite]) +detectSites t = + ( sites isSub -- for substitution + , sites (not.gaconstr) -- for adjunction + , sites constrButNotSub -- for neither + ) + where + ns = flatten t + sites match = [ TagSite (gnname n) (gup n) (gdown n) (gorigin n) | n <- ns, match n ] + isSub n = gtype n == Subs + constrButNotSub n = gaconstr n && (not $ isSub n) +\end{code} + +\subsection{Unique ID} + +TagElem comparison relies exclusively on \fnparam{tidnum}, so you must +ensure that every TagElem you use has a unique ID. We provide two +helpful functions for this. These are most likely useful \emph{between} +lexical selection and generation proper, because during generation +proper, you can simply keep a counter within a State monad to assign +unique IDs to new TagElems. + +Note that we also label each node of the tree with its elementary tree +name and with the unique ID. This helps us to build derivation trees +correctly + +\begin{code} +-- | Assigns a unique id to each element of this list, that is, an integer +-- between 1 and the size of the list. +setTidnums :: [TagElem] -> [TagElem] +setTidnums xs = zipWith (\c i -> setOrigin $ c {tidnum = i}) xs [1..] + +setOrigin :: TagElem -> TagElem +setOrigin te = te { ttree = fmap setLabel . ttree $ te } + where setLabel g = g { gorigin = idname te ++ ":" ++ (show.tidnum) te } +\end{code} + +% ---------------------------------------------------------------------- +\section{TAG Item} +% ---------------------------------------------------------------------- + +\begin{code} +-- | 'TagItem' is a generalisation of 'TagElem'. +class TagItem t where + tgIdName :: t -> String + tgIdNum :: t -> Integer + tgSemantics :: t -> Sem + +instance TagItem TagElem where + tgIdName = idname + tgIdNum = tidnum + tgSemantics = tsemantics +\end{code} + +% ---------------------------------------------------------------------- +\section{Map by sem} +% ---------------------------------------------------------------------- + +\begin{code} +-- | Sorts trees into a Map.Map organised by the first literal of their +-- semantics. This is useful in at least three places: the polarity +-- optimisation, the gui display code, and code for measuring the efficiency +-- of GenI. Note: trees with a null semantics are filed under an empty +-- predicate, if any. +mapBySem :: (TagItem t) => [t] -> Map.Map Pred [t] +mapBySem ts = + let gfn t = case tgSemantics t of + [] -> emptyPred + (x:_) -> x + in groupByFM gfn ts + +-- | 'subsumedBy' @cs ts@ determines if the candidate semantics @cs@ is +-- subsumed by the proposition semantics @ts@. Notice how the proposition +-- semantics is only a single item where as the candidate semantics is a +-- list. +-- +-- We assume +-- +-- * most importantly that @cs@ has already its semantics instatiated +-- (all variables assigned) +-- +-- * @cs@ and @ts@ are sorted +-- +-- * the list in each element of cs and ts is itself sorted +subsumedBy :: Sem -> Pred -> Bool +subsumedBy [] _ = False +subsumedBy ((ch, cp, cla):cl) (th, tp,tla) + | (ch == th) && (cp == tp) && (cla == tla) = True + -- if we haven't yet overshot, try for the next one + | cp < tp = subsumedBy cl (th, tp, tla) + | otherwise = False +\end{code} + +% ---------------------------------------------------------------------- +\section{Extracting sentences} +% ---------------------------------------------------------------------- + +Normally, extracting the sentences from a TAG tree would just consist of +reading its leaves. But if you want the generator to return inflected +forms instead of just lemmas, you also need to return the relevant +features for each leaf. In TAG, or at least our use of it, the features +come from the \emph{pre-terminal} nodes, that is, not the leaves +themselves but their parents. Another bit of trickiness: because of +atomic disjunction, leaves might have more than one value, so we can't +just return a String lemma but a list of String, one for each +possibility. + +\begin{code} +type UninflectedDisjunction = ([String], Flist) + +tagLeaves :: TagElem -> [ (String, UninflectedDisjunction) ] +tagLeaves te = [ (gnname pt, (getLexeme t, gup pt)) | (pt,t) <- preTerminals . ttree $ te ] + +-- | Try in order: lexeme, lexeme attributes, node name +getLexeme :: GNode -> [String] +getLexeme node = + case glexeme node of + [] -> fromMaybe [gnname node] $ firstMaybe grab lexemeAttributes + lexs -> lexs + where + grab la = + let match (a, (GConst v)) | a == la = Just v + match _ = Nothing + in firstMaybe match guppy + guppy = gup node + +firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b +firstMaybe fn = listToMaybe . mapMaybe fn + +\end{code} + +% ---------------------------------------------------------------------- +\section{Debugging} +% ---------------------------------------------------------------------- + +\begin{code} +-- Useful for debugging adjunction and substitution nodes +showTagSites :: [TagSite] -> String +showTagSites sites = concat $ intersperse "\n " $ map fn sites + where + fn (TagSite n t b o) = + concat . intersperse "/" $ [ n, showPairs t, showPairs b, o ] +\end{code} + +% ---------------------------------------------------------------------- +\section{Diagnostic messages} +% ---------------------------------------------------------------------- + +Diagnostic messages let us know why a TAG tree is not returned as a result. +Whenever GenI decides to discard a tree, it sets the tdiagnostic field of +the TagElem so that the person using a debugger can find out what went wrong. + +\begin{code} +ts_synIncomplete, ts_tbUnificationFailure :: String +ts_synIncomplete = "syntactically incomplete" +ts_tbUnificationFailure = "top/bot unification failure" + +ts_rootFeatureMismatch :: Flist -> String +ts_rootFeatureMismatch good = "root feature does not unify with " ++ showFlist good + +ts_semIncomplete :: [Pred] -> String +ts_semIncomplete sem = "semantically incomplete - missing: " ++ showSem sem +\end{code} diff --git a/src/NLP/GenI/Test.hs b/src/NLP/GenI/Test.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Test.hs @@ -0,0 +1,36 @@ +-- ---------------------------------------------------------------------- +-- 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. +-- ---------------------------------------------------------------------- + +-- TODO: use somebody else's test framework... do not let this grow into a +-- custom monstrosity. + +module NLP.GenI.Test where + +import Test.QuickCheck ( quickCheck ) +import NLP.GenI.Btypes + +runTests :: IO () +runTests = + do putStrLn $ header "unification" + putStrLn "unification is symmetrical" >> quickCheck prop_unify_sym + putStrLn "everything unifies with underscore" >> quickCheck prop_unify_anon + putStrLn "everything unifies with itself" >> quickCheck prop_unify_self + where + bar = replicate 72 '=' + header x = unlines [bar,x,bar] diff --git a/src/NLP/GenI/unused/Predictors.lhs b/src/NLP/GenI/unused/Predictors.lhs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/unused/Predictors.lhs @@ -0,0 +1,315 @@ +% 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. + +\chapter{Predictor Optimisation} + +One optimisation is to annotate the macros with a set of +\jargon{predictors}. This allows macros to predict that they will +combine with certain (usually) null-semantic trees. For example, a +common noun would predict that it needs a determiner. + +\begin{code} +module Predictors +where +\end{code} + +\begin{code} +import Debug.Trace +import qualified Data.Map as Map +import Data.List (nub, sortBy, groupBy, intersect) +import Monad (when, ap, foldM) +import MonadState (get, put) + +import Bfuncs (Sem, Flist, AvPair, showSem, showAv, isVar) +import Tags (TagElem(TE), emptyTE, idname, tsemantics, substnodes, + derivation, tpredictors, drawTagTrees) +import Configuration (defaultParams) +import Mstate (MS, Gstats, initGstats, addGstats, initMState, + runState, genstats, + incrNumcompar, incrSzchart, incrGeniter, + renameTagElem, + addToInitRep, + getGenRep, lookupGenRep, genRepToList, addListToGenRep, + iapplySubstNode, + nullInitRep, getInitRep, genrep, getSem, selectGiven) + +import Polarity (showLite) +\end{code} + +% ---------------------------------------------------------------------- +\section{Optimisation} +% ---------------------------------------------------------------------- + +We attempt substitution between macro and any predictors that it has. +Whenever we succeed, we can pass the combined tree as a candidate. +Whenever we fail, we have to pass both the macro and its predictors. +This is basically an indirect means of adding some kind of indexing to +the generator's chart. + +Note: there are actually two cases here. For those predictors that +we can substitute into the macro, we return the resulting tree and +discard the predictor. + +\begin{code} +optimisePredictors :: [[TagElem]] -> PredictorMap -> ([[TagElem]], Gstats) +optimisePredictors cands predictmap = + let trees = nub $ concat cands + -- calculate predicted trees + sumup = foldr addGstats initGstats + optTree t = optimisePredictors' predictmap t + optPath p = (r, sumup s) + where (r,s) = unzip $ map optTree p + (res, stats) = optPath trees + treemap = Map.fromList $ zip trees res + -- replace trees with their predicted equivalents + repTree t = lookupWithDefaultFM treemap [t] t + repPath p = concatMap repTree p + {- repPath p = trace ("\n==============\npath\n=============\n" ++ drawTagTrees l) l + where l = repPath' p -} + in (map repPath cands, stats) +\end{code} + +\paragraph{optimisePredictors'} is a helper function that tries to +fulfill as many of a tree's predictors as possible. Any predictors +it cannot use are also returned so that they can be passed to the +generator proper. + +\begin{code} +optimisePredictors' :: PredictorMap -> TagElem -> ([TagElem], Gstats) +optimisePredictors' predictmap te = + let -- grab the predictors (helper fns) + isneg _ e = e < 0 + predictors t = Map.keys $ filterFM isneg $ tpredictors t + ptrees t = concatMap fn (predictors t) + where fn = lookupWithDefaultFM predictmap [] + -- generate + tePtrees = ptrees te + initSt = initMState tePtrees [te] (tsemantics te) defaultParams + (res', st) = runState miniGenerate initSt + -- pick the trees with the largest derivation history + derSz = length.snd.derivation + cmpDerSz t1 t2 = compare (derSz t2) (derSz t1) -- note the inversion + sameDerSz t1 t2 = (derSz t2) == (derSz t1) + groupedres = groupBy sameDerSz $ sortBy cmpDerSz res' + -- return the results + result = head groupedres -- trace ("\n==============\nresults for " ++ idname te ++ "\n=============\n" ++ drawTagTrees res) $ + rejects = concatMap ptrees result + stats = genstats st + -- + debugstr = "\n===================" + ++ "\noptimising " ++ showLite te + ++ "\nptrees: " ++ showLite (tePtrees) + ++ "\n==================== " + errormsg = "Geni: Predictors.optimisePredictors' is broken" + in case () of _ | null tePtrees -> ([te], stats) + | null groupedres -> error errormsg + | otherwise -> (result ++ rejects, stats) +\end{code} + +% ---------------------------------------------------------------------- +\subsection{miniGenerate} +% ---------------------------------------------------------------------- + +miniGenerate is a lightweight version of the generator which operates +on the following principles: + +\begin{enumerate} +\item There is one primary tree (chart) and some secondary trees + (agenda), which should not be confused with auxiliary trees +\item All operations are performed between the primary + tree and the secondary trees, that is, you won't + have any interaction between secondary trees +\item The primary tree may substitute with or be + substituted any number of secondary trees +\item Secondary trees may only be used once +\end{enumerate} + +It is used as a helper function for optimisePredictors. + +\begin{code} +miniGenerate :: MS [TagElem] +miniGenerate = do + nir <- nullInitRep + gr <- getGenRep + if nir then return (concat $ elems gr) else do + incrGeniter 1 + tsem <- getSem + -- choose a secondary tree from the agenda + given <- selectGiven + -- perform any substitutions + chart <- lookupGenRep given + let (res', cost') = unzip $ map (timidSubstitution given) chart + res = concat res' + cost = foldr (+) 0 cost' + incrSzchart (length res) + incrNumcompar cost + -- add any succesful results to the chart + st <- get + put st { genrep = addListToGenRep gr res } + miniGenerate +\end{code} + +\paragraph{timidSubstitution} attempts to perform substitution between +input trees $te_1$ and $te_2$. This is meant strictly to be a helper +function for optimisePredictors, so we'll have a somewhat conservative +and quirky behaviour: +\begin{itemize} +\item If there are no ways to perform substitution, we return the empty +list +\item If there is exactly one way to perform substitution +(either $te_1$ into $te_2$ or vice versa), we +return that substitution. +\item If there is more than one way to do it, we return the empty list. +This is because the situation is ambiguous and could lead to unpredictable +results (see section \ref{sec:optimisePredictors_tricky}) +\end{itemize} + +This is somewhat similar to MState's applySubstitution, except that we +rule out the case of multiple results, and that we do not require the +substitution nodes to be in any particular order. + +\begin{code} +timidSubstitution :: TagElem -> TagElem -> ([TagElem],Int) +timidSubstitution te1 te2 = + let tesem = tsemantics te1 + -- we only substitute tags with no overlaping semantics + notOverlap = null $ intersect (tsemantics te2) tesem + -- we rename tags to do a proper substitution + rte1 = renameTagElem 'A' te1 + rte2 = renameTagElem 'B' te2 + -- perform the substitution + subst t1 t2 = concatMap (iapplySubstNode t1 t2) $ substnodes t2 + res' = (subst rte1 rte2) ++ (subst rte2 rte1) + res = if (length res' == 1) then res' else [] + -- measuring efficiency + cost = fn te1 + fn te2 + where fn t = length $ substnodes t + in if notOverlap then (res, cost) else ([], 0) +\end{code} + +\subsection{Trickiness in optimisePredictors} +\label{sec:optimisePredictors_tricky} + +Rejecting ambiguous substitutions is crucial to the idea that +secondary trees may only be used once. + +Consider the trees for \textit{the N, enemy of N, friend}. +The idea is that we eventually want to generate \textit {the enemy of the +friend}, so the result of optimisePredictors should ideally be something like: +\textit{the friend, the enemy of N} + +But this isn't so easy to achieve. In fact, if we tried to achieve +the above result, we would instead get a highly undesirable result +like this \textit{the friend, the enemy of the N} + +Do you see why the above result is bad? It is because now there is +no way to substitute friend into that noun-substitution node. To +avoid this sort of over-ambitiousness, we avoid ambiguous cases where a +tree could both substitute into or be substituted into another. So we +get a less optimal, but much safer result \textit{the friend, enemy of, +the}: + +% ---------------------------------------------------------------------- +\section{Cleanup} +% ---------------------------------------------------------------------- + +\paragraph{fillPredictors} This is neccesary when either the +predictor optimisation is disabled or if there are some +predictor substitutions which do not succeed. It takes a list of paths +and inserts all required predictors on the paths. + +\begin{code} +fillPredictors :: [[TagElem]] -> PredictorMap -> [[TagElem]] +fillPredictors paths predictmap = + let isneg _ pol = pol < 0 + getP = lookupWithDefaultFM predictmap [] + predictors te = Map.keys $ filterFM isneg $ tpredictors te + addP te = te : (concatMap getP $ predictors te) + in map (\p -> nub $ concatMap addP p) paths +\end{code} + +% -------------------------------------------------------------------- +\section{Instatiation of predictors} +% -------------------------------------------------------------------- + +We combine the predictors from the lexicon and macros. The idea is +to do this in a way which lets the grammar writer be lazy while having +as simple and predictable a behaviour as possible. Any predictors that +the lexicon has must correspond to some variable predictor in the +macros, so if I say in the lexicon that a tree as predictor +$+vsup:avoir$ there had better be a $+vsup:X$ in the macros to back it +up. + +\begin{code} +combinePredictors tt le = + let -- fn to add an item to the predictors map + addP (fv,c) fm = addToFM_C (+) fm fv c + -- lexicon predictors + lpr = sort $ ipredictors le + -- tree predictors (variable vs constant predictors) + tpr = sort $ ptpredictors tt + isVpr ((f,v),_) = (not $ null v) && isVar v + (varPr,constPr) = partition isVpr tpr + constPrFm = foldr addP Map.empty constPr + -- separating the charges from the fv + (lfv, lc) = unzip lpr + (vfv, vc) = unzip varPr + -- the unification + unify [] [] = [] + unify ((tf,tv):tnext) ((lf,lv):lnext) + | tf /= lf = error errmsg + | isVar lv = error errvlex + | isVar tv = (lf,lv):(unify (substFlist' tnext (tv,lv)) lnext) + | lv == tv = (lf,lv):(unify tnext lnext) + | otherwise = error errmsg + unification = unify vfv lfv + -- error messages in case things don't line up + errmsg = "Word '" ++ (iword le) ++ "' does not correctly " + ++ " instantiate the variable predictors in tree " + ++ (itreename le) + ++ "\n Tree predictors: " ++ (show $ map fst varPr) + ++ "\n Word predictors: " ++ (show $ map fst lpr) + ++ "\n Hint: only the variable predictors should be instantiated" + errvlex = "Word '" ++ (iword le) ++ "' contains variable " + ++ " predictors in " ++ (show $ map fst lpr) + in if (lc == vc) -- note: this implies list equality + then foldr addP constPrFm $ zip unification lc + else error errmsg +\end{code} + + +% ---------------------------------------------------------------------- +\section{PredictorMap} +% ---------------------------------------------------------------------- + +We create a map between predictors and the trees that provide them. + +\begin{code} +type PredictorMap = Map AvPair [TagElem] +\end{code} + +\begin{code} +mapByPredictors :: [TagElem] -> PredictorMap +mapByPredictors trees = foldr mapByPredictors' Map.empty trees + +mapByPredictors' :: TagElem -> PredictorMap -> PredictorMap +mapByPredictors' tree fm = + let ispos _ pol = (pol > 0) + predictors = Map.keys $ filterFM ispos $ tpredictors tree + addp p f = addToFM_C (++) f p [tree] + in foldr addp fm predictors +\end{code}