diff --git a/EnableGUI.hs b/EnableGUI.hs new file mode 100644 --- /dev/null +++ b/EnableGUI.hs @@ -0,0 +1,38 @@ +-- this is just to get the GUI running on my mac, no big deal +-- note: for Observe.lhs: -fglasgow-exts -cpp -package concurrent + +module EnableGUI(enableGUI) where + +import Data.Int +import Foreign +import qualified Main as Main2 + +{- +import Posix +import Concurrent +import Control.Exception +catchCtrlC = do + main_thread <- myThreadId + installHandler sigINT (Catch (hupHandler main_thread)) Nothing + where + hupHandler :: ThreadId -> IO () + hupHandler main_thread + = throwTo main_thread (ErrorCall "Control-C") +-} + +main = do (enableGUI >> Main2.main) + +type ProcessSerialNumber = Int64 + +foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 +foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () +foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () +foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () + +enableGUI = alloca $ \psn -> do + getCurrentProcess psn + cgsDefaultConnection + cpsEnableForegroundOperation psn + cpsSignalAppReady psn + cpsSetFrontProcess psn diff --git a/GenI.cabal b/GenI.cabal new file mode 100644 --- /dev/null +++ b/GenI.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + 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. + + , 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. diff --git a/MainGeni.lhs b/MainGeni.lhs new file mode 100644 --- /dev/null +++ b/MainGeni.lhs @@ -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. diff --git a/NLP/GenI/BuilderGui.lhs b/NLP/GenI/BuilderGui.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/BuilderGui.lhs @@ -0,0 +1,34 @@ +% GenI surface realiser +% Copyright (C) 2005 Carlos Areces and Eric Kow +% +% This program is free software; you can redistribute it and/or +% modify it under the terms of the GNU General Public License +% as published by the Free Software Foundation; either version 2 +% of the License, or (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +\begin{code} +module NLP.GenI.BuilderGui +where + +import Graphics.UI.WXCore + +import qualified NLP.GenI.Builder as B +import NLP.GenI.Geni (ProgStateRef, GeniResult) +import NLP.GenI.Configuration (Params) +import NLP.GenI.Statistics (Statistics) +\end{code} + +\begin{code} +data BuilderGui = BuilderGui + { resultsPnl :: forall a . ProgStateRef -> (Window a) -> IO ([GeniResult],Statistics,Layout) + , debuggerPnl :: forall a . (Window a) -> Params -> B.Input -> String -> IO Layout } +\end{code} diff --git a/NLP/GenI/CkyEarley/CkyGui.lhs b/NLP/GenI/CkyEarley/CkyGui.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/CkyEarley/CkyGui.lhs @@ -0,0 +1,456 @@ +% GenI surface realiser +% Copyright (C) 2005 Carlos Areces and Eric Kow +% +% This program is free software; you can redistribute it and/or +% modify it under the terms of the GNU General Public License +% as published by the Free Software Foundation; either version 2 +% of the License, or (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +\chapter{CKY Gui} + +\begin{code} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +module NLP.GenI.CkyEarley.CkyGui where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX hiding (when) +import Graphics.UI.WXCore hiding (when) + +import qualified Control.Monad as Monad +import Control.Monad (liftM) + +import Data.IORef +import Data.List (intersperse, findIndex, sort) +import qualified Data.Map as Map +import Data.Maybe (listToMaybe, catMaybes) +import Data.Tree + +import NLP.GenI.Statistics (Statistics) + +import NLP.GenI.Automaton + ( NFA(states, transitions, startSt, finalStList) + , addTrans ) +import qualified NLP.GenI.Builder as B +import qualified NLP.GenI.BuilderGui as BG +import NLP.GenI.Btypes ( GNode, gnname ) + +import NLP.GenI.CkyEarley.CkyBuilder + ( ckyBuilder, earleyBuilder, CkyStatus, CkyItem(..), ChartId + , ciRoot, ciAdjDone + , bitVectorToSem, findId + , extractDerivations + , theResults, theAgenda, theChart, theTrash + , emptySentenceAut, mJoinAutomata, mAutomatonPaths + , unpackItemToAuts, + ) +import NLP.GenI.Configuration ( Params(..) ) + +import NLP.GenI.Geni + ( ProgStateRef, runGeni, GeniResult ) +import NLP.GenI.General ( boundsCheck, geniBug ) +import NLP.GenI.GuiHelper + ( messageGui, toSentence + , debuggerPanel, DebuggerItemBar + , addGvHandler, modifyGvParams + , GraphvizGuiSt(gvitems, gvsel, gvparams), GvIO, setGvSel + , graphvizGui, newGvRef, setGvDrawables, + ) + +import NLP.GenI.Tags ( idname, tsemantics, ttree, TagElem ) + +import NLP.GenI.Graphviz + ( GraphvizShow(..), gvNode, gvEdge, gvSubgraph, gvUnlines, gvShowTree + , gvNewline + , GraphvizShowNode(..) ) +\end{code} +} + +% -------------------------------------------------------------------- +\section{Interface} +% -------------------------------------------------------------------- + +\begin{code} +ckyGui, earleyGui :: BG.BuilderGui +ckyGui = ckyOrEarleyGui False +earleyGui = ckyOrEarleyGui True + +ckyOrEarleyGui :: Bool -> BG.BuilderGui +ckyOrEarleyGui isEarley = BG.BuilderGui { + BG.resultsPnl = resultsPnl builder + , BG.debuggerPnl = ckyDebuggerTab builder } + where builder = if isEarley then earleyBuilder else ckyBuilder + +resultsPnl :: B.Builder CkyStatus CkyItem Params -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) +resultsPnl builder pstRef f = + do (sentences, stats, st) <- runGeni pstRef builder + (lay, _, _) <- realisationsGui pstRef f (theResults st) + return (sentences, stats, lay) +\end{code} + +% -------------------------------------------------------------------- +\section{Results} +\label{sec:cky_results_gui} +% -------------------------------------------------------------------- + +\begin{code} +-- | Browser for the results (if there are any) +realisationsGui :: ProgStateRef -> (Window a) -> [CkyItem] + -> GvIO CkyDebugParams (Maybe CkyItem) +realisationsGui _ f [] = + do m <- messageGui f "No results found" + gvRef <- newGvRef initCkyDebugParams [] "" + return (m, gvRef, return ()) +realisationsGui _ f resultsRaw = + do let tip = "result" + results = map Just resultsRaw + labels = map (toSentence.ciSourceTree) resultsRaw + gvRef <- newGvRef initCkyDebugParams labels tip + setGvDrawables gvRef results + graphvizGui f "cky-results" gvRef +\end{code} + +\begin{code} +data CkyDebugParams = + CkyDebugParams { debugShowFeats :: Bool + , debugShowFullDerv :: Bool + , debugShowSourceTree :: Bool + , debugWhichDerivation :: Int + , debugNodeChoice :: [ChartId] } + +initCkyDebugParams :: CkyDebugParams +initCkyDebugParams = + CkyDebugParams { debugShowFeats = False + , debugShowFullDerv = False + , debugShowSourceTree = False + , debugWhichDerivation = 0 + , debugNodeChoice = [] } + +-- would be nice if Haskell sugared this kind of stuff for us +setDebugShowFeats, setDebugShowFullDerv, setDebugShowSourceTree :: Bool -> CkyDebugParams -> CkyDebugParams +setDebugShowFeats b x = x { debugShowFeats = b } +setDebugShowFullDerv b x = x { debugShowFullDerv = b } +setDebugShowSourceTree b x = x { debugShowSourceTree = b } + +setDebugWhichDerivation :: Int -> CkyDebugParams -> CkyDebugParams +setDebugWhichDerivation w x = x { debugWhichDerivation = w } + +clearDebugNodeChoice :: CkyDebugParams -> CkyDebugParams +clearDebugNodeChoice x = x { debugNodeChoice = [] } + +pushDebugNodeChoice :: ChartId -> CkyDebugParams -> CkyDebugParams +pushDebugNodeChoice w x = x { debugNodeChoice = w:(debugNodeChoice x) } + +popDebugNodeChoice :: CkyDebugParams -> Maybe (ChartId, CkyDebugParams) +popDebugNodeChoice x = + case debugNodeChoice x of + [] -> Nothing + (h:t) -> Just (h, x { debugNodeChoice = t }) + +ckyDebuggerTab :: B.Builder CkyStatus CkyItem Params + -> (Window a) -> Params -> B.Input -> String -> IO Layout +ckyDebuggerTab builder = debuggerPanel builder initCkyDebugParams stateToGv ckyItemBar + where + stateToGv :: CkyStatus -> ([(Maybe (CkyStatus,CkyItem))], [String]) + stateToGv st = + let agenda = section "AGENDA" $ theAgenda st + trash = section "TRASH" $ theTrash st + chart = section "CHART" $ theChart st + results = section "RESULTS" $ theResults st + -- + section n i = hd : (map tlFn i) + where hd = (Nothing, "___" ++ n ++ "___") + tlFn x = (Just (st,x), labelFn x) + showPaths = const "" + {- if (polarised $ genconfig st) + then (\t -> " (" ++ showPolPaths t ++ ")") + else const "" -} + gorn i = case gornAddressStr (ttree $ ciSourceTree i) (ciNode i) of + Nothing -> geniBug "A chart item claims to have a node which is not in its tree" + Just x -> x + isComplete i = ciRoot i && ciAdjDone i + -- try displaying as an automaton, or if all else fails, the tree sentence + fancyToSentence ci = + let mergedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts st ci + boringSentence = toSentence $ ciSourceTree ci + in case mAutomatonPaths mergedAut of + [] -> boringSentence + (h:_) -> unwords $ map fst $ h + labelFn i = unwords [ completeStr ++ idStr ++ gornStr + , fancyToSentence i + , "/" ++ (idname $ ciSourceTree i) + , showPaths i + ] + where idStr = show $ ciId i + completeStr = if isComplete i then ">" else "" + gornStr = if isComplete i then "" else " g" ++ (gorn i) + in unzip $ agenda ++ chart ++ results ++ trash + +ckyItemBar :: DebuggerItemBar CkyDebugParams (CkyStatus, CkyItem) +ckyItemBar f gvRef updaterFn = + do ib <- panel f [] + -- select derivation + derTxt <- staticText ib [] + derChoice <- choice ib [ tooltip := "Select a derivation" ] + jumpBtn <- button ib [ text := "Go to node" ] + unjumpBtn <- button ib [ text := "Pop back" ] + jumpChoice <- choice ib [ tooltip := "Jump to item." ] + let onDerChoice = + do sel <- get derChoice selection + modifyGvParams gvRef (setDebugWhichDerivation sel) + gvSt <- readIORef gvRef + -- update the list of jump choices + case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just (s,c)) -> do + let t = selectedDerivation (gvparams gvSt) s c + nodes = map show $ sort $ derivationNodes t + set jumpChoice [ items := nodes, selection := 0 ] + updaterFn + _ -> return () + set derChoice [ on select := onDerChoice ] + -- show features + detailsChk <- checkBox ib [ text := "features" + , enabled := False, checked := False ] + fullDervChk <- checkBox ib [ text := "full derivation" + , checked := False ] + srcTreeChk <- checkBox ib [ text := "src tree" + , checked := False ] + let setChkBoxUpdater box setter = + set box [ on command := do isChecked <- get box checked + modifyGvParams gvRef $ setter isChecked + updaterFn ] + setChkBoxUpdater detailsChk setDebugShowFeats + setChkBoxUpdater fullDervChk setDebugShowFullDerv + setChkBoxUpdater srcTreeChk setDebugShowSourceTree + -- make detailsChk conditioned on srcTreeChk + set srcTreeChk [ on command :~ \x -> x >> do + isChecked <- get srcTreeChk checked + set detailsChk [ enabled := isChecked ] + ] + -- add a handler for when an item is selected: + -- update the list of derivations to choose from + let updateDerTxt t = set derTxt [ text := "Deriviations (" ++ t ++ ")" ] + handler gvSt = + do case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just (s,c)) -> + do let derivations = extractDerivations s c + dervLabels = zipWith (\n _ -> show n) ([1..]::[Int]) derivations + set derChoice [ enabled := True, items := dervLabels, selection := 0 ] + onDerChoice + updateDerTxt $ show $ length derivations + _ -> + do set derChoice [ enabled := False, items := [] ] + updateDerTxt "n/a" + addGvHandler gvRef handler + -- call the handler to react to the first selection + handler `liftM` readIORef gvRef + -- pushing and popping between nodes + let jumpToNode jmpTo = + do gvSt <- readIORef gvRef + let chartItems = Map.elems $ gvitems gvSt + case findIndex isJmpTo chartItems of + Nothing -> geniBug $ "Was asked to see node " ++ (show jmpTo) ++ ", which is not in the list" + Just x -> + do setGvSel gvRef x + modifyGvParams gvRef (setDebugWhichDerivation 0) + readIORef gvRef >>= handler + updaterFn + where isJmpTo Nothing = False + isJmpTo (Just (_,x)) = ciId x == jmpTo + set jumpBtn [ on command := do + gvSt <- readIORef gvRef + case Map.lookup (gvsel gvSt) (gvitems gvSt) of + Just (Just x) -> modifyGvParams gvRef (pushDebugNodeChoice $ (ciId.snd) x) + _ -> return () + jmpSel <- get jumpChoice selection + jmpItms <- get jumpChoice items + let jmpTo = (read $ jmpItms !! jmpSel) + jumpToNode jmpTo ] + + set unjumpBtn [ on command := do + gvSt <- readIORef gvRef + case popDebugNodeChoice (gvparams gvSt) of + Nothing -> return () + Just (x,gvParam) -> do modifyGvParams gvRef (const gvParam) + jumpToNode x ] + -- + return $ hfloatCentre $ container ib $ column 0 $ + [ row 5 + [ label "Show...", widget fullDervChk, widget srcTreeChk, widget detailsChk ] + , row 5 + [ widget derTxt, widget derChoice + , hspace 5, label "Node", widget jumpChoice, widget jumpBtn, widget unjumpBtn ] ] +\end{code} + +\section{Helper code} + +\begin{code} + +gornAddressStr :: Tree GNode -> GNode -> Maybe String +gornAddressStr t target = + (concat . (intersperse ".") . (map show)) `liftM` gornAddress t target + +gornAddress :: Tree GNode -> GNode -> Maybe [Int] +gornAddress tr target = reverse `liftM` helper [] tr + where + helper current (Node x _) | (gnname x == gnname target) = Just current + helper current (Node _ l) = listToMaybe $ catMaybes $ + zipWith (\c t -> helper (c:current) t) [1..] l + + +selectedDerivation :: CkyDebugParams -> CkyStatus -> CkyItem -> Tree (ChartId, String) +selectedDerivation f s c = + let derivations = extractDerivations s c + whichDer = debugWhichDerivation f + in if boundsCheck whichDer derivations + then derivations !! whichDer + else geniBug $ "Bounds check failed on derivations selector:\n" + ++ "Selected derivation: " ++ (show whichDer) ++ "\n" + ++ "Bounds: 0 to " ++ (show $ length derivations - 1) + +derivationNodes :: Tree (ChartId, String) -> [ChartId] +derivationNodes = (map fst).flatten + +-- | Remove na and subst or adj completion links +thinDerivationTree :: Tree (ChartId, String) -> Tree (ChartId, String) +thinDerivationTree = + let thinlst = ["no-adj", "subst", "adj" ] + helper n@(Node _ []) = n + -- this is made complicated for fancy highlighting to work + helper (Node (i,op) [k]) | op `elem` thinlst = (Node (i,op2) k2) + where (Node (_,op2) k2) = helper k + helper (Node x kids) = (Node x $ map helper kids) + in helper + +instance GraphvizShow CkyDebugParams (CkyStatus, CkyItem) where + graphvizLabel f (_,c) = graphvizLabel f c + graphvizParams f (_,c) = graphvizParams f c + graphvizShowAsSubgraph f p (s,c) = + let color_ x = ("color", x) + label_ x = ("label", x) + style_ x = ("style", x) + arrowtail_ x = ("arrowtail", x) + -- + substColor = color_ "blue" + adjColor = color_ "red" + -- + edgeParams (_ ,"no-adj") = [ label_ "na" ] + edgeParams (_, "kids" ) = [] + edgeParams (_, "init" ) = [ label_ "i" ] + edgeParams (_, "subst" ) = [ substColor ] + edgeParams (_, "adj" ) = [ adjColor ] + edgeParams (_, "subst-finish") = [ substColor, style_ "bold" , arrowtail_ "normal" ] + edgeParams (_, "adj-finish") = [ adjColor , style_ "dashed, bold", arrowtail_ "normal" ] + edgeParams (_, k) = [ ("label", "UNKNOWN: " ++ k) ] + -- + whichDer = debugWhichDerivation f + showFullDer = debugShowFullDerv f + showSrcTree = debugShowSourceTree f + showTree i t = gvSubgraph $ gvShowTree edgeParams (s,showFullDer, [ciId c]) prfx t + where prfx = p ++ "t" ++ (show i) + gvDerv = showTree whichDer $ if showFullDer then t else thinDerivationTree t + where t = selectedDerivation f s c + -- + joinedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts s c + gvAut = graphvizShowAsSubgraph () (p ++ "aut") joinedAut + -- + showFeats = debugShowFeats f + treeParams = unlines $ graphvizParams showFeats $ ciSourceTree c + -- FIXME: will have to make this configurable, maybe, show aut, show tree? radio button? + in "\n// ------------------- derivations --------------------------\n" + ++ treeParams ++ "node [ shape = plaintext, peripheries = 0 ]\n" + ++ gvDerv + ++ "\n// ------------------- automata (joined) ------------------------\n" + ++ gvSubgraph gvAut + ++ if showSrcTree + then ("\n// ------------------- elementary tree --------------------------\n" + ++ treeParams ++ graphvizShowAsSubgraph f p c) + else "" + +instance GraphvizShowNode (CkyStatus,Bool,[ChartId]) (ChartId, String) where + graphvizShowNode (st,showFullDerv,highlight) prefix (theId,_) = + let idStr = show theId + treename i = " (" ++ ((idname.ciSourceTree) i) ++ ")" + txt = case findId st theId of + Nothing -> ("???" ++ idStr) + Just i -> idStr ++ " " ++ (show.ciNode) i + ++ (if showFullDerv then treename i else "") + custom = if theId `elem` highlight then [ ("fontcolor","red") ] else [] + in gvNode prefix txt custom + +instance GraphvizShow CkyDebugParams CkyItem where + graphvizLabel f ci = + graphvizLabel (debugShowFeats f, nullHlter) (toTagElem ci) ++ + gvNewline ++ (gvUnlines $ ciDiagnostic ci) + + graphvizShowAsSubgraph f prefix ci = + let showFeats = debugShowFeats f + hlter n = (n, if (gnname n) == (gnname $ ciNode ci) + then Just "red" else Nothing) + in graphvizShowAsSubgraph (showFeats,hlter) (prefix ++ "tree") $ toTagElem ci + +nullHlter :: GNode -> (GNode, Maybe String) +nullHlter a = (a,Nothing) + +toTagElem :: CkyItem -> TagElem +toTagElem ci = + te { ttree = ttree te + , tsemantics = bitVectorToSem (ciSemBitMap ci) (ciSemantics ci) } + where te = ciSourceTree ci + +-- FIXME: this is largely copy-and-pasted from Polarity.lhs +-- it should be refactored later +instance GraphvizShow () B.SentenceAut where + graphvizShowAsSubgraph _ prefix aut = + let st = (concat.states) aut + ids = map (\x -> prefix ++ show x) ([0..]::[Int]) + -- map which permits us to assign an id to a state + stmap = Map.fromList $ zip st ids + lookupFinal x = Map.findWithDefault "error_final" x stmap + in -- final states should be a double-edged ellispse + "node [ shape = ellipse, peripheries = 2 ]; " + ++ (unlines $ map lookupFinal $ finalStList aut) + -- any other state should be an ellipse + ++ "node [ shape = ellipse, peripheries = 1 ]\n" + -- draw the states and transitions + ++ (concat $ zipWith gvShowState ids st) + ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) + +type SentenceAutState = Int + +gvShowState :: String -> SentenceAutState -> String +gvShowState stId st = gvNode stId (show st) [] + +gvShowTrans :: B.SentenceAut -> Map.Map SentenceAutState String + -> String -> SentenceAutState -> String +gvShowTrans aut stmap idFrom st = + let -- outgoing transition labels from st + trans = Map.findWithDefault Map.empty st $ transitions aut + -- returns the graphviz dot command to draw a labeled transition + drawTrans (stTo,x) = case Map.lookup stTo stmap of + Nothing -> drawTrans' ("id_error_" ++ (show stTo)) x + Just idTo -> drawTrans' idTo x + drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] + drawLabel labels = gvUnlines $ map fst $ catMaybes labels + in unlines $ map drawTrans $ Map.toList trans +\end{code} + +\begin{code} +-- | join two automata, inserting a ".." transition between them +mJoinAutomataUsingHole :: Maybe B.SentenceAut -> Maybe B.SentenceAut -> Maybe B.SentenceAut +mJoinAutomataUsingHole aut1 Nothing = aut1 +mJoinAutomataUsingHole aut1 aut2 = + mJoinAutomata aut1 $ mJoinAutomata (Just holeAut) aut2 + where holeAut = addTrans emptyA 0 (Just ("..",[])) 1 + emptyA = emptySentenceAut { startSt = 0, finalStList = [1], states = [[0,1]] } +\end{code} diff --git a/NLP/GenI/Console.hs b/NLP/GenI/Console.hs new file mode 100644 --- /dev/null +++ b/NLP/GenI/Console.hs @@ -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) diff --git a/NLP/GenI/Graphviz.hs b/NLP/GenI/Graphviz.hs new file mode 100644 --- /dev/null +++ b/NLP/GenI/Graphviz.hs @@ -0,0 +1,212 @@ +{-# OPTIONS -fglasgow-exts #-} + +{- + GenI surface realiser + Copyright (C) 2005 Carlos Areces and Eric Kow + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-} + +{- | Graphviz is an open source tool which converts an abstract + representation of a graph (node foo is connected to node bar, etc.) + into a nicely laid out graphic. This module contains methods + to invoke graphviz and to convert graphs and trees to its input format. + + You can download this (open source) tool at + +-} + +module NLP.GenI.Graphviz +where + +import Control.Monad(when) +import Data.List(intersperse) +import Data.Tree +import System.IO(hPutStrLn, hClose) +import System.Exit(ExitCode) + +import NLP.GenI.SysGeni(waitForProcess, runInteractiveProcess) + +{- | + Data structures which can be visualised with GraphViz should + implement this class. Note the first argument to graphvizShowGraph is + so that you can parameterise your show function (i.e. pass in + flags to change the way you show particular object). Note + that by default, all graphs are treated as directed graphs. You + can hide this by turning off edge arrows. +-} +class GraphvizShow flag b where + graphvizShowGraph :: flag -> b -> String + graphvizShowAsSubgraph :: flag -- ^ flag + -> String -- ^ prefix + -> b -- ^ item + -> String -- ^ gv output + graphvizLabel :: flag -- ^ flag + -> b -- ^ item + -> String -- ^ gv output + graphvizParams :: flag -> b -> [String] + + graphvizShowGraph f b = + let l = graphvizLabel f b + in "digraph {\n" + ++ (unlines $ graphvizParams f b) + ++ graphvizShowAsSubgraph f "_" b ++ "\n" + ++ (if null l then "" else " label = \"" ++ l ++ "\";\n") + ++ "}" + graphvizLabel _ _ = "" + graphvizParams _ _ = [] + +class GraphvizShowNode flag b where + graphvizShowNode :: flag -- ^ flag + -> String -- ^ prefix + -> b -- ^ item + -> String -- ^ gv output + +-- | Things which are meant to be displayed within some other graph +-- as (part) of a node label +class GraphvizShowString flag b where + graphvizShow :: flag -- ^ flag + -> b -- ^ item + -> String -- ^ gv output + +-- | Note: the 'dotFile' argument allows you to save the intermediary +-- dot output to a file. You can pass in the empty string if you don't +toGraphviz :: (GraphvizShow f a) => f + -> a + -> String -- ^ the 'dotFile' + -> String -> IO ExitCode +toGraphviz p x dotFile outputFile = do + graphviz (graphvizShowGraph p x) dotFile outputFile + +-- --------------------------------------------------------------------- +-- useful utility functions +-- --------------------------------------------------------------------- + +gvNewline :: String +gvNewline = "\\n" + +gvUnlines :: [String] -> String +gvUnlines = concat . (intersperse gvNewline) + +gvSubgraph :: String -> String +gvSubgraph g = "subgraph {\n" ++ g ++ "}\n" + +-- | The Graphviz string for a node. Note that we make absolutely no +-- effort to escape any characters for you; so if you need to protect +-- anything from graphviz, you're on your own +gvNode :: String -- ^ the node name + -> String -- ^ the label (may be empty) + -> [(String,String)] -- ^ any other parameters + -> String +gvNode name label params = + " " ++ name ++ " " ++ (gvLabelAndParams label params) ++ "\n" + +-- | The Graphviz string for a connection between two nodes. +-- Same disclaimer as 'gvNode' applies. +gvEdge :: String -- ^ the 'from' node + -> String -- ^ the 'to' node + -> String -- ^ the label (may be empty) + -> [(String,String)] -- ^ any other parameters + -> String +gvEdge from to label params = + " " ++ from ++ " -> " ++ to ++ (gvLabelAndParams label params) ++ "\n" + +gvLabelAndParams :: String -> [(String,String)] -> String +gvLabelAndParams l p = + gvParams $ if null l then p else ("label", l) : p + +gvParams :: [(String,String)] -> String +gvParams [] = "" +gvParams p = "[ " ++ (concat $ intersperse ", " $ map showPair p) ++ " ]" + where showPair (a,v) = a ++ "=\"" ++ v ++ "\"" + +-- --------------------------------------------------------------------- +-- some instances +-- --------------------------------------------------------------------- + +instance (GraphvizShow f b) => GraphvizShow f (Maybe b) where + graphvizShowAsSubgraph _ _ Nothing = "" + graphvizShowAsSubgraph f p (Just b) = graphvizShowAsSubgraph f p b + + graphvizLabel _ Nothing = "" + graphvizLabel f (Just b) = graphvizLabel f b + + graphvizParams _ Nothing = [] + graphvizParams f (Just b) = graphvizParams f b + +-- | Displays a tree in graphviz format. +{- Note that we could make this an + instance of GraphvizShow, but I'm not too sure about the wisdom of + such a move. + + Maybe if we had some really super-sophisticated types in Haskell, where + we can define this as the default instance which could be overrided by + something more specific, that would be cool. + + The prefix argument is interpreted as the name of the top node. Node + names below are basically Gorn addresses (e.g. n0x2x3 means 3rd child of + the 2nd child of the root) to keep them distinct. Note : We use the + letter `x' as seperator because graphviz will choke on `.' or `-', even + underscore. -} +gvShowTree :: (GraphvizShowNode f n) => + (n->[(String,String)]) -- ^ function to convert a node to a list of graphviz parameters for the edge + -> f -- ^ GraphvizShow flag + -> String -- ^ node prefix + -> (Tree n) -- ^ the tree + -> String +gvShowTree edgeFn f prefix t = + "edge [ arrowhead = none ]\n" ++ gvShowTreeHelper edgeFn f prefix t + +gvShowTreeHelper :: forall n . forall f . (GraphvizShowNode f n) => (n->[(String,String)]) -> f -> String -> (Tree n) -> String +gvShowTreeHelper edgeFn f prefix (Node node l) = + let showNode = graphvizShowNode f prefix + showKid :: Integer -> Tree n -> String + showKid index kid = + gvShowTreeHelper edgeFn f kidname kid ++ " " + ++ (gvEdge prefix kidname "" (edgeFn node)) + where kidname = prefix ++ "x" ++ (show index) + in showNode node ++ "\n" ++ (concat $ zipWith showKid [0..] l) + +-- --------------------------------------------------------------------- +-- invocation +-- --------------------------------------------------------------------- + +-- | Calls graphviz. If the second argument is the empty string, then we +-- just send stuff directly to dot's stdin + +graphviz :: String -- ^ graphviz's dot format. + -> String -- ^ the name of the file graphviz should write the dot + -> String -- ^ the name of the file graphviz should write its output + -> IO ExitCode + +-- We write the dot String to a temporary file which we then feed to graphviz. +-- This is avoid complications with fork and pipes. We use png output even +-- though it's uglier, because we don't have a wxhaskell widget that can +-- display postscript... do we? + +graphviz dot dotFile outputFile = do + let dotArgs' = ["-Gfontname=courier", + "-Nfontname=courier", + "-Efontname=courier", + "-Gcharset=latin1", -- FIXME: should really output UTF-8 instead + "-Tpng", "-o" ++ outputFile ] + dotArgs = dotArgs' ++ (if (null dotFile) then [] else [dotFile]) + -- putStrLn ("sending to graphviz:\n" ++ dot) + when (not $ null dotFile) $ writeFile dotFile dot + (_, toGV, _, pid) <- runInteractiveProcess "dot" dotArgs Nothing Nothing + when (null dotFile) $ do + hPutStrLn toGV dot + hClose toGV + waitForProcess pid diff --git a/NLP/GenI/GraphvizShow.lhs b/NLP/GenI/GraphvizShow.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/GraphvizShow.lhs @@ -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} diff --git a/NLP/GenI/GraphvizShowPolarity.lhs b/NLP/GenI/GraphvizShowPolarity.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/GraphvizShowPolarity.lhs @@ -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 + diff --git a/NLP/GenI/Gui.lhs b/NLP/GenI/Gui.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/Gui.lhs @@ -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} diff --git a/NLP/GenI/GuiHelper.lhs b/NLP/GenI/GuiHelper.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/GuiHelper.lhs @@ -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} + + diff --git a/NLP/GenI/Simple/SimpleGui.lhs b/NLP/GenI/Simple/SimpleGui.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/Simple/SimpleGui.lhs @@ -0,0 +1,200 @@ +% GenI surface realiser +% Copyright (C) 2005 Carlos Areces and Eric Kow +% +% This program is free software; you can redistribute it and/or +% modify it under the terms of the GNU General Public License +% as published by the Free Software Foundation; either version 2 +% of the License, or (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +\chapter{Simple GUI} + +\begin{code} +module NLP.GenI.Simple.SimpleGui where +\end{code} + +\ignore{ +\begin{code} +import Graphics.UI.WX +import Graphics.UI.WXCore + +import Data.IORef +import qualified Data.Map as Map + +import NLP.GenI.Statistics (Statistics) + +import NLP.GenI.Btypes (GNode(gnname, gup), emptyGNode, GeniVal(GConst)) +import NLP.GenI.Configuration ( Params(..) ) +import NLP.GenI.General ( snd3 ) +import NLP.GenI.Geni ( ProgStateRef, runGeni, GeniResult ) +import NLP.GenI.Graphviz ( GraphvizShow(..), gvNewline, gvUnlines ) +import NLP.GenI.GuiHelper + ( messageGui, tagViewerGui, + debuggerPanel, DebuggerItemBar, setGvParams, GvIO, newGvRef, + viewTagWidgets, XMGDerivation(getSourceTrees), + ) +import NLP.GenI.Tags (tsemantics, TagElem(idname, ttree), TagItem(..), emptyTE) +import NLP.GenI.GraphvizShow ( graphvizShowDerivation ) + +import qualified NLP.GenI.Builder as B +import qualified NLP.GenI.BuilderGui as BG +import NLP.GenI.Polarity +import NLP.GenI.Simple.SimpleBuilder + ( simpleBuilder, SimpleStatus, SimpleItem(..), SimpleGuiItem(..) + , unpackResult + , theResults, theAgenda, theAuxAgenda, theChart, theTrash) +\end{code} +} + +% -------------------------------------------------------------------- +\section{Interface} +% -------------------------------------------------------------------- + +\begin{code} +simpleGui_2p, simpleGui_1p :: BG.BuilderGui +simpleGui_2p = simpleGui True +simpleGui_1p = simpleGui False + +simpleGui :: Bool -> BG.BuilderGui +simpleGui twophase = BG.BuilderGui { + BG.resultsPnl = resultsPnl twophase + , BG.debuggerPnl = simpleDebuggerTab twophase } + +resultsPnl :: Bool -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout) +resultsPnl twophase pstRef f = + do (sentences, stats, st) <- runGeni pstRef (simpleBuilder twophase) + (lay, _, _) <- realisationsGui pstRef f (theResults st) + return (sentences, stats, lay) +\end{code} + +% -------------------------------------------------------------------- +\section{Results} +\label{sec:results_gui} +% -------------------------------------------------------------------- + +\subsection{Derived Trees} + +Browser for derived/derivation trees, except if there are no results, we show a +message box + +\begin{code} +realisationsGui :: ProgStateRef -> (Window a) -> [SimpleItem] + -> GvIO Bool (Maybe SimpleItem) +realisationsGui _ f [] = + do m <- messageGui f "No results found" + g <- newGvRef False [] "" + return (m, g, return ()) +realisationsGui pstRef f resultsRaw = + do let tip = "result" + itNlabl = map (\t -> (Just t, siToSentence t)) resultsRaw + -- + pst <- readIORef pstRef + -- FIXME: have to show the semantics again + tagViewerGui pst f tip "derived" itNlabl +\end{code} + +% -------------------------------------------------------------------- +\section{Debugger} +\label{sec:simple_debugger_gui} +\label{fn:simpleDebugGui} +% -------------------------------------------------------------------- + +\begin{code} +simpleDebuggerTab :: Bool -> (Window a) -> Params -> B.Input -> String -> IO Layout +simpleDebuggerTab twophase x1 (pa@x2) = + debuggerPanel (simpleBuilder twophase) False stToGraphviz (simpleItemBar pa) + x1 x2 + +stToGraphviz :: SimpleStatus -> ([Maybe SimpleItem], [String]) +stToGraphviz st = + let agenda = section "AGENDA" $ theAgenda st + auxAgenda = section "AUXILIARY" $ theAuxAgenda st + trash = section "TRASH" $ theTrash st + chart = section "CHART" $ theChart st + results = section "RESULTS" $ theResults st + -- + section n i = hd : (map tlFn i) + where hd = (Nothing, "___" ++ n ++ "___") + tlFn x = (Just x, siToSentence x ++ (showPaths $ siPolpaths x)) + showPaths t = " (" ++ showPolPaths t ++ ")" + in unzip $ agenda ++ auxAgenda ++ chart ++ trash ++ results + +simpleItemBar :: Params -> DebuggerItemBar Bool SimpleItem +simpleItemBar pa f gvRef updaterFn = + do ib <- panel f [] + detailsChk <- checkBox ib [ text := "Show features" + , checked := False ] + viewTagLay <- viewTagWidgets ib gvRef pa + -- handlers + let onDetailsChk = + do isDetailed <- get detailsChk checked + setGvParams gvRef isDetailed + updaterFn + set detailsChk [ on command := onDetailsChk ] + -- + return . hfloatCentre . (container ib) . row 5 $ + [ hspace 5 + , widget detailsChk + , hglue + , viewTagLay + , hspace 5 ] +\end{code} + +% -------------------------------------------------------------------- +\section{Miscellaneous} +% ------------------------------------------------------------------- + +\begin{code} +instance TagItem SimpleItem where + tgIdName = siIdname.siGuiStuff + tgIdNum = siId + tgSemantics = siFullSem.siGuiStuff + +instance XMGDerivation SimpleItem where + -- Note: this is XMG-related stuff + getSourceTrees it = tgIdName it : (map snd3 . siDerivation $ it) +\end{code} + +\begin{code} +instance GraphvizShow Bool SimpleItem where + graphvizLabel f c = + graphvizLabel f (toTagElem c) ++ gvNewline ++ (gvUnlines $ siDiagnostic $ siGuiStuff c) + + graphvizParams f c = graphvizParams f (toTagElem c) + graphvizShowAsSubgraph f p it = + let isHiglight n = gnname n `elem` (siHighlight.siGuiStuff) it + info n | isHiglight n = (n, Just "red") + | otherwise = (n, Nothing) + in "\n// ------------------- elementary tree --------------------------\n" + ++ graphvizShowAsSubgraph (f, info) (p ++ "TagElem") (toTagElem it) + ++ "\n// ------------------- derivation tree --------------------------\n" + -- derivation tree is displayed without any decoration + ++ (graphvizShowDerivation . siDerivation $ it) + +toTagElem :: SimpleItem -> TagElem +toTagElem si = + emptyTE { idname = tgIdName si + , tsemantics = tgSemantics si + , ttree = fmap lookupOrBug (siDerived si) } + where + nodes = siNodes.siGuiStuff $ si + nodeMap = Map.fromList $ zip (map gnname nodes) nodes + lookupOrBug k = case Map.lookup k nodeMap of + Nothing -> emptyGNode { gup = [ ("cat",GConst ["error looking up " ++ k]) ] } + Just x -> x +\end{code} + +\begin{code} +siToSentence :: SimpleItem -> String +siToSentence si = case unpackResult si of + [] -> siIdname.siGuiStuff $ si + (h:_) -> unwords . map fst . fst $ h +\end{code} diff --git a/NLP/GenI/SysGeni.lhs b/NLP/GenI/SysGeni.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/SysGeni.lhs @@ -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} + diff --git a/NLP/GenI/unused/Predictors.lhs b/NLP/GenI/unused/Predictors.lhs new file mode 100644 --- /dev/null +++ b/NLP/GenI/unused/Predictors.lhs @@ -0,0 +1,315 @@ +% GenI surface realiser +% Copyright (C) 2005 Carlos Areces and Eric Kow +% +% This program is free software; you can redistribute it and/or +% modify it under the terms of the GNU General Public License +% as published by the Free Software Foundation; either version 2 +% of the License, or (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +\chapter{Predictor Optimisation} + +One optimisation is to annotate the macros with a set of +\jargon{predictors}. This allows macros to predict that they will +combine with certain (usually) null-semantic trees. For example, a +common noun would predict that it needs a determiner. + +\begin{code} +module Predictors +where +\end{code} + +\begin{code} +import Debug.Trace +import qualified Data.Map as Map +import Data.List (nub, sortBy, groupBy, intersect) +import Monad (when, ap, foldM) +import MonadState (get, put) + +import Bfuncs (Sem, Flist, AvPair, showSem, showAv, isVar) +import Tags (TagElem(TE), emptyTE, idname, tsemantics, substnodes, + derivation, tpredictors, drawTagTrees) +import Configuration (defaultParams) +import Mstate (MS, Gstats, initGstats, addGstats, initMState, + runState, genstats, + incrNumcompar, incrSzchart, incrGeniter, + renameTagElem, + addToInitRep, + getGenRep, lookupGenRep, genRepToList, addListToGenRep, + iapplySubstNode, + nullInitRep, getInitRep, genrep, getSem, selectGiven) + +import Polarity (showLite) +\end{code} + +% ---------------------------------------------------------------------- +\section{Optimisation} +% ---------------------------------------------------------------------- + +We attempt substitution between macro and any predictors that it has. +Whenever we succeed, we can pass the combined tree as a candidate. +Whenever we fail, we have to pass both the macro and its predictors. +This is basically an indirect means of adding some kind of indexing to +the generator's chart. + +Note: there are actually two cases here. For those predictors that +we can substitute into the macro, we return the resulting tree and +discard the predictor. + +\begin{code} +optimisePredictors :: [[TagElem]] -> PredictorMap -> ([[TagElem]], Gstats) +optimisePredictors cands predictmap = + let trees = nub $ concat cands + -- calculate predicted trees + sumup = foldr addGstats initGstats + optTree t = optimisePredictors' predictmap t + optPath p = (r, sumup s) + where (r,s) = unzip $ map optTree p + (res, stats) = optPath trees + treemap = Map.fromList $ zip trees res + -- replace trees with their predicted equivalents + repTree t = lookupWithDefaultFM treemap [t] t + repPath p = concatMap repTree p + {- repPath p = trace ("\n==============\npath\n=============\n" ++ drawTagTrees l) l + where l = repPath' p -} + in (map repPath cands, stats) +\end{code} + +\paragraph{optimisePredictors'} is a helper function that tries to +fulfill as many of a tree's predictors as possible. Any predictors +it cannot use are also returned so that they can be passed to the +generator proper. + +\begin{code} +optimisePredictors' :: PredictorMap -> TagElem -> ([TagElem], Gstats) +optimisePredictors' predictmap te = + let -- grab the predictors (helper fns) + isneg _ e = e < 0 + predictors t = Map.keys $ filterFM isneg $ tpredictors t + ptrees t = concatMap fn (predictors t) + where fn = lookupWithDefaultFM predictmap [] + -- generate + tePtrees = ptrees te + initSt = initMState tePtrees [te] (tsemantics te) defaultParams + (res', st) = runState miniGenerate initSt + -- pick the trees with the largest derivation history + derSz = length.snd.derivation + cmpDerSz t1 t2 = compare (derSz t2) (derSz t1) -- note the inversion + sameDerSz t1 t2 = (derSz t2) == (derSz t1) + groupedres = groupBy sameDerSz $ sortBy cmpDerSz res' + -- return the results + result = head groupedres -- trace ("\n==============\nresults for " ++ idname te ++ "\n=============\n" ++ drawTagTrees res) $ + rejects = concatMap ptrees result + stats = genstats st + -- + debugstr = "\n===================" + ++ "\noptimising " ++ showLite te + ++ "\nptrees: " ++ showLite (tePtrees) + ++ "\n==================== " + errormsg = "Geni: Predictors.optimisePredictors' is broken" + in case () of _ | null tePtrees -> ([te], stats) + | null groupedres -> error errormsg + | otherwise -> (result ++ rejects, stats) +\end{code} + +% ---------------------------------------------------------------------- +\subsection{miniGenerate} +% ---------------------------------------------------------------------- + +miniGenerate is a lightweight version of the generator which operates +on the following principles: + +\begin{enumerate} +\item There is one primary tree (chart) and some secondary trees + (agenda), which should not be confused with auxiliary trees +\item All operations are performed between the primary + tree and the secondary trees, that is, you won't + have any interaction between secondary trees +\item The primary tree may substitute with or be + substituted any number of secondary trees +\item Secondary trees may only be used once +\end{enumerate} + +It is used as a helper function for optimisePredictors. + +\begin{code} +miniGenerate :: MS [TagElem] +miniGenerate = do + nir <- nullInitRep + gr <- getGenRep + if nir then return (concat $ elems gr) else do + incrGeniter 1 + tsem <- getSem + -- choose a secondary tree from the agenda + given <- selectGiven + -- perform any substitutions + chart <- lookupGenRep given + let (res', cost') = unzip $ map (timidSubstitution given) chart + res = concat res' + cost = foldr (+) 0 cost' + incrSzchart (length res) + incrNumcompar cost + -- add any succesful results to the chart + st <- get + put st { genrep = addListToGenRep gr res } + miniGenerate +\end{code} + +\paragraph{timidSubstitution} attempts to perform substitution between +input trees $te_1$ and $te_2$. This is meant strictly to be a helper +function for optimisePredictors, so we'll have a somewhat conservative +and quirky behaviour: +\begin{itemize} +\item If there are no ways to perform substitution, we return the empty +list +\item If there is exactly one way to perform substitution +(either $te_1$ into $te_2$ or vice versa), we +return that substitution. +\item If there is more than one way to do it, we return the empty list. +This is because the situation is ambiguous and could lead to unpredictable +results (see section \ref{sec:optimisePredictors_tricky}) +\end{itemize} + +This is somewhat similar to MState's applySubstitution, except that we +rule out the case of multiple results, and that we do not require the +substitution nodes to be in any particular order. + +\begin{code} +timidSubstitution :: TagElem -> TagElem -> ([TagElem],Int) +timidSubstitution te1 te2 = + let tesem = tsemantics te1 + -- we only substitute tags with no overlaping semantics + notOverlap = null $ intersect (tsemantics te2) tesem + -- we rename tags to do a proper substitution + rte1 = renameTagElem 'A' te1 + rte2 = renameTagElem 'B' te2 + -- perform the substitution + subst t1 t2 = concatMap (iapplySubstNode t1 t2) $ substnodes t2 + res' = (subst rte1 rte2) ++ (subst rte2 rte1) + res = if (length res' == 1) then res' else [] + -- measuring efficiency + cost = fn te1 + fn te2 + where fn t = length $ substnodes t + in if notOverlap then (res, cost) else ([], 0) +\end{code} + +\subsection{Trickiness in optimisePredictors} +\label{sec:optimisePredictors_tricky} + +Rejecting ambiguous substitutions is crucial to the idea that +secondary trees may only be used once. + +Consider the trees for \textit{the N, enemy of N, friend}. +The idea is that we eventually want to generate \textit {the enemy of the +friend}, so the result of optimisePredictors should ideally be something like: +\textit{the friend, the enemy of N} + +But this isn't so easy to achieve. In fact, if we tried to achieve +the above result, we would instead get a highly undesirable result +like this \textit{the friend, the enemy of the N} + +Do you see why the above result is bad? It is because now there is +no way to substitute friend into that noun-substitution node. To +avoid this sort of over-ambitiousness, we avoid ambiguous cases where a +tree could both substitute into or be substituted into another. So we +get a less optimal, but much safer result \textit{the friend, enemy of, +the}: + +% ---------------------------------------------------------------------- +\section{Cleanup} +% ---------------------------------------------------------------------- + +\paragraph{fillPredictors} This is neccesary when either the +predictor optimisation is disabled or if there are some +predictor substitutions which do not succeed. It takes a list of paths +and inserts all required predictors on the paths. + +\begin{code} +fillPredictors :: [[TagElem]] -> PredictorMap -> [[TagElem]] +fillPredictors paths predictmap = + let isneg _ pol = pol < 0 + getP = lookupWithDefaultFM predictmap [] + predictors te = Map.keys $ filterFM isneg $ tpredictors te + addP te = te : (concatMap getP $ predictors te) + in map (\p -> nub $ concatMap addP p) paths +\end{code} + +% -------------------------------------------------------------------- +\section{Instatiation of predictors} +% -------------------------------------------------------------------- + +We combine the predictors from the lexicon and macros. The idea is +to do this in a way which lets the grammar writer be lazy while having +as simple and predictable a behaviour as possible. Any predictors that +the lexicon has must correspond to some variable predictor in the +macros, so if I say in the lexicon that a tree as predictor +$+vsup:avoir$ there had better be a $+vsup:X$ in the macros to back it +up. + +\begin{code} +combinePredictors tt le = + let -- fn to add an item to the predictors map + addP (fv,c) fm = addToFM_C (+) fm fv c + -- lexicon predictors + lpr = sort $ ipredictors le + -- tree predictors (variable vs constant predictors) + tpr = sort $ ptpredictors tt + isVpr ((f,v),_) = (not $ null v) && isVar v + (varPr,constPr) = partition isVpr tpr + constPrFm = foldr addP Map.empty constPr + -- separating the charges from the fv + (lfv, lc) = unzip lpr + (vfv, vc) = unzip varPr + -- the unification + unify [] [] = [] + unify ((tf,tv):tnext) ((lf,lv):lnext) + | tf /= lf = error errmsg + | isVar lv = error errvlex + | isVar tv = (lf,lv):(unify (substFlist' tnext (tv,lv)) lnext) + | lv == tv = (lf,lv):(unify tnext lnext) + | otherwise = error errmsg + unification = unify vfv lfv + -- error messages in case things don't line up + errmsg = "Word '" ++ (iword le) ++ "' does not correctly " + ++ " instantiate the variable predictors in tree " + ++ (itreename le) + ++ "\n Tree predictors: " ++ (show $ map fst varPr) + ++ "\n Word predictors: " ++ (show $ map fst lpr) + ++ "\n Hint: only the variable predictors should be instantiated" + errvlex = "Word '" ++ (iword le) ++ "' contains variable " + ++ " predictors in " ++ (show $ map fst lpr) + in if (lc == vc) -- note: this implies list equality + then foldr addP constPrFm $ zip unification lc + else error errmsg +\end{code} + + +% ---------------------------------------------------------------------- +\section{PredictorMap} +% ---------------------------------------------------------------------- + +We create a map between predictors and the trees that provide them. + +\begin{code} +type PredictorMap = Map AvPair [TagElem] +\end{code} + +\begin{code} +mapByPredictors :: [TagElem] -> PredictorMap +mapByPredictors trees = foldr mapByPredictors' Map.empty trees + +mapByPredictors' :: TagElem -> PredictorMap -> PredictorMap +mapByPredictors' tree fm = + let ispos _ pol = (pol > 0) + predictors = Map.keys $ filterFM ispos $ tpredictors tree + addp p f = addToFM_C (++) f p [tree] + in foldr addp fm predictors +\end{code} diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 + + diff --git a/macstuff/macosx-app b/macstuff/macosx-app new file mode 100644 --- /dev/null +++ b/macstuff/macosx-app @@ -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] " + 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 ""