packages feed

GenI 0.16.1 → 0.17.3

raw patch · 87 files changed

+16408/−3753 lines, 87 filesdep +filepathdep −HaXmldep −libGenIdep −wxcoredep ~HUnitdep ~QuickCheckdep ~basesetup-changedbinary-added

Dependencies added: filepath

Dependencies removed: HaXml, libGenI, wxcore

Dependency ranges changed: HUnit, QuickCheck, base, binary, containers, mtl, parsec, process, wx

Files

+ AUTHORS view
@@ -0,0 +1,2 @@+Carlos Areces+Eric Kow
− EnableGUI.hs 
@@ -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
GenI.cabal view
@@ -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+
+ INSTALL view
@@ -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
LICENSE view
@@ -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.
− MainGeni.lhs 
@@ -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.
+ NEWS view
@@ -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)
− NLP/GenI/BuilderGui.lhs 
@@ -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}
− NLP/GenI/CkyEarley/CkyGui.lhs 
@@ -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}
− NLP/GenI/Console.hs 
@@ -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)
− NLP/GenI/Graphviz.hs 
@@ -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-     <http://www.research.att.com/sw/tools/graphviz>--}--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
− NLP/GenI/GraphvizShow.lhs 
@@ -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}
− NLP/GenI/GraphvizShowPolarity.lhs 
@@ -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-
− NLP/GenI/Gui.lhs 
@@ -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}
− NLP/GenI/GuiHelper.lhs 
@@ -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}--
− NLP/GenI/Simple/SimpleGui.lhs 
@@ -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}
− NLP/GenI/SysGeni.lhs 
@@ -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}-
− NLP/GenI/unused/Predictors.lhs 
@@ -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}
+ README view
@@ -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.
Setup.lhs view
@@ -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 ---------------------------------
+ etc/macstuff/Info.plist view
@@ -0,0 +1,36 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">+<plist version="1.0">+<dict>+	<key>CFBundleDevelopmentRegion</key>+	<string>English</string>+	<key>CFBundleExecutable</key>+	<string>geni</string>+	<key>CFBundleGetInfoString</key>+	<string>GenI unstable 0.8</string>+	<key>CFBundleIconFile</key>+	<string>wxmac.icns</string>+	<key>CFBundleIdentifier</key>+	<string>fr.loria.geni</string>+	<key>CFBundleInfoDictionaryVersion</key>+	<string>6.0</string>+	<key>CFBundleLongVersionString</key>+	<string>0.8, (c) 2005 LORIA</string>+	<key>CFBundleName</key>+	<string>GenI</string>+	<key>CFBundlePackageType</key>+	<string>APPL</string>+	<key>CFBundleShortVersionString</key>+	<string>0.8</string>+	<key>CFBundleSignature</key>+	<string>????</string>+	<key>CFBundleVersion</key>+	<string>0.8</string>+	<key>CSResourcesFileMapped</key>+	<true/>+	<key>LSRequiresCarbon</key>+	<true/>+	<key>NSHumanReadableCopyright</key>+	<string>Copyright 2005 LORIA</string>+</dict>+</plist>
+ etc/macstuff/macosx-app view
@@ -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] <program (a.out)>"+        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 ""
+ etc/macstuff/wxmac.icns view

binary file changed (absent → 46234 bytes)

+ examples/artificial/lexicon view
@@ -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()]
+ examples/artificial/macros view
@@ -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]+}+
+ examples/artificial/suite view
@@ -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()]
+ examples/artificial/suite-bad view
@@ -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()]+
+ examples/chatnoir/lexicon view
@@ -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)]+
+ examples/chatnoir/macros view
@@ -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:
+ examples/chatnoir/suite view
@@ -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 ]
+ examples/demo/README view
@@ -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+++++   +++
+ examples/demo/lexicon view
@@ -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)]
+ examples/demo/macros view
@@ -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 ]+    }+}+
+ examples/demo/suite view
@@ -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)+	     ]++
+ examples/ej/lexicon view
@@ -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)]
+ examples/ej/macros view
@@ -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]![]+	}
+ examples/ej/suite view
@@ -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]+
+ examples/nosemantics/README.txt view
@@ -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
+ examples/nosemantics/lexicon view
@@ -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()
+ examples/nosemantics/macros view
@@ -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++{+}+
+ examples/promettre/lexicon view
@@ -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)]++
+ examples/promettre/macros view
@@ -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:++
+ examples/promettre/morphinfo view
@@ -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+% -------------------------------------------------------------------- +% +
+ examples/promettre/suite view
@@ -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)+	     ]
+ examples/xmg-example/Makefile view
@@ -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 $(<D), $(<F) and $(@F)+$(GRAMMAR_DIR)/$(MACROS_FILE): $(GRAMMAR_RAW_MG)+	$(ECHO_STATUS) compiling semantic macros only+	$(SILENTLY) MetaTAG $< --mac -s $(basename $@)++$(LEXICON_DIR)/$(MACROS_FILE): $(GRAMMAR_DIR)/$(MACROS_FILE)+	$(SILENTLY) cp -f $< $@++#convert lexicon to geni format using semantic macros+%.glex: %.lex $(LEXICON_DIR)/$(MACROS_FILE)+	$(ECHO_STATUS) lexically converting $<+	$(SILENTLY) lexConverter -L -g -i $< -o $@++#convert lexicon to geni format+%.gmorph: %.mph+	$(SILENTLY) sed -e 's/pos/cat/g' -e 's/=/:/g' -e 's/;/ /g' < $< > $@
+ examples/xmg-example/README view
@@ -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
+ examples/xmg-example/grammar/Arguments.mg view
@@ -0,0 +1,146 @@+class  VerbalArgument+export+        ?xS ?xV+declare+        ?xS ?xV+{+        <syn>{+                node ?xS(color=white)[cat = s]{+                        node ?xV(color=white)[cat = v]+                }+        }+}++class  SubjectAgreement+export+        ?xSubjAgr ?xVAgr+declare+        ?xSubjAgr ?xVAgr ?fX ?fY ?fZ+{+        <syn>{+                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+{+        <syn>{+                node ?xS[cat = s]{+                        node ?xSubj(color=red)[cat = @{cl,n}]+                        node ?xV[cat = v]+                };+                ?xSubj = ?xSubjAgr;+                ?xV = ?xVAgr+        }+}++class  CanonicalSubject+import+        CanSubject[]+	SubjectSem[]+{+        <syn>{+             node ?xSubj(color=red,mark=subst)[cat = n]+        };+	?xSubj = ?xSem+}++class  CliticSubject+import+        CanSubject[]+	SubjectSem[]+{+        <syn>{+             node ?xSubj(color=red,mark=subst)[cat = cl]+        };+	?xSubj = ?xSem+}++class  RelativeSubject+import+        VerbalArgument[]+        SubjectAgreement[]+	SubjectSem[]+declare+        ?xSubj ?xfoot ?xRel ?fU ?fY ?fZ ?xQui+{+        <syn>{+                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+{+        <syn>{+                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+{+        <syn>{+                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 ;+	<syn>{ ?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]+}
+ examples/xmg-example/grammar/Entete.mg view
@@ -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
+ examples/xmg-example/grammar/Evaluations.mg view
@@ -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+
+ examples/xmg-example/grammar/Misc.mg view
@@ -0,0 +1,32 @@+class propername+import+	nSem[]+declare+        ?xN+{+        <syn>{+                node xN(color=red,mark=anchor)[cat = n,bot=[pers = 3]]+        };+	?xN = ?xSem+}++class Copule+declare+        ?xV+{+        <syn>{+                node xV(color=red,mark=anchor)[cat = v]+        }+}++class Clitic+import+	nSem[]+declare+        ?xCl+{+        <syn>{+                node xCl(color=red,mark=anchor)[cat = cl]+        };+	?xCl = ?xSem+}
+ examples/xmg-example/grammar/Sem.mg view
@@ -0,0 +1,80 @@+%% Semantic classes+class  basicProperty+export ?E ?L0 ?Rel+declare ?E ?L0 ?Rel+      {+        <sem>{+                L0:Rel(E)+              }+              *=[label0 = L0, rel =Rel,arg0=E]+          }++% unary relation with event variable+class  unaryRel+import basicProperty[]+declare ?X ?Theta1+      {+        <sem>{+                 L0:Theta1(E,X)+              }+              *=[arg1=X,theta1 =Theta1]+          }++% binary relation with event variable+class  binaryRel+import unaryRel[]+declare ?X ?Theta2+      {+        <sem>{+                 L0:Theta2(E,X)+              }+              *=[arg2=X,theta2 =Theta2]+          }++% Verb arguments+class  SubjectSem+export+        ?xSem+declare+        ?xSem ?X ?L+{+        <syn>{+                node xSem[top=[idx=X,label=L]]+        }*=[subjectI = X,subjectL = L]+}++class  ObjectSem+export+        ?xSem+declare+        ?xSem ?X ?L+{+        <syn>{+                node xSem[top=[idx=X,label=L]]+        }*=[objectI = X,objectL = L]+}++class  CAgentSem+export+        ?xSem+declare+        ?xSem ?X ?L+{+        <syn>{+                node xSem[top=[idx=X,label=L]]+        }*=[cagentI = X,cagentL = L]+}++%% Noun semantics+class  nSem+export+        ?xSem+declare+        ?xSem ?X ?L+{+        <syn>{+                node ?xSem[cat=@{cl,n},top=[idx=X, label=L]]+        };+        basicProperty[]*=[arg0=X]+}+
+ examples/xmg-example/grammar/VerbMorph.mg view
@@ -0,0 +1,78 @@+class VerbalMorphology+export+   ?xS ?xVN ?xV+declare+   ?xS ?xVN ?xV ?I ?L+{+        <syn>{+                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+{+        <syn>{+                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+{+        <syn>{+                     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]+	}+}
+ examples/xmg-example/grammar/demo-corpus-latin1.txt view
@@ -0,0 +1,6 @@+Jean aime Marie.+Jean est appelé par Marie.+Marie aime Jean.+Marie appelle.+Jean qui appelle aime Marie.+ils appellent.
+ examples/xmg-example/grammar/parse-corpus.sh view
@@ -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
+ examples/xmg-example/lexicon/demo-lemma-latin1.lex view
@@ -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:
+ examples/xmg-example/lexicon/demo-morph-latin1.mph view
@@ -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;]
+ examples/xmg-example/suite view
@@ -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]++
− macstuff/macosx-app 
@@ -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] <program (a.out)>"-        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 ""
+ src/EnableGUI.hs view
@@ -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
+ src/MainGeni.lhs view
@@ -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.
+ src/NLP/GenI/Automaton.lhs view
@@ -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}+
+ src/NLP/GenI/Btypes.lhs view
@@ -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}+}
+ src/NLP/GenI/BtypesBinary.hs view
@@ -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)+
+ src/NLP/GenI/Builder.lhs view
@@ -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}++
+ src/NLP/GenI/BuilderGui.lhs view
@@ -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}
+ src/NLP/GenI/CkyEarley/CkyBuilder.lhs view
@@ -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).++
+ src/NLP/GenI/CkyEarley/CkyGui.lhs view
@@ -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}
+ src/NLP/GenI/Configuration.lhs view
@@ -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}++
+ src/NLP/GenI/Console.hs view
@@ -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)
+ src/NLP/GenI/General.hs view
@@ -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
+ src/NLP/GenI/Geni.lhs view
@@ -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}++
+ src/NLP/GenI/GeniParsers.lhs view
@@ -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}++
+ src/NLP/GenI/GeniShow.lhs view
@@ -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}
+ src/NLP/GenI/Graphviz.hs view
@@ -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+     <http://www.research.att.com/sw/tools/graphviz>+-}++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
+ src/NLP/GenI/GraphvizShow.lhs view
@@ -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}
+ src/NLP/GenI/GraphvizShowPolarity.lhs view
@@ -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+
+ src/NLP/GenI/Gui.lhs view
@@ -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}
+ src/NLP/GenI/GuiHelper.lhs view
@@ -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}++
+ src/NLP/GenI/Morphology.lhs view
@@ -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}
+ src/NLP/GenI/Polarity.lhs view
@@ -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}
+ src/NLP/GenI/Simple/SimpleBuilder.lhs view
@@ -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}+
+ src/NLP/GenI/Simple/SimpleGui.lhs view
@@ -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}
+ src/NLP/GenI/Statistics.hs view
@@ -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)+
+ src/NLP/GenI/SysGeni.lhs view
@@ -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}+
+ src/NLP/GenI/Tags.lhs view
@@ -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}
+ src/NLP/GenI/Test.hs view
@@ -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]
+ src/NLP/GenI/unused/Predictors.lhs view
@@ -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}