GenI (empty) → 0.16
raw patch · 17 files changed
+4171/−0 lines, 17 filesdep +HUnitdep +HaXmldep +QuickCheckbuild-type:Customsetup-changed
Dependencies added: HUnit, HaXml, QuickCheck, base, binary, containers, directory, haskell98, libGenI, mtl, parsec, process, wx, wxcore
Files
- EnableGUI.hs +38/−0
- GenI.cabal +38/−0
- LICENSE +340/−0
- MainGeni.lhs +87/−0
- NLP/GenI/BuilderGui.lhs +34/−0
- NLP/GenI/CkyEarley/CkyGui.lhs +456/−0
- NLP/GenI/Console.hs +191/−0
- NLP/GenI/Graphviz.hs +212/−0
- NLP/GenI/GraphvizShow.lhs +221/−0
- NLP/GenI/GraphvizShowPolarity.lhs +129/−0
- NLP/GenI/Gui.lhs +762/−0
- NLP/GenI/GuiHelper.lhs +858/−0
- NLP/GenI/Simple/SimpleGui.lhs +200/−0
- NLP/GenI/SysGeni.lhs +108/−0
- NLP/GenI/unused/Predictors.lhs +315/−0
- Setup.lhs +68/−0
- macstuff/macosx-app +114/−0
+ 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
+ GenI.cabal view
@@ -0,0 +1,38 @@+Name: GenI+Version: 0.16+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: GenI, an FB-LTAG surface realiser+Description: GenI, a natural language generator (more precisely, an FB-LTAG surface realiser)+Maintainer: eric.kow@loria.fr++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++data-files: GenI.cabal macstuff/macosx-app++Flag splitBase+ description: Choose the new smaller, split-up base package.++Executable geni+ Main-Is: MainGeni.lhs+ Hs-Source-Dirs: .+ Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses+ Ghc-options: -Wall+ if flag(splitBase)+ Build-Depends: base >= 3, binary, wx, wxcore, haskell98, mtl, parsec,+ QuickCheck, HUnit, HaXml >=1.16, libGenI,+ process > 1, directory > 1, containers >= 0.1+ else+ Build-Depends: base < 3, binary, wx, wxcore, haskell98, mtl, parsec,+ QuickCheck, HUnit, HaXml >=1.16, libGenI
+ LICENSE view
@@ -0,0 +1,340 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+ 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.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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+++Also add information on how to contact you by electronic and paper mail.++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 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.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ MainGeni.lhs view
@@ -0,0 +1,87 @@+% 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(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.
+ 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.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 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 #-}+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 view
@@ -0,0 +1,191 @@+-- 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 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
+ NLP/GenI/GraphvizShow.lhs view
@@ -0,0 +1,221 @@+% 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 #-} +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 view
@@ -0,0 +1,129 @@+% 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 #-} +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 view
@@ -0,0 +1,762 @@+% 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 view
@@ -0,0 +1,858 @@+% 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 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}+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 view
@@ -0,0 +1,108 @@+% 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.Exit (ExitCode)+import System.IO (Handle)++import NLP.GenI.General((///))++#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}+#ifdef darwin_TARGET_OS +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 +#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 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}
+ Setup.lhs view
@@ -0,0 +1,68 @@+#!/usr/bin/env runhaskell++This Cabal setup script is meant to be used with programs that use the+wxHaskell toolkit. The problem is that on MacOS X, you have to post+process each GUI with the 'macosx-app' shell script (from wxhaskell) so+that it actually responds to user input instead of just sitting there+looking pretty.++> import Control.Monad (foldM_)+> import System.Cmd+> import System.Exit+> import System.Info (os)+>+> import Distribution.PackageDescription+> import Distribution.Simple.Setup+> import Distribution.Simple+> import Distribution.Simple.LocalBuildInfo++Configure this stuff+--------------------+Put here the list of executables which contain a GUI. If they all+contain a GUI (or you don't really care that much), just put Nothing++> mRestrictTo :: Maybe [String]+> mRestrictTo = Just ["geni"]++Normally, this should just be "macosx-app"++> macosxApp :: String+> macosxApp = "macstuff/macosx-app"++Nothing to configure from here on+---------------------------------+Note that we assume anybody running on Darwin is running OS X, probably+not the right thing to do, but frankly... who runs Darwin anyway? Note+also that this script is equivalent to the vanilla one if you're running+on other operating systems.++> main :: IO ()+> main =+> do case os of+> "darwin" -> defaultMainWithHooks (simpleUserHooks { postBuild = macifyHook })+> _ -> defaultMain++> macifyHook _ _ pkg localb =+> foldM_ (next $ macify.binPath) ExitSuccess guiExes+> where+> allExes = map exeName $ executables pkg+> guiExes = case mRestrictTo of+> Nothing -> allExes+> Just rs -> filter (`elem` rs) allExes+> next _ x@(ExitFailure _) _ = return x+> next _ _ b = macify (binPath b)+> binPath x = buildDir localb /// x /// x++> macify :: FilePath -> IO ExitCode+> macify x = system $ unwords $ [ "chmod u+x", macosxApp, ";"+> , macosxApp, x ]++This handly little FilePath concatenation function was stolen from+darcs. Note that darcs is GPL; if this bothers you, ask David Roundy.++> (///) :: FilePath -> FilePath -> FilePath+> ""///b = b+> a///"" = a+> a///b = a ++ "/" ++ b++
+ macstuff/macosx-app view
@@ -0,0 +1,114 @@+#!/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 ""