diff --git a/GenI.cabal b/GenI.cabal --- a/GenI.cabal +++ b/GenI.cabal @@ -1,5 +1,5 @@ Name: GenI -Version: 0.20.2 +Version: 0.22 License: GPL License-file: LICENSE Author: Carlos Areces and Eric Kow @@ -8,28 +8,28 @@ Description: A natural language generator (specifically, an FB-LTAG surface realiser) Homepage: http://projects.haskell.org/GenI Maintainer: geni-users@loria.fr -Build-Type: Custom -Cabal-Version: >=1.2.3 +Build-Type: Simple +Cabal-Version: >=1.8 data-files: AUTHORS, INSTALL, README, NEWS, GenI.cabal, examples/artificial/lexicon, - examples/artificial/macros, + examples/artificial/trees, examples/artificial/suite, examples/artificial/suite-bad, examples/chatnoir/lexicon, - examples/chatnoir/macros, + examples/chatnoir/trees, examples/chatnoir/suite, examples/demo/lexicon, - examples/demo/macros, + examples/demo/trees, examples/demo/README, examples/demo/suite, examples/ej/lexicon, - examples/ej/macros, + examples/ej/trees, examples/ej/suite, examples/nosemantics/lexicon, - examples/nosemantics/macros, + examples/nosemantics/trees, examples/nosemantics/README.txt, examples/promettre/lexicon, - examples/promettre/macros, + examples/promettre/trees, examples/promettre/morphinfo, examples/promettre/suite, examples/xmg-example/grammar/Arguments.mg, @@ -44,93 +44,123 @@ examples/xmg-example/lexicon/demo-morph-utf8.mph, examples/xmg-example/Makefile, examples/xmg-example/README, - examples/xmg-example/suite, - etc/stupidmorph.pl, - etc/macstuff/Info.plist, - etc/macstuff/wxmac.icns - -extra-source-files: src/NLP/GenI/SysGeni.hs - src/NLP/GenI/Test.hs - src/NLP/GenI/Simple/SimpleGui.lhs, - src/NLP/GenI/Gui.lhs - src/NLP/GenI/GraphvizShow.hs, - src/NLP/GenI/GuiHelper.hs - src/NLP/GenI/Console.hs, - src/NLP/GenI/Graphviz.hs - src/NLP/GenI/BuilderGui.lhs, - src/NLP/GenI/GraphvizShowPolarity.lhs, - src/NLP/GenI/Regression.hs + examples/xmg-example/suite +extra-source-files: geni-test/NLP/GenI/Test.hs -Flag gui - description: Build with a graphical user interface - default: False +source-repository head + type: darcs + location: http://code.haskell.org/GenI Flag static Description: Build a static binary Default: False Library - Build-depends: parsec >= 2 && < 3, - base >= 3 && < 4, - containers >= 0.1, - process > 1, - QuickCheck >= 1.2 && < 2, - json >= 0.4.3 && < 0.5, - HUnit > 1 && < 1.3, - mtl > 1.0 && < 1.2, - parallel >= 1.1 && < 1.2, - binary >= 0.5.0.2 && < 0.6, - split >= 0.1.1 && < 0.2, - test-framework-hunit >= 0.2.4 && < 0.3, - test-framework-quickcheck >= 0.2.4 && < 0.3, - test-framework >= 0.2.4 && < 0.3, - utf8-string >= 0.3.5 && < 0.4, - uniplate >= 1.2.0 && < 1.3 - - if !flag(gui) - cpp-options: -DDISABLE_GUI + Build-depends: base >= 4 && < 5 + , binary >= 0.5.0.2 + , bytestring == 0.9.* + , cabal-macosx >= 0.1.2 && < 0.3 + , containers >= 0.1 + , deepseq + , directory > 1 + , filepath == 1.* + , hslogger == 1.1.* + , json >= 0.4.3 && < 0.6 + , MaybeT == 0.1.* + , mtl > 1.0 && < 2.1 + , old-locale + , ordered == 0.1.* + , parsec >= 2 && < 3.2 + , process > 1 + , split >= 0.1.1 && < 0.2 + , syb + , text + , time >= 1.1 && < 1.3 + , utf8-string >= 0.3.5 && < 0.4 + , yaml-light == 0.1.* if flag(static) ghc-options: -static -optl-static Exposed-Modules: - NLP.GenI.Btypes, - NLP.GenI.BtypesBinary, + BoolExp, + Data.FullList.Internal, + Data.FullList, + NLP.GenI.Console, + NLP.GenI.FeatureStructure, + NLP.GenI.Flag, NLP.GenI.General, - NLP.GenI.GeniParsers, NLP.GenI.GeniShow, NLP.GenI.GeniVal, - NLP.GenI.Tags, + NLP.GenI.GeniVal.Internal, + NLP.GenI.Lexicon, + NLP.GenI.Lexicon.Internal, + NLP.GenI.LexicalSelection, + NLP.GenI.LexicalSelection.Types, + NLP.GenI.Main, + NLP.GenI.Parser, + NLP.GenI.Pretty, + NLP.GenI.Semantics, + NLP.GenI.Tag, + NLP.GenI.TestSuite, + NLP.GenI.TreeSchema, + NLP.GenI.Warning, + NLP.GenI.Warning.Internal, NLP.GenI.Morphology, + NLP.GenI.Morphology.Types, NLP.GenI.OptimalityTheory, NLP.GenI.Polarity, - NLP.GenI.PolarityTypes, + NLP.GenI.Polarity.Internal, + NLP.GenI.Polarity.Types, NLP.GenI.Automaton, NLP.GenI.Statistics, NLP.GenI.Builder, NLP.GenI.Simple.SimpleBuilder, - -- NLP.GenI.CkyEarley.CkyBuilder, - NLP.GenI.Geni, NLP.GenI.Configuration + NLP.GenI.Configuration, + NLP.GenI + Other-Modules: + Paths_GenI Hs-Source-Dirs: src - Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ExistentialQuantification, LiberalTypeSynonyms - Ghc-options: -Wall -O2 + Ghc-options: -Wall Ghc-prof-options: -auto-all Executable geni - Main-Is: MainGeni.lhs - Hs-Source-Dirs: src - Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ExistentialQuantification, LiberalTypeSynonyms + Main-Is: geni.hs + Hs-Source-Dirs: geni - Ghc-options: -Wall -O2 + Ghc-options: -Wall -rtsopts Ghc-prof-options: -auto-all - Build-Depends: directory > 1, - filepath >= 1.1.0 && < 1.2 - if flag(gui) - Build-Depends: wx >= 0.10.3 && < 0.13 - else - cpp-options: -DDISABLE_GUI + Build-Depends: base >= 4 && < 5 + , GenI + , containers >= 0.1 + , directory > 1 + , filepath == 1.* + , yaml-light == 0.1.* + , hslogger == 1.1.* + , json >= 0.4 && < 0.6 + , mtl > 1.0 && < 2.1 + , process > 1 + , split == 0.1.* + , utf8-string == 0.3.* - if flag(static) - ghc-options: -static -optl-static +Test-Suite geni-test + Type: exitcode-stdio-1.0 + Main-Is: MainTest.hs + Hs-Source-Dirs: geni-test + Build-Depends: GenI + , base >= 4 && < 5 + , containers >= 0.1 + , filepath == 1.* + , json + , mtl + , parsec >= 2 && < 3.2 + , QuickCheck == 2.4.* + , smallcheck + , HUnit > 1 && < 1.3 + , test-framework-hunit >= 0.2.4 && < 0.3 + , test-framework-quickcheck2 >= 0.2.4 && < 0.3 + , test-framework-smallcheck + , test-framework > 0.3 + , text diff --git a/INSTALL b/INSTALL --- a/INSTALL +++ b/INSTALL @@ -1,13 +1,12 @@ Requirements ------------ - * GHC 6.8 or 6.10 - * libgmp (for ghc) + * Haskell Platform 2011.3.0.0 GUI requirements ---------------- Only needed if you want the graphical interface: * wxWidgets 2.8 - * wxHaskell 0.11 + * wxHaskell * Graphviz Building GenI @@ -15,7 +14,7 @@ 1. obtain cabal-install 2. run: cabal install 3. if you want the graphical interface, try - cabal install -fgui + cabal install ./geni-gui but ONLY AFTER you succeed in installing the text version :-) -For more details, see http://trac.haskell.org/GenI +For more details, see http://projects.haskell.org/GenI diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,111 @@ +GenI 0.22, 14 Apr 2012 +---------------------- +Note that the changes between this release and 0.20 are considered to be under +the BSD3 license. GenI overall remains dual-licensed under the GPL and any +commercial-use terms you may wish to negotiate with INRIA. Having secured the +rights to use GenI 0.20, you may freely use GenI 0.22 in a similar fashion. + +CHANGES TO WATCH OUT FOR + +* Separation of geni and geni-gui into two packages; + simpler installation +* Now using the top feature for lemanchors instead of bot +* Empty disjunctions forbidden in unification variables +* JSON input/output to morph processors have changed +* Lexical selection unifies semantics of tree schema + lemma with + input semantics. + +GUI + +* New results tab with reminder of inputs +* Add gui element to display unanchored lexical selection. +* Jump to new tab in debugger panel when created. +* Update gui to use Pretty instead of Show +* Rename $algo-session tab to "tree assembly" +* Make warnings resizable. +* Fix display of path equations with 'interface' in them. +* Fix #50 - load button has no effect. +* Fix #49 - correct order that leaf nodes are returned. +* Show GenI version in About box. +* Add detect polarities and root feature editor to main gui. + +DOCUMENTATION + +* Literate GenI and genimanual replaced with + http://projects.haskell.org/GenI/manual + +GENERAL + +* Builds with GHC 7 +* Core behaviour + * Early null-adjunction and semfilter obligatory + * Handling of zero-literal semantic items restored + * Unconstrained polarities in automaton construction. + This makes it possible to do polarity detection with only a + weakly specified root feature like [cat:_], and without needing + the relevant feature to be implemented everywhere. + +* Flags: + * --trees (used to be --macros; latter is deprecated) + * --batchdir now optional (defaults to a new temp dir) + * --maxsteps (stop after N steps) + * --extrapol REMOVED (use root feature instead) +* Logging facility (not used much in GenI yet) + Can be configured in ~/.geni/config.yaml, for example + logging: + - + name : NLP.GenI.Console + level : WARN + format : simple "$msg" + - + name : NLP.Geni.LexicalSelection + level : DEBUG + format : simple "$utcTime $loggername $msg" + handler : stderr +* Less repetition in warnings (hopefully easier to read) +* More hiding of constructors for safety +* New enrichment option for setting co-anchors (foo.lex=hello) +* Lexical selection performance enhancements +* Variables that only occur once are converted to anonymous, + should make unification a bit more efficient +* Fix #39: reject malformed root feature input. +* New feature: + * Variables with constraints on their possible values (?X/foo|bar) + * Fancy disjunctions: tree schemata now allow disjunctions of + unification variables (but not recursive). These must flatten down + to plain old atomic disjunction once converted to elementary trees + +* Time metric in statistics (Laura Perez) +* Do top/bottom unification on na-constrained nodes during initialisation. +* Polarity detection relaxed to work with constrained variables too. + (?X/foo|bar gives the result as foo|bar) +* Bugfix in interpretation of root feature (it should be sorted). +* Flags: + * --rootfeat always assumed, but defaults to '[cat:_]' + * '-r' a short command line option for '--rootfeat'. + +LIBRARY + +* Somewhat safer and easier to understand API + (still no stability yet) +* Replace String with Text in GeniVal +* Replace Show abuse with custom Pretty class +* Slightly less stateful (no target semantics in state) +* Much rearranging and renaming (sorry!) +* New: ability to provide custom lexical selection action +* New: ability to provide custom morph postprocessing action +* de-haskell98 (Gwern Branwen) +* No more null builder. + +TOOLS (darcs get --lazy http://code.haskell.org/GenI) + +* new tool, genireport: summarise batch generation results +* geniserver now talks over HTTP using a JSON format +* Use Sylvain Salvati's xmg2geni.xsl instead of geniconvert. + * xmg2geni: fix treatment of missing lexemes. + * xmg2geni: treat type=coanchor as other nodes in GenI. +* geniwrapper: illustrates C wrapper of GenI API + GenI 0.20, 29 Sep 2009 ---------------------- - NON BACKWARD-COMPATIBLE CHANGES diff --git a/README b/README --- a/README +++ b/README @@ -1,24 +1,27 @@ -documentation +Documentation ------------- -make doc # (pdflatex and haddock are needed) - 1. users manual: - http://wiki.loria.fr/wiki/GenI -2. semi-literate source code: - doc/genidoc.pdf -3. API: - doc/api/index.html + http://projects.haskell.org/GenI/manual +2. API: + http://projects.haskell.org/GenI/api-doc -installing GenI +Installing GenI --------------- -(tested on Linux and MacOs X) +(tested on Linux, Windows, and MacOS X) -see INSTALL for details +see INSTALL for details (should just be cabal install) -assuming everything above is installed correctly, -it should possible to just make +Development +----------- +The code style has evolved a lot. Sorry for the inconsistency. +As of 2012-05-06, I'm trying to move to a published style guide +so I can stop thinking about it -contact us! + https://github.com/tibbe/haskell-style-guide + +But the code will take a long time to catch up + +Contact us! ----------- Please let us know if you are using GenI; we'd like to hear about your experiences, both positive and negative. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,117 +1,2 @@ -{-# LANGUAGE CPP #-} - -import Control.Monad (foldM_, forM_) -import Data.Maybe ( fromMaybe ) -import System.Cmd -import System.Exit -import System.Info (os) -import System.FilePath -import System.Directory ( doesFileExist, copyFile, removeFile, createDirectoryIfMissing ) - -import Distribution.PackageDescription -import Distribution.Simple.Setup import Distribution.Simple -import Distribution.Simple.LocalBuildInfo - -#ifndef WIN32 -import System.Posix.Files (fileMode, getFileStatus, setFileMode, - ownerExecuteMode, groupExecuteMode, otherExecuteMode) -import Data.Bits ( (.|.) ) -#endif - -main :: IO () -main = defaultMainWithHooks $ addMacHook simpleUserHooks - where - addMacHook h = - case os of - "darwin" -> h { postInst = appBundleHook } -- is it OK to treat darwin as synonymous with MacOS X? - _ -> h - -appBundleHook :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () -appBundleHook _ _ pkg localb = - forM_ exes $ \app -> - do createAppBundle theBindir (buildDir localb app app) - customiseAppBundle (appBundlePath theBindir app) app - `catch` \err -> putStrLn $ "Warning: could not customise bundle for " ++ app ++ ": " ++ show err - removeFile (theBindir app) - createAppBundleWrapper theBindir app - where - theBindir = bindir $ absoluteInstallDirs pkg localb NoCopyDest - exes = fromMaybe (map exeName $ executables pkg) mRestrictTo - --- ---------------------------------------------------------------------- --- helper code for application bundles --- ---------------------------------------------------------------------- - --- | 'createAppBundle' @d p@ - creates an application bundle in @d@ --- for program @p@, assuming that @d@ already exists and is a directory. --- Note that only the filename part of @p@ is used. -createAppBundle :: FilePath -> FilePath -> IO () -createAppBundle dir p = - do createDirectoryIfMissing False $ bundle - createDirectoryIfMissing True $ bundleBin - createDirectoryIfMissing True $ bundleRsrc - copyFile p (bundleBin takeFileName p) - where - bundle = appBundlePath dir p - bundleBin = bundle "Contents/MacOS" - bundleRsrc = bundle "Contents/Resources" - --- | 'createAppBundleWrapper' @d p@ - creates a script in @d@ that calls --- @p@ from the application bundle @d takeFileName p <.> "app"@ -createAppBundleWrapper :: FilePath -> FilePath -> IO () -createAppBundleWrapper bindir p = - do writeFile scriptFile scriptTxt - makeExecutable scriptFile - where - scriptFile = bindir takeFileName p - scriptTxt = "`dirname $0`" appBundlePath "." p "Contents/MacOS" takeFileName p ++ " \"$@\"" - -appBundlePath :: FilePath -> FilePath -> FilePath -appBundlePath dir p = dir takeFileName p <.> "app" - --- ---------------------------------------------------------------------- --- utilities --- ---------------------------------------------------------------------- - -makeExecutable :: FilePath -> IO () -#ifdef WIN32 -makeExecutable = const (return ()) -#else -makeExecutable f = - do st <- getFileStatus f - let m = fileMode st - m2 = m .|. ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode - setFileMode f m2 -#endif - --- ---------------------------------------------------------------------- --- customisations --- ---------------------------------------------------------------------- - --- | Put here IO actions needed to add any fancy things (eg icons) --- you want to your application bundle. -customiseAppBundle :: FilePath -- ^ app bundle path - -> FilePath -- ^ full path to original binary - -> IO () -customiseAppBundle bundleDir p = - case takeFileName p of - "geni" -> - do hasRez <- doesFileExist "/Developer/Tools/Rez" - if hasRez - then do -- set the icon - copyFile "etc/macstuff/Info.plist" (bundleDir "Contents/Info.plist") - copyFile "etc/macstuff/wxmac.icns" (bundleDir "Contents/Resources/wxmac.icns") - -- no idea what this does - system ("/Developer/Tools/Rez -t APPL Carbon.r -o " ++ bundleDir "Contents/MacOS/geni") - writeFile (bundleDir "PkgInfo") "APPL????" - -- tell Finder about the icon - system ("/Developer/Tools/SetFile -a C " ++ bundleDir "Contents") - return () - else putStrLn "Developer Tools not found. Too bad; no fancy icons for you." - "" -> return () - --- | 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"] +main = defaultMain diff --git a/etc/macstuff/Info.plist b/etc/macstuff/Info.plist deleted file mode 100644 --- a/etc/macstuff/Info.plist +++ /dev/null @@ -1,36 +0,0 @@ - - - - - CFBundleDevelopmentRegion - English - CFBundleExecutable - geni - CFBundleGetInfoString - GenI - CFBundleIconFile - wxmac.icns - CFBundleIdentifier - fr.loria.geni - CFBundleInfoDictionaryVersion - 6.0 - CFBundleLongVersionString - (c) 2005-2009 LORIA - CFBundleName - GenI - CFBundlePackageType - APPL - CFBundleShortVersionString - 0 - CFBundleSignature - ???? - CFBundleVersion - 0 - CSResourcesFileMapped - - LSRequiresCarbon - - NSHumanReadableCopyright - Copyright 2005-2009 LORIA - - diff --git a/etc/macstuff/wxmac.icns b/etc/macstuff/wxmac.icns deleted file mode 100644 Binary files a/etc/macstuff/wxmac.icns and /dev/null differ diff --git a/etc/stupidmorph.pl b/etc/stupidmorph.pl deleted file mode 100644 --- a/etc/stupidmorph.pl +++ /dev/null @@ -1,85 +0,0 @@ -: -eval 'exec perl -w -S $0 ${1+"$@"}' - if 0; - -use strict; -use JSON; - -# -------------------------------------------------------------------- -# idiotic morphological generator -# -# this outputs for each lemma the name of the lemma and its category -# -------------------------------------------------------------------- - -# -------------------------------------------------------------------- -# from GenI -# -------------------------------------------------------------------- - -# we return a list of lists of hashes -# - each item in the outer list corresponds to a sentence -# - each item in the inner list corresponds to a word -# - each hash represents the features read from GenI plus a special "__lemma__" feature -# which holds the lemma -sub read_morph_request { - my $json_str = shift; - my $allR = from_json $json_str; - my @r_sentences = (); # one request per sentence - - foreach my $sentenceR (@$allR) { - my @r_words = (); - foreach my $wordR (@$sentenceR) { - my $lemma = $wordR->{lemma}; - my $featstr = $wordR->{"lemma-features"}; - $featstr =~ s/^\[//; - $featstr =~ s/\]$//; - - my %feat = (); - my $av = ""; - for (split(/ /, $featstr)) { - $av = $_; - my ($attr, $val) = split(/:/,$av); - $feat{$attr} = $val; - } - $feat{"__lemma__"} = $lemma; - push @r_words, \%feat; - } - push @r_sentences, \@r_words; - } - return \@r_sentences -} - -# -------------------------------------------------------------------- -# morph -# -------------------------------------------------------------------- - -sub morph { - my $lemma = shift; - my $featsR = shift; - my $cat = $featsR->{"cat"}; - return "$lemma:$cat"; -} - -# -------------------------------------------------------------------- -# main -# -------------------------------------------------------------------- - -# slurp STDIN to $buf (copied from web) -my $holdTerminator = $/; -undef $/; -my $buf = ; -$/ = $holdTerminator; - -my @output = (); -my $reqsR = read_morph_request $buf; -foreach my $sentenceR (@$reqsR) { - my @output_words = (); - foreach my $wordR (@$sentenceR) { - my $inflected = morph($wordR->{"__lemma__"}, $wordR); - push @output_words, $inflected; - } - my $output_sentence = join(" ",@output_words); - my @singleton = ( $output_sentence ); - push @output, \@singleton; -} - -print to_json(\@output); diff --git a/examples/artificial/lexicon b/examples/artificial/lexicon --- a/examples/artificial/lexicon +++ b/examples/artificial/lexicon @@ -46,7 +46,10 @@ tb-unification-noadj tb-unification-noadj () semantics:[tb-unification-noadj()] tb-unification-bot tb-unification-bot () semantics:[tb-unification-bot()] tb-unification-adj tb-unification-adj () semantics:[tb-unification-adj()] +tb-unification-na tb-unification-na(?X) semantics:[tb-unification-na(?X)] +tb-unification-anchor tb-unification-anchor(?X) semantics:[tb-unification-anchor(?X)] + no-thing no-thing () semantics:[no-thing()] thing-good thing-good () semantics:[thing-good()] thing-bad thing-bad () semantics:[thing-bad()] @@ -54,3 +57,8 @@ "string-literal-in-lemma" term () semantics:["string-lit'+!|"(foo)] lemanchor lemanchor() semantics:[lemanchor()] + +preterminal preterminal() semantics:[preterminal()] + +disjunction disjunction(x y z) semantics:[disjunction()] +variablecat variablecat(x y z) semantics:[variablecat()] diff --git a/examples/artificial/macros b/examples/artificial/macros deleted file mode 100644 --- a/examples/artificial/macros +++ /dev/null @@ -1,126 +0,0 @@ -% trivial example of the kid to parent rule -k2p-trivial() initial -Mother [cat:a]![] { Anchor anchor [ cat:x ]![] } - -% note: the alphabetical names below are meaningless - they are just -% chinese numbers (which is why i follow them by the equivalent -% arabic numerals) -% -% why do i name them this way? dunno... figured they'd be easier -% to see or something - - -yi1() initial -YiMo [cat:a tb:?T]![tb:?B] { - YiLe anchor [ cat:x ]![] - YiRi type:subst [ cat:b ]![] -} - -er2() initial -Mother [cat:b]![] { - Left anchor [ cat:x ]![] - Right type:subst [ cat:t1 ]![] -} - -term(?C ?X) initial -T anchor [cat:?C foo:?X]![] - -aux-bad() auxiliary -Mother [cat:t1 tb:foo]![] { - Left anchor [ cat:x ]![] - Foot type:foot [cat:t1]![tb:bar] -} - -aux-good() auxiliary -MothA [cat:t1 tb:ping]![] { - LeftA anchor [cat:x]![] - FootA type:foot [cat:t1]![tb:ping] -} - -aux-nepas () auxiliary -Mother [cat:t1 tb:ping]![] { - Left anchor [cat:x]![] - Foot type:foot [cat:t1]![tb:ping] - Right type:lex "pas" -} - - - -% meant to receive substitution from san3 -% if it works - ?A should be set to bar -wu5 () initial -WuM [cat:a foo:?A]![] { - WuL anchor [cat:x]![] - WuR type:subst [cat:t1 foo:?A]![] -} - -% a simple tb unification which ought to work -liu6-good () initial -Mother [cat:a]![cat:a] { Anchor anchor [cat:x]![] } - -% unification + subst should work, but this should NOT propagate up! -% this should NOT propagate up -wu5-bad () initial -Mother [cat:a foo:?A]![] { - Anch anchor [cat:x]![] - Left type:subst [cat:t1 foo:?A]![] - Right type:subst [cat:t2 foo:?A]![] -} - - - -% top-bot unification failure (simple) -liu6-bad1 () initial -Mother [cat:a]![cat:b] { Anch anchor [cat:x]![] } - -% top-bot unification (complex) -liu6-bad2 () initial -Mother [cat:a tb:?X]![tb:?Y] { - Anch anchor [cat:x]![] - Left type:subst [cat:t1 foo:?X]![] - Right type:subst [cat:t2 foo:?Y]![] -} - -% this should still be passed -iaf-killer-good (?X) initial -Mother [cat:a]![cat:a] { - Anch anchor [cat:x]![] - Left type:subst [cat:t1 idx:?X]![] - Right type:subst [cat:t2 idx:?X]![] -} - -aconstr-with-anchor () initial -Anch anchor aconstr:noadj [cat:a]![] - -% this succeeds iff thing is good or left unset -tb-unification-noadj () initial -M [cat:a]![] { - X type:subst [cat:x thing:?X]![thing:good] - Y anchor [cat:b]![] -} - -tb-unification-bot() initial -M anchor [cat:a]![] - -tb-unification-adj() auxiliary -M [cat:a]![idx:b] { - X anchor [cat:b]![] - Y type:foot [cat:a]![] -} - -no-thing () initial -X anchor [cat:x]![] - -thing-good () initial -X anchor [cat:x thing:good]![] - -thing-bad () initial -X anchor [cat:x thing:bad]![] - -lemanchor () initial -M [cat:x]![] { - X anchor [cat:x]![] - Y type:subst [cat:y]![lemanchor:hello] - Z type:subst [cat:y]![lemanchor:world] -} - diff --git a/examples/artificial/suite b/examples/artificial/suite --- a/examples/artificial/suite +++ b/examples/artificial/suite @@ -25,5 +25,10 @@ tb-noadj-good-2 semantics:[tb-unification-noadj() thing-good()] tb-unification-1 semantics:[tb-unification-bot()] tb-unification-2 semantics:[tb-unification-bot() tb-unification-adj()] +tb-unification-na-good semantics:[tb-unification-na(good)] +tb-unification-anchor-good semantics:[tb-unification-anchor(good)] lemanchor semantics:[lemanchor()] +preterminal semantics:[preterminal()] +disjunction semantics:[disjunction()] +variablecat semantics:[variablecat()] diff --git a/examples/artificial/suite-bad b/examples/artificial/suite-bad --- a/examples/artificial/suite-bad +++ b/examples/artificial/suite-bad @@ -9,3 +9,5 @@ % aconstr:noadj nodes tb-noadj-bad semantics:[tb-unification-noadj() thing-bad()] +tb-unification-na-bad semantics:[tb-unification-na(bad)] +tb-unification-anchor-bad semantics:[tb-unification-anchor(bad)] diff --git a/examples/artificial/trees b/examples/artificial/trees new file mode 100644 --- /dev/null +++ b/examples/artificial/trees @@ -0,0 +1,150 @@ +% trivial example of the kid to parent rule +k2p-trivial() initial +Mother [cat:a]![] { Anchor anchor [ cat:x ]![] } + +% note: the alphabetical names below are meaningless - they are just +% chinese numbers (which is why i follow them by the equivalent +% arabic numerals) +% +% why do i name them this way? dunno... figured they'd be easier +% to see or something + + +yi1() initial +YiMo [cat:a tb:?T]![tb:?B] { + YiLe anchor [ cat:x ]![] + YiRi type:subst [ cat:b ]![] +} + +er2() initial +Mother [cat:b]![] { + Left anchor [ cat:x ]![] + Right type:subst [ cat:t1 ]![] +} + +term(?C ?X) initial +T anchor [cat:?C foo:?X]![] + +aux-bad() auxiliary +Mother [cat:t1 tb:foo]![] { + Left anchor [ cat:x ]![] + Foot type:foot [cat:t1]![tb:bar] +} + +aux-good() auxiliary +MothA [cat:t1 tb:ping]![] { + LeftA anchor [cat:x]![] + FootA type:foot [cat:t1]![tb:ping] +} + +aux-nepas () auxiliary +Mother [cat:t1 tb:ping]![] { + Left anchor [cat:x]![] + Foot type:foot [cat:t1]![tb:ping] + Right type:lex "pas" +} + + + +% meant to receive substitution from san3 +% if it works - ?A should be set to bar +wu5 () initial +WuM [cat:a foo:?A]![] { + WuL anchor [cat:x]![] + WuR type:subst [cat:t1 foo:?A]![] +} + +% a simple tb unification which ought to work +liu6-good () initial +Mother [cat:a]![cat:a] { Anchor anchor [cat:x]![] } + +% unification + subst should work, but this should NOT propagate up! +% this should NOT propagate up +wu5-bad () initial +Mother [cat:a foo:?A]![] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 foo:?A]![] + Right type:subst [cat:t2 foo:?A]![] +} + + + +% top-bot unification failure (simple) +liu6-bad1 () initial +Mother [cat:a]![cat:b] { Anch anchor [cat:x]![] } + +% top-bot unification (complex) +liu6-bad2 () initial +Mother [cat:a tb:?X]![tb:?Y] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 foo:?X]![] + Right type:subst [cat:t2 foo:?Y]![] +} + +% this should still be passed +iaf-killer-good (?X) initial +Mother [cat:a]![cat:a] { + Anch anchor [cat:x]![] + Left type:subst [cat:t1 idx:?X]![] + Right type:subst [cat:t2 idx:?X]![] +} + +aconstr-with-anchor () initial +Anch anchor aconstr:noadj [cat:a]![] + +% this succeeds iff thing is good or left unset +tb-unification-noadj () initial +M [cat:a]![] { + X type:subst [cat:x thing:?X]![thing:good] + Y anchor [cat:b]![] +} + +tb-unification-bot() initial +M anchor [cat:a]![] + +tb-unification-adj() auxiliary +M [cat:a]![idx:b] { + X anchor [cat:b]![] + Y type:foot [cat:a]![] +} + +tb-unification-na(?T) initial +X aconstr:noadj [cat:X thing:good]![thing:?T] { + Y anchor [cat:X]![] +} + +tb-unification-anchor(?T) initial +X [cat:X thing:good]![thing:?T] { + Y anchor [cat:X thing:good]![thing:?T] +} + + +no-thing () initial +X anchor [cat:x]![] + +thing-good () initial +X anchor [cat:x thing:good]![] + +thing-bad () initial +X anchor [cat:x thing:bad]![] + +lemanchor () initial +M [cat:x]![] { + X anchor [cat:x]![] + Y type:subst [cat:y lemanchor:hello]![] + Z type:subst [cat:y lemanchor:world]![] +} + +preterminal () initial +M [cat:x]![] { + X anchor [cat:x]![] + Y [cat:y]![lemanchor:hello] +} + + +disjunction(?X ?Y ?Z) initial +X anchor [cat:?X;?Y;?Z x:?X y:?Y z:?Z foo:?X/x|y|z;?Z;a]![] + +variablecat(?X ?Y ?Z) initial +X anchor [cat:_ x:?X y:?Y z:?Z foo:?X/x|y|z;?Z;a]![] + diff --git a/examples/chatnoir/macros b/examples/chatnoir/macros deleted file mode 100644 --- a/examples/chatnoir/macros +++ /dev/null @@ -1,132 +0,0 @@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% DETERMINERS -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -Det(?I) auxiliary -n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] -{ - n2 anchor [cat:det]![] - n4 type:foot [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:?_] -} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% NOUNS -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -% Common Nouns: voyage -nC(?I) initial -n1 anchor [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] - -% Proper Nouns: Jean -nP(?I) initial -n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% ADJECTIVES -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -adj_post(?I) auxiliary -n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] -{ - n1 type:foot [cat:n idx:?I det:minus qu:minus]! - [cat:n idx:?I det:minus qu:?_ ] - n2 anchor [cat:a]![] -} - -adj_pre(?I) auxiliary -n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] -{ - n1 anchor [cat:a]![] - n3 type:foot [cat:n idx:?I det:minus qu:minus]! - [cat:n idx:?I det:minus qu:?_ ] -} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% TRANSITIVE VERBS -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -%infinitive - % chasser une souris vinfn1 -vArity2:vinfn1(?E ?X ?Y) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:?_ sujidx:?_] -{ - n2 anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:?_ qu:?_ ] -} - -% declarative - % le chat chasse la souris -vArity2:n0vn1(?E ?X ?Y) initial -n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]! - [cat:n idx:?X det:?_ qu:?_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y - det:?_ qu:?_ ] -} - -% question sujet - % qui chasse une souris ? -vArity2:qu0vn1(?E ?X ?Y) initial -n1[cat:p]![] -{ - n2 type:subst [cat:c idx:?X det:plus qu:minus]! - [cat:c idx:?X det:?_ qu:?_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]! - [cat:n idx:?Y det:?_ qu:?_ ] -} - -% question objet - % que chasse le chat ? -vArity2:qu1vn0(?E ?X ?Y) initial -n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?Y det:plus qu:plus]! - [cat:n idx:?Y det:?_ qu:plus ] - n3[cat:p idx:?E]![] - { - % FIXME: EYK - the bottom node was cat:p, i set it to cat:v - % to validate - n4 anchor [cat:v idx:?E]![cat:v idx:?E] - n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X - det:?_ qu:?_ ] - } -} - -% relative sujet -% le chat qui chasse la souris - -vArity2:rel0vn1(?E ?X ?Y) auxiliary -n0[cat:n idx:?X det:plus qu:?_]![cat:n idx:?X det:?_ qu:?_ ] -{ - n1 type:foot [cat:n idx:?X det:?_ qu:?_]![cat:n idx:?X det:?_ qu:?_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]! - [cat:c idx:?X det:?_ qu:?_ ] - n4 anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Y det:plus qu:minus]! - [cat:n idx:?Y det:?_ qu:?_ ] - }} - -% relative objet -% la souris que chasse le chat - -vArity2:rel1vn0(?E ?X ?Y) auxiliary -n0[cat:n idx:?Y det:plus qu:?_]![cat:n idx:?Y det:?_ qu:?_ ] -{ - n1 type:foot [cat:n idx:?Y det:?_ qu:?_]! - [cat:n idx:?Y det:?_ qu:?_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]! - [cat:c idx:?X det:?_ qu:?_ ] - n4 anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?X det:plus qu:minus]! - [cat:n idx:?X det:?_ qu:?_ ] - } -} - -% vi: set cinoptions=0,p0: diff --git a/examples/chatnoir/trees b/examples/chatnoir/trees new file mode 100644 --- /dev/null +++ b/examples/chatnoir/trees @@ -0,0 +1,132 @@ +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% DETERMINERS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +Det(?I) auxiliary +n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] +{ + n2 anchor [cat:det]![] + n4 type:foot [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:?_] +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% NOUNS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% Common Nouns: voyage +nC(?I) initial +n1 anchor [cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] + +% Proper Nouns: Jean +nP(?I) initial +n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% ADJECTIVES +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +adj_post(?I) auxiliary +n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] +{ + n1 type:foot [cat:n idx:?I det:minus qu:minus]! + [cat:n idx:?I det:minus qu:?_ ] + n2 anchor [cat:a]![] +} + +adj_pre(?I) auxiliary +n0[cat:n idx:?I det:?_ qu:?_]![cat:n idx:?I det:minus qu:minus ] +{ + n1 anchor [cat:a]![] + n3 type:foot [cat:n idx:?I det:minus qu:minus]! + [cat:n idx:?I det:minus qu:?_ ] +} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% TRANSITIVE VERBS +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%infinitive + % chasser une souris vinfn1 +vArity2:vinfn1(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:?_ sujidx:?_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:?_ qu:?_ ] +} + +% declarative + % le chat chasse la souris +vArity2:n0vn1(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]! + [cat:n idx:?X det:?_ qu:?_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:?_ qu:?_ ] +} + +% question sujet + % qui chasse une souris ? +vArity2:qu0vn1(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]! + [cat:n idx:?Y det:?_ qu:?_ ] +} + +% question objet + % que chasse le chat ? +vArity2:qu1vn0(?E ?X ?Y) initial +n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Y det:plus qu:plus]! + [cat:n idx:?Y det:?_ qu:plus ] + n3[cat:p idx:?E]![] + { + % FIXME: EYK - the bottom node was cat:p, i set it to cat:v + % to validate + n4 anchor [cat:v idx:?E]![cat:v idx:?E] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X + det:?_ qu:?_ ] + } +} + +% relative sujet +% le chat qui chasse la souris + +vArity2:rel0vn1(?E ?X ?Y) auxiliary +n0[cat:n idx:?X det:plus qu:?_]![cat:n idx:?X det:?_ qu:?_ ] +{ + n1 type:foot [cat:n idx:?X det:?_ qu:?_]![cat:n idx:?X det:?_ qu:?_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]! + [cat:n idx:?Y det:?_ qu:?_ ] + }} + +% relative objet +% la souris que chasse le chat + +vArity2:rel1vn0(?E ?X ?Y) auxiliary +n0[cat:n idx:?Y det:plus qu:?_]![cat:n idx:?Y det:?_ qu:?_ ] +{ + n1 type:foot [cat:n idx:?Y det:?_ qu:?_]! + [cat:n idx:?Y det:?_ qu:?_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]! + [cat:c idx:?X det:?_ qu:?_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?X det:plus qu:minus]! + [cat:n idx:?X det:?_ qu:?_ ] + } +} + +% vi: set cinoptions=0,p0: diff --git a/examples/demo/macros b/examples/demo/macros deleted file mode 100644 --- a/examples/demo/macros +++ /dev/null @@ -1,439 +0,0 @@ -%% 02 april 2004 -%% 1. Jean promet un cadeau a Marie -%% 2. Jean promet a Marie de partir -%% 3. Qui promet un cadeau a Marie? -%% 4. Que promet Jean a Marie? -%% 5. A qui Jean promet-il un cadeau? -%% 6. la personne qui promet un cadeau a Marie -%% 7. le cadeau que Jean promet a Marie -%% 8. la personne a qui Jean promet un cadeau -%% 9. promettre un cadeau a Marie -%% 10. promettant un cadeau a Marie -%% 11. donner un livre a marie - -Det(?I) auxiliary -n1[cat:n idx:?I det:_ qu:minus]![cat:n idx:?I det:_ qu:minus] -{ - n2 anchor [cat:det]![] - n4 type:foot [cat:n idx:?I det:_ qu:_ ]![cat:n idx:?I det:minus qu:_ ] -} - - % Common Nouns: voyage -nC(?I) initial - n1 anchor [cat:n idx:?I det:_ qu:?W ]![cat:n idx:?I det:minus qu:minus ] -% Proper Nouns: Jean - -nP(?I) initial - n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] - - %1 declarative gn promet gn sp_a -n0vn1sp2(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - n6[cat:sp idx:?Z det:plus]![det:_ ] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z - det:_ qu:_] - } -} - - %2 infinitive V GN SP_a -vinfn1sp2(?E ?X ?Y ?Z) initial - n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:_ sujidx:_] -{ - n2 anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - n5[cat:sp idx:?Z det:plus]![det:_ ] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z - det:_ qu:_] - } -} - - %3 question sujet qui V GN GP_a ? -qu0vn1sp2(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:c idx:?X det:plus qu:minus]![idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - n6[cat:sp idx:?Z det:plus]![det:_ ] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] - } -} - - %4 question objet -qu1vn0sp2(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y det:_ qu:plus ] - n3[cat:p idx:?E]![] - { - n4 anchor [cat:v idx:?E]![idx:?E] - n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X - det:_ qu:_ ] - n7[cat:sp idx:?Z det:plus]![det:_ ] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_] - } - } -} - - %5 question objet indirect -qu2n0vn1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2[cat:sp idx:?Z det:plus]![det:_ ] - { n3[cat:prep]![] - { - n4 type:lex "a" - } - n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] - } - n6[cat:p idx:?E]![] - { - n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n8 anchor [cat:v idx:?E]![idx:?E] - n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - } -} - -%6 relative sujet qui V gn sp_a -rel0vn1sp2(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n4 anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - n7[cat:sp idx:?Z ]![] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ - det:_ qu:_] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] - }}} - -%7 relative objet -rel1vn0sp2(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n4 anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n7[cat:sp idx:?Z ]![] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ - det:_ qu:_] - } - } -} - -%8 relative objet indirect -rel2n0vn1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] - n2[cat:p]![] - { - n3[cat:sp idx:?Z det:plus]![det:_ ] - { n4[cat:prep]![] - { - n5 type:lex "a" - } - n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] - } - n7[cat:p idx:?E]![] - { - n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n9 anchor [cat:v idx:?E]![cat:p idx:?E] - n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] - } - } -} - - %9 declarative GN V GN_a Pinf_de -n0vsp2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5[cat:sp idx:?Y det:plus]![det:_ ] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] - } -} - - %10 infinitive V SP_a Inf_de -vinfsp2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p idx:?E mode:inf sujidx:?X]![idx:?Y mode:_ sujidx:_] -{ - n2 anchor [cat:v idx:?E]![] - n4[cat:sp idx:?Z det:plus]![det:_ ] - { n5[cat:prep]![] - { - n6 type:lex "a" - } - n7 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z - det:_ qu:_] - } - n8[cat:p]![] - {n9[cat:prep]![] - { - n10 type:lex "de" - } - n11 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] - } -} - - %11 question sujet qui V GP_a Pinf_de ? -qu0vsp2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5[cat:sp idx:?Z det:plus]![det:_ ] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] - }} - - %12 question objet indirect -qu2n0vpinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2[cat:sp idx:?Z det:plus]![det:_ ] - { n3[cat:prep]![] - { - n4 type:lex "a" - } - n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] - } - n6[cat:p idx:?E]![] - { - n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n8 anchor [cat:v idx:?E]![cat:p idx:?E] - } - n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] -} - -%13 relative sujet qui V sp_a pinf_de -rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n4 anchor [cat:v idx:?E]![] - n6[cat:sp idx:?Z ]![] - { n7[cat:prep]![] - { - n8 type:lex "a" - } - n9 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ - det:_ qu:_] - } - n10[cat:p]![] - {n11[cat:prep]![] - { - n12 type:lex "de" - } - n13 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] - }}} - -%14 relative objet indirect a qui GN v Pinf_de -rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] - n2[cat:p]![] - { - n3[cat:sp idx:?Z det:plus]![det:_ ] - { n4[cat:prep]![] - { - n5 type:lex "a" - } - n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] - } - n7[cat:p idx:?E]![] - { - n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n9 anchor [cat:v idx:?E]![cat:p idx:?E] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y - mode:_ sujidx:_] - } - }} - - - %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 -n0vn2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] - n6[cat:p]![] - {n7[cat:prep]![] - { - n8 type:lex "de" - } - n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] - } -} - - %15 infinitive persuader gn pinf_de vinfn2pinf1 -vinfn2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?Y mode:_ sujidx:_] -{ - n2 anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y - det:_ qu:_] - n5[cat:p]![] - {n6[cat:prep]![] - { - n7 type:lex "de" - } - n8 type:subst [cat:p idx:?Z mode:inf sujidx:?Y]![cat:p idx:?Z - mode:_ sujidx:_] - } -} - - %16 qu-sujet qui persuade gn pinf_de ? qu0vn2pinf1 -qu0vn2pinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n3 anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] - n6[cat:p]![] - {n7[cat:prep]![] - { - n8 type:lex "de" - } - n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z - mode:_ sujidx:_] - }} - - %17 qu-obj qui gn persuade-il pinf_de ? qu2n0vpinf1 -qu2n0vpinf1(?E ?X ?Y ?Z) initial - n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] - n3[cat:p idx:?E]![] - { - n4 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n5 anchor [cat:v idx:?E]![cat:p idx:?E] - } - n7[cat:prep]![] - { - n8 type:lex "de" - } - n9 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y - mode:_ sujidx:_] -} - -%18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 -rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] - n4 anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ - det:_ qu:_] - n7[cat:p]![] - {n8[cat:prep]![] - { - n9 type:lex "de" - } - n10 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y - mode:_ sujidx:_] - }}} - -%19 rel-obj n dont gn persuade gn rel1n0vn2 -rel1n0vn2(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] -{ - n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_] - n2[cat:p]![] - { - n3 type:subst [cat:c idx:?Y det:plus qu:_]![cat:c idx:?Y det:_ qu:_] - n4[cat:p idx:?E]![] - { - n5 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] - n6 anchor [cat:v idx:?E]![cat:p idx:?E] - } - n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y - det:_ qu:minus ] - } -} - diff --git a/examples/demo/trees b/examples/demo/trees new file mode 100644 --- /dev/null +++ b/examples/demo/trees @@ -0,0 +1,439 @@ +%% 02 april 2004 +%% 1. Jean promet un cadeau a Marie +%% 2. Jean promet a Marie de partir +%% 3. Qui promet un cadeau a Marie? +%% 4. Que promet Jean a Marie? +%% 5. A qui Jean promet-il un cadeau? +%% 6. la personne qui promet un cadeau a Marie +%% 7. le cadeau que Jean promet a Marie +%% 8. la personne a qui Jean promet un cadeau +%% 9. promettre un cadeau a Marie +%% 10. promettant un cadeau a Marie +%% 11. donner un livre a marie + +Det(?I) auxiliary +n1[cat:n idx:?I det:_ qu:minus]![cat:n idx:?I det:_ qu:minus] +{ + n2 anchor [cat:det]![] + n4 type:foot [cat:n idx:?I det:_ qu:_ ]![cat:n idx:?I det:minus qu:_ ] +} + + % Common Nouns: voyage +nC(?I) initial + n1 anchor [cat:n idx:?I det:_ qu:?W ]![cat:n idx:?I det:minus qu:minus ] +% Proper Nouns: Jean + +nP(?I) initial + n1 anchor [cat:n idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus ] + + %1 declarative gn promet gn sp_a +n0vn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n6[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } +} + + %2 infinitive V GN SP_a +vinfn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?E mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n5[cat:sp idx:?Z det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } +} + + %3 question sujet qui V GN GP_a ? +qu0vn1sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n6[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + } +} + + %4 question objet +qu1vn0sp2(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y det:_ qu:plus ] + n3[cat:p idx:?E]![] + { + n4 anchor [cat:v idx:?E]![idx:?E] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X + det:_ qu:_ ] + n7[cat:sp idx:?Z det:plus]![det:_ ] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_] + } + } +} + + %5 question objet indirect +qu2n0vn1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2[cat:sp idx:?Z det:plus]![det:_ ] + { n3[cat:prep]![] + { + n4 type:lex "a" + } + n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n6[cat:p idx:?E]![] + { + n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n8 anchor [cat:v idx:?E]![idx:?E] + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + } +} + +%6 relative sujet qui V gn sp_a +rel0vn1sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + n7[cat:sp idx:?Z ]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }}} + +%7 relative objet +rel1vn0sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n7[cat:sp idx:?Z ]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + } +} + +%8 relative objet indirect +rel2n0vn1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![det:_ ] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n9 anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_ ] + } + } +} + + %9 declarative GN V GN_a Pinf_de +n0vsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Y det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] + } +} + + %10 infinitive V SP_a Inf_de +vinfsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![idx:?Y mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4[cat:sp idx:?Z det:plus]![det:_ ] + { n5[cat:prep]![] + { + n6 type:lex "a" + } + n7 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + det:_ qu:_] + } + n8[cat:p]![] + {n9[cat:prep]![] + { + n10 type:lex "de" + } + n11 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + } +} + + %11 question sujet qui V GP_a Pinf_de ? +qu0vsp2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Z det:plus]![det:_ ] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }} + + %12 question objet indirect +qu2n0vpinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2[cat:sp idx:?Z det:plus]![det:_ ] + { n3[cat:prep]![] + { + n4 type:lex "a" + } + n5 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n6[cat:p idx:?E]![] + { + n7 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n8 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] +} + +%13 relative sujet qui V sp_a pinf_de +rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6[cat:sp idx:?Z ]![] + { n7[cat:prep]![] + { + n8 type:lex "a" + } + n9 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + } + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }}} + +%14 relative objet indirect a qui GN v Pinf_de +rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus qu:_]![cat:n idx:?Z det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Z det:_ qu:_]![cat:n idx:?Z det:_ qu:_] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![det:_ ] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n9 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] + } + }} + + + %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 +n0vn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y det:_ qu:_] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![idx:?Z mode:_ sujidx:_] + } +} + + %15 infinitive persuader gn pinf_de vinfn2pinf1 +vinfn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p idx:?Y mode:_ sujidx:_] +{ + n2 anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:_ qu:_] + n5[cat:p]![] + {n6[cat:prep]![] + { + n7 type:lex "de" + } + n8 type:subst [cat:p idx:?Z mode:inf sujidx:?Y]![cat:p idx:?Z + mode:_ sujidx:_] + } +} + + %16 qu-sujet qui persuade gn pinf_de ? qu0vn2pinf1 +qu0vn2pinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n3 anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z det:_ qu:_ ] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z + mode:_ sujidx:_] + }} + + %17 qu-obj qui gn persuade-il pinf_de ? qu2n0vpinf1 +qu2n0vpinf1(?E ?X ?Y ?Z) initial + n1[cat:p]![] +{ + n2 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z det:_ qu:plus] + n3[cat:p idx:?E]![] + { + n4 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n5 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] +} + +%18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 +rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus qu:_]![cat:n idx:?X det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?X det:_ qu:_]![cat:n idx:?X det:_ qu:_ ] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:_ ] + n4 anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:_ + det:_ qu:_] + n7[cat:p]![] + {n8[cat:prep]![] + { + n9 type:lex "de" + } + n10 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y + mode:_ sujidx:_] + }}} + +%19 rel-obj n dont gn persuade gn rel1n0vn2 +rel1n0vn2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus qu:_]![cat:n idx:?Y det:_ qu:_ ] +{ + n1 type:foot [cat:n idx:?Y det:_ qu:_]![cat:n idx:?Y det:_ qu:_] + n2[cat:p]![] + { + n3 type:subst [cat:c idx:?Y det:plus qu:_]![cat:c idx:?Y det:_ qu:_] + n4[cat:p idx:?E]![] + { + n5 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X det:_ qu:minus ] + n6 anchor [cat:v idx:?E]![cat:p idx:?E] + } + n8 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + det:_ qu:minus ] + } +} + diff --git a/examples/ej/lexicon b/examples/ej/lexicon --- a/examples/ej/lexicon +++ b/examples/ej/lexicon @@ -48,9 +48,13 @@ Vinny Pn(?Entity ! agr:sg3) semantics:[name(_ ?Entity vincent)] +% Unicode Émilie Pn(?Entity ! agr:sg3) semantics:[name(_ ?Entity émilie)] +% string literals +"Joe \"the Boxer\" Stephens" Pn(?Entity ! agr:sg3) +semantics:[name(_ ?Entity joe_stephens)] %% Verbs %% intransitive verbs diff --git a/examples/ej/macros b/examples/ej/macros deleted file mode 100644 --- a/examples/ej/macros +++ /dev/null @@ -1,92 +0,0 @@ -%% -%% Tree Templates -%% -%% -%% INITIAL TREES -%% s trees -%% (IntrV, TrV, TrVPP) -%% np trees -%% (Dp, Pn) -%% n trees -%% (Cn) -%% -%% AUXILIARY TREES -%% n trees -%% (Adj) -%% vp trees -%% (Adv) - - -%% INITIAL TREES - -vArity1:IntrV(?Event ?Agent ! agr:?A) initial - n1[cat:s idx:?Event]![] - { - n2 type:subst [cat:np idx:?Agent]![] - n3 [cat:vp idx:?Event]![] - { - n4 anchor [cat:v idx:?Event]![] - } - } - -vArity2:TrV(?Event ?Agent ?Experiencer ! agr:?A) initial - n1[cat:s idx:?Event]![] - { - n2 type:subst [cat:np idx:?Agent ]![] - n3[cat:vp idx:?Event]![] - { - n4 anchor [cat:v idx:?Event]![] - n6 type:subst [cat:np idx:?Experiencer ]![] - } - } - -vArity3:TrVPP(?Event ?Agent ?Theme ?Loc ! agr:?A) initial - n1[cat:s idx:?Event]![] - { - n2 type:subst [cat:np idx:?Agent ]![] - n3[cat:vp idx:?Event]![] - { - n4 anchor [cat:v idx:?Event]![] - n6 type:subst [cat:np idx:?Theme ]![] - n7 aconstr:noadj [cat:pp]![] - { - n8[cat:p]![] - { - n9 type:lex "from" - } - n10 type:subst [cat:np idx:?Loc ]![] - } - } - } - -Dp(?Entity ! agr:?A) initial - n1[cat:np idx:?Entity]![] - { - n2 anchor [cat:det]![] - n4 type:subst [cat:n idx:?Entity ]![] - } - -Pn(?Entity ! agr:?A) initial - n1[cat:np idx:?Entity]![] - { - n2 anchor [cat:pn idx:?Entity]![] - } - -Cn(?Entity ! agr:?A) initial - n1 anchor [cat:n idx:?Entity]![] - -%% ?AUXILIARY ?TREES - -Adj(?Entity) auxiliary - n1[cat:n idx:?Entity]![] - { - n2 anchor [cat:adj]![] - n4 type:foot [cat:n idx:?Entity ]![] - } - -Adv(?Event) auxiliary - n1[cat:vp idx:?Event]![] - { - n2 type:foot [cat:vp idx:?Event]![] - n3 anchor [cat:adv]![] - } diff --git a/examples/ej/suite b/examples/ej/suite --- a/examples/ej/suite +++ b/examples/ej/suite @@ -18,6 +18,12 @@ name(s2 ex émilie)] [Vincent loves Émilie] +v_loves_j +semantics: [ name(s1 a vincent) + love(e a ex) + name(s2 ex joe_stephens)] +[Vincent loves Joe "the Boxer" Stephens] + v_loves_m_f semantics : [name(s1 a vincent) love(e a ex) diff --git a/examples/ej/trees b/examples/ej/trees new file mode 100644 --- /dev/null +++ b/examples/ej/trees @@ -0,0 +1,92 @@ +%% +%% Tree Templates +%% +%% +%% INITIAL TREES +%% s trees +%% (IntrV, TrV, TrVPP) +%% np trees +%% (Dp, Pn) +%% n trees +%% (Cn) +%% +%% AUXILIARY TREES +%% n trees +%% (Adj) +%% vp trees +%% (Adv) + + +%% INITIAL TREES + +vArity1:IntrV(?Event ?Agent ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent]![] + n3 [cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + } + } + +vArity2:TrV(?Event ?Agent ?Experiencer ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent ]![] + n3[cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + n6 type:subst [cat:np idx:?Experiencer ]![] + } + } + +vArity3:TrVPP(?Event ?Agent ?Theme ?Loc ! agr:?A) initial + n1[cat:s idx:?Event]![] + { + n2 type:subst [cat:np idx:?Agent ]![] + n3[cat:vp idx:?Event]![] + { + n4 anchor [cat:v idx:?Event]![] + n6 type:subst [cat:np idx:?Theme ]![] + n7 aconstr:noadj [cat:pp]![] + { + n8[cat:p]![] + { + n9 type:lex "from" + } + n10 type:subst [cat:np idx:?Loc ]![] + } + } + } + +Dp(?Entity ! agr:?A) initial + n1[cat:np idx:?Entity]![] + { + n2 anchor [cat:det]![] + n4 type:subst [cat:n idx:?Entity ]![] + } + +Pn(?Entity ! agr:?A) initial + n1[cat:np idx:?Entity]![] + { + n2 anchor [cat:pn idx:?Entity]![] + } + +Cn(?Entity ! agr:?A) initial + n1 anchor [cat:n idx:?Entity]![] + +%% ?AUXILIARY ?TREES + +Adj(?Entity) auxiliary + n1[cat:n idx:?Entity]![] + { + n2 anchor [cat:adj]![] + n4 type:foot [cat:n idx:?Entity ]![] + } + +Adv(?Event) auxiliary + n1[cat:vp idx:?Event]![] + { + n2 type:foot [cat:vp idx:?Event]![] + n3 anchor [cat:adv]![] + } diff --git a/examples/nosemantics/macros b/examples/nosemantics/macros deleted file mode 100644 --- a/examples/nosemantics/macros +++ /dev/null @@ -1,363 +0,0 @@ -%% -%% GENI Macro -%% This macro was automatically generated by -%% a tagml->macro script, tagml2genimacro.xsl -%% 2005 -%% contact: kow@loria.fr lai@loria.fr - -n() initial -n1 anchor - -{ -} - -pro() initial -n1 anchor - -{ -} - -pro_substantif() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -} - -det_n() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -n1.2 type:foot [cat:nom]![cat:nom] -} - -n_la() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -} - -det_substantif() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -} - -det_det() auxiliary -n1 [cat:det]![cat:det] -{ -n1.1 type:foot [cat:det]![cat:det] -n1.2 anchor -} - -np() initial -n1 anchor - -{ -} - -np_substantif() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -} - -n_np() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -} - -n_con_n() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 anchor -n1.3 type:subst [cat:nom]![cat:nom] -} - -enum_n() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -} - -n_pred() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 [cat:gp]![cat:gp] -{ -n1.2.1 anchor -n1.2.2 type:subst [cat:nom]![cat:nom] -} -} - -compl_n() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 [cat:cdn]![cat:cdn] -{ -n1.2.1 anchor -n1.2.2 type:subst [cat:nom]![cat:nom] -} -} - -adj() initial -n1 anchor - -{ -} - -adj_substantif() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -} - -adv_adj() auxiliary -n1 [cat:adj]![cat:adj] -{ -n1.1 anchor -n1.2 type:foot [cat:adj]![cat:adj] -} - -adj_n() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -n1.2 type:foot [cat:nom]![cat:nom] -} - -n_adj() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -} - -n_gp() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 [cat:gp]![cat:gp] -{ -n1.2.1 anchor -n1.2.2 type:subst [cat:nom]![cat:nom] -} -} - -s_gp() auxiliary -n1 [cat:sen]![cat:sen] -{ -n1.1 type:foot [cat:sen]![cat:sen] -n1.2 [cat:gp]![cat:gp] -{ -n1.2.1 anchor -n1.2.2 type:subst [cat:nom]![cat:nom] -} -} - -gp_s() auxiliary -n1 [cat:sen]![cat:sen] -{ -n1.1 type:foot [cat:sen]![cat:sen] -n1.2 [cat:gp]![cat:gp] -{ -n1.2.1 anchor -n1.2.2 type:subst [cat:nom]![cat:nom] -} -} - -gp() initial -n1 [cat:gp]![cat:gp] -{ -n1.1 anchor -n1.2 type:subst [cat:nom]![cat:nom] -} - -gpro() initial -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -n1.2 type:subst [cat:nom]![cat:nom] -} - -gpro_n_right() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -n1.3 type:subst [cat:nom]![cat:nom] -} - -n0_v() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 anchor -} - -n0_v_n1() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 anchor -n1.3 type:subst [cat:nom]![cat:nom] -} - -pro_v() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:pro]![cat:pro] -n1.2 anchor -} - -pro_v_n1() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:pro]![cat:pro] -n1.2 anchor -n1.3 type:subst [cat:nom]![cat:nom] -} - -v_inf() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -} - -v_n1_inf() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -n1.2 type:subst [cat:nom]![cat:nom] -} - -n0_v_s() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:nom]![cat:nom] -n1.2 anchor -n1.3 type:subst [cat:sen]![cat:sen] -} - -pro_v_s() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:subst [cat:pro]![cat:pro] -n1.2 anchor -n1.3 type:subst [cat:sen]![cat:sen] -} - -mod_v() auxiliary -n1 [cat:ver]![cat:ver] -{ -n1.1 anchor -n1.2 type:foot [cat:ver]![cat:ver] -} - -il_faut_n0() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 type:lex "il" -n1.2 anchor -n1.3 type:subst [cat:nom]![cat:nom] -} - -mod_pro_left() auxiliary -n1 [cat:ver]![cat:ver] -{ -n1.1 anchor -n1.2 type:foot [cat:ver]![cat:ver] -} - -qu_est_ce_que() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -n1.2 type:subst [cat:sen]![cat:sen] -} - -v_pro() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -n1.2 type:subst [cat:pro]![cat:pro] -} - -v_pro_n() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -n1.2 type:subst [cat:pro]![cat:pro] -n1.3 type:subst [cat:nom]![cat:nom] -} - -v_pro_s() initial -n1 [cat:sen]![cat:sen] -{ -n1.1 anchor -n1.2 type:subst [cat:pro]![cat:pro] -n1.3 type:subst [cat:sen]![cat:sen] -} - -mod_adv_left() auxiliary -n1 [cat:ver]![cat:ver] -{ -n1.1 anchor -n1.2 type:foot [cat:ver]![cat:ver] -} - -mod_adv_right() auxiliary -n1 [cat:ver]![cat:ver] -{ -n1.1 type:foot [cat:ver]![cat:ver] -n1.2 anchor -} - -mod_adv() auxiliary -n1 [cat:adv]![cat:adv] -{ -n1.1 anchor -n1.2 type:foot [cat:adv]![cat:adv] -} - -mod_adv_n_left() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 type:foot [cat:nom]![cat:nom] -n1.2 anchor -} - -mod_adv_n_right() auxiliary -n1 [cat:nom]![cat:nom] -{ -n1.1 anchor -n1.2 type:foot [cat:nom]![cat:nom] -} - -adv() initial -n1 anchor - -{ -} - -entre_np_et_np() initial -n1 [cat:gp]![cat:gp] -{ -n1.1 anchor -n1.2 type:subst [cat:nompropre]![cat:nompropre] -n1.3 type:lex "et" -n1.4 type:subst [cat:nompropre]![cat:nompropre] -} - -int() initial -n1 anchor - -{ -} - diff --git a/examples/nosemantics/trees b/examples/nosemantics/trees new file mode 100644 --- /dev/null +++ b/examples/nosemantics/trees @@ -0,0 +1,363 @@ +%% +%% GENI Macro +%% This macro was automatically generated by +%% a tagml->macro script, tagml2genimacro.xsl +%% 2005 +%% contact: kow@loria.fr lai@loria.fr + +n() initial +n1 anchor + +{ +} + +pro() initial +n1 anchor + +{ +} + +pro_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +det_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +n_la() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +det_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +det_det() auxiliary +n1 [cat:det]![cat:det] +{ +n1.1 type:foot [cat:det]![cat:det] +n1.2 anchor +} + +np() initial +n1 anchor + +{ +} + +np_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +n_np() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_con_n() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +enum_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_pred() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +compl_n() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 [cat:cdn]![cat:cdn] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +adj() initial +n1 anchor + +{ +} + +adj_substantif() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +} + +adv_adj() auxiliary +n1 [cat:adj]![cat:adj] +{ +n1.1 anchor +n1.2 type:foot [cat:adj]![cat:adj] +} + +adj_n() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +n_adj() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +n_gp() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +s_gp() auxiliary +n1 [cat:sen]![cat:sen] +{ +n1.1 type:foot [cat:sen]![cat:sen] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +gp_s() auxiliary +n1 [cat:sen]![cat:sen] +{ +n1.1 type:foot [cat:sen]![cat:sen] +n1.2 [cat:gp]![cat:gp] +{ +n1.2.1 anchor +n1.2.2 type:subst [cat:nom]![cat:nom] +} +} + +gp() initial +n1 [cat:gp]![cat:gp] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +gpro() initial +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +gpro_n_right() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +n0_v() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +} + +n0_v_n1() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +pro_v() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +} + +pro_v_n1() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +v_inf() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +} + +v_n1_inf() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:nom]![cat:nom] +} + +n0_v_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:nom]![cat:nom] +n1.2 anchor +n1.3 type:subst [cat:sen]![cat:sen] +} + +pro_v_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:subst [cat:pro]![cat:pro] +n1.2 anchor +n1.3 type:subst [cat:sen]![cat:sen] +} + +mod_v() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +il_faut_n0() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 type:lex "il" +n1.2 anchor +n1.3 type:subst [cat:nom]![cat:nom] +} + +mod_pro_left() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +qu_est_ce_que() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:sen]![cat:sen] +} + +v_pro() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +} + +v_pro_n() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +n1.3 type:subst [cat:nom]![cat:nom] +} + +v_pro_s() initial +n1 [cat:sen]![cat:sen] +{ +n1.1 anchor +n1.2 type:subst [cat:pro]![cat:pro] +n1.3 type:subst [cat:sen]![cat:sen] +} + +mod_adv_left() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 anchor +n1.2 type:foot [cat:ver]![cat:ver] +} + +mod_adv_right() auxiliary +n1 [cat:ver]![cat:ver] +{ +n1.1 type:foot [cat:ver]![cat:ver] +n1.2 anchor +} + +mod_adv() auxiliary +n1 [cat:adv]![cat:adv] +{ +n1.1 anchor +n1.2 type:foot [cat:adv]![cat:adv] +} + +mod_adv_n_left() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 type:foot [cat:nom]![cat:nom] +n1.2 anchor +} + +mod_adv_n_right() auxiliary +n1 [cat:nom]![cat:nom] +{ +n1.1 anchor +n1.2 type:foot [cat:nom]![cat:nom] +} + +adv() initial +n1 anchor + +{ +} + +entre_np_et_np() initial +n1 [cat:gp]![cat:gp] +{ +n1.1 anchor +n1.2 type:subst [cat:nompropre]![cat:nompropre] +n1.3 type:lex "et" +n1.4 type:subst [cat:nompropre]![cat:nompropre] +} + +int() initial +n1 anchor + +{ +} + diff --git a/examples/promettre/macros b/examples/promettre/macros deleted file mode 100644 --- a/examples/promettre/macros +++ /dev/null @@ -1,450 +0,0 @@ -%% 02 april 2004 -%% 1. Jean promet un cadeau a Marie -%% 2. Jean promet a Marie de partir -%% 6. la personne qui promet un cadeau a Marie -%% 7. le cadeau que Jean promet a Marie -%% 8. la personne a qui Jean promet un cadeau -%% 9. promettre un cadeau a Marie -%% 10. promettant un cadeau a Marie -%% 11. donner un livre a marie - -% FIXME: eric the non-linguist set all cat:p nodes with unspecified mode to FIXME - -Det(?I) auxiliary -n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I qu:minus] -{ - n2 type:anchor [cat:det]![] - n4 type:foot [cat:n idx:?I]![cat:n idx:?I det:minus] -} - -clitic:cl(?H ?X ! idx:?X ) initial -n1 type:anchor [cat:cl idx:?X]![cat:cl idx:?X] {} - -pronoun:pn(?H ?X ! idx:?X num:?Num gen:?Gen pers:?Pers) initial -n1 [cat:n idx:?X num:?Num gen:?Gen pers:?Pers]![cat:n idx:?X] -{ - n2 type:anchor [cat:pn num:?Num gen:?Gen pers:?Pers]![] -} - -% Common Nouns: voyage -nC(?I!num:?Num gen:?Gen) initial -n1 [cat:n num:?Num gen:?Gen idx:?I]![cat:n num:?Num gen:?Gen idx:?I det:minus qu:minus] -{ - n2 type:anchor [cat:n num:?Num gen:?Gen]![] -} - -% Proper Nouns: Jean -nP(?I!pers:?Pers num:?Num gen:?Gen) initial -n1 type:anchor [cat:n num:?Num pers:?Pers gen:?Gen idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] {} - - - -% jean se aimer -- note: we rely on top/bottom unification -% for this to work -vArity2:n0v(?E ?X ?Y) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?Y] - n5 [cat:se idx:?X det:plus qu:minus]![cat:se idx:?Y] - n3 type:anchor [cat:v idx:?E]![] -} - -vArity2:n0cl1v(?E ?X ?Y) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] - n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] - n3 type:anchor [cat:v idx:?E]![] -} - -vArity2:n0vn1(?E ?X ?Y) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] - n3 type:anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] -} - -% aimer N (jean espere [aimer Marie]) -vArity2:vinfn1(?E ?X ?Y) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n2 type:anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] -} - -% le aimer (jean espere [le aimer]) -cl0vinf(?E ?X ?Y) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] - n2 type:anchor [cat:v idx:?E]![] -} - -% infinitive: le donner un livre (je promets de le donner un livre) -vArity3:cl2vinfn0(?E ?X ?Y ?Z) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n5 type:subst [cat:cl idx:?Z det:plus qu:minus]![cat:cl idx:?Z] - n2 type:anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] -} - - %1 declarative gn promet gn sp_a -vArity3:n0vn1sp2(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] - n3[cat:v idx:?E]![] - { - n4 type:anchor [cat:v pers:?Pers num:?Num]![] - } - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] - n6[cat:sp idx:?Z det:plus]![] - { n8[cat:prep]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } -} - - - %2 infinitive ?V GN SP_a -vArity3:vinfn1sp2(?E ?X ?Y ?Z) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n2 type:anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] - n5[cat:sp idx:?Z det:plus]![] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } -} - -vArity3:n0vn1inf2(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X pers:?Pers num:?Num det:plus qu:minus]![cat:n idx:?X] - n3[cat:v idx:?E]![] - { - n4 type:anchor [cat:v pers:?Pers num:?Num]![] - } - n5[cat:sp idx:?Z det:plus]![] - { n6[cat:p]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z - ] - } - n9 type:subst [cat:p idx:?Y mode:inf]![cat:p idx:?Y] -} - -%8 relative objet indirect -vArity3:rel2n0vn1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Z det:plus]![cat:n idx:?Z] -{ - n1 type:foot [cat:n idx:?Z]![cat:n idx:?Z] - n2[cat:p]![] - { - n3[cat:sp idx:?Z det:plus]![] - { n4[cat:prep]![] - { - n5 type:lex "a" - } - n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z qu:plus] - } - n7[cat:p idx:?E]![] - { - n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] - n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] - n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] - } - } -} - - %9 declarative GN V GN_a Pinf_de -vArity3control:n0vsp2pinf1(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] - n3[cat:v idx:?E]![] - { - n4 type:anchor [cat:v pers:?Pers num:?Num]![] - } - n5[cat:sp idx:?Z det:plus]![] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] - } -} - - %10 infinitive V SP_a Inf_de -vArity3control:vinfsp2pinf1(?E ?X ?Y ?Z) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n2 type:anchor [cat:v idx:?E]![] - n4[cat:sp idx:?Y det:plus]![] - { n5[cat:prep]![] - { - n6 type:lex "a" - } - n7 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y - ] - } - n8[cat:p]![] - {n9[cat:prep]![] - { - n10 type:lex "de" - } - n11 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] - - } -} - - % kowey: promettre a marie de faire... -vArity3control:vinfn2pinf1(?E ?X ?Y ?Z) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n2 type:anchor [cat:v idx:?E]![] - - n5[cat:sp idx:?Z det:plus]![] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } - - n10[cat:p]![] - {n11[cat:prep]![] - { - n12 type:lex "de" - } - n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] - } -} - - %13 relative sujet qui V sp_a pinf_de -vArity3control:rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus]![cat:n idx:?X] -{ - n1 type:foot [cat:n idx:?X]![cat:n idx:?X] - n2[cat:p]![] - { - n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] - n4 type:anchor [cat:v idx:?E]![] - n6[cat:sp idx:?Y]![] - { n7[cat:prep]![] - { - n8 type:lex "a" - } - n9 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n - ] - } - n10[cat:p]![] - {n11[cat:prep]![] - { - n12 type:lex "de" - } - n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] - }}} - - -%14 relative objet indirect a qui GN v Pinf_de -vArity3control:rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] -{ - n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] - n2[cat:p]![] - { - n3[cat:sp idx:?Y det:plus]![] - { n4[cat:prep]![] - { - n5 type:lex "a" - } - n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] - } - n7[cat:p idx:?E]![] - { - n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] - n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] - } - }} - - -vArity3control:rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus]![cat:n idx:?X] -{ - n1 type:foot [cat:n idx:?X]![cat:n idx:?X] - n2[cat:p]![] - { - n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] - n4 type:anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n - ] - n7[cat:p]![] - {n8[cat:prep]![] - { - n9 type:lex "de" - } - n10 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] - }}} - -% relative sujet -vArity3control:rel0vn1sp2(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus]![cat:n idx:?X] -{ - n1 type:foot [cat:n idx:?X]![cat:n idx:?X] - n2[cat:p]![] - { - n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] - n4 type:anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - n7[cat:sp idx:?Y]![] - { n8[cat:p]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] - } - } -} - -% relative objet -vArity3control:rel1vn0sp2(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?X det:plus]![cat:n idx:?X] -{ - n1 type:foot [cat:n idx:?X]![cat:n idx:?X] - n2[cat:p]![] - { - n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] - n4 type:anchor [cat:v idx:?E]![] - n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - n7[cat:sp idx:?Y]![] - { n8[cat:p]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] - } - } -} - - % relative objet indirect -rel2vn0n1(?E ?X ?Y ?Z) auxiliary -n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] -{ - n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] - n2[cat:p]![] - { - n3[cat:sp idx:?Y det:plus]![] - { n4[cat:p]![] - { - n5 type:lex "a" - } - n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] - } - n7[cat:p idx:?E]![] - { - n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] - n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] - n11 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } - } -} - - % kowey: for persuader instead of promettre - % (sujidx is set differently) -vArity3controlObj:n0vsp2pinf1b(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] - n3 type:anchor [cat:v idx:?E]![] - n5[cat:sp idx:?Z det:plus]![] - { n6[cat:prep]![] - { - n7 type:lex "a" - } - n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - } - n9[cat:p]![] - {n10[cat:prep]![] - { - n11 type:lex "de" - } - n12 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] - } -} - - %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 -vArity3controlObj:n0vn2pinf1b(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] - n3 type:anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - n6[cat:p]![] - {n7[cat:prep]![] - { - n8 type:lex "de" - } - n9 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] - } -} - - %15 infinitive persuader gn pinf_de vinfn2pinf1 -vArity3controlObj:vinfn2pinf1b(?E ?X ?Y ?Z) initial -n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] -{ - n2 type:anchor [cat:v idx:?E]![] - n4 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] - n5[cat:p]![] - {n6[cat:prep]![] - { - n7 type:lex "de" - } - n8 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] - } -} - - %18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 -vArity3controlObj:n0vn1sp2(?E ?X ?Y ?Z) initial -n1[cat:p mode:FIXME]![] -{ - n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] - n3 type:anchor [cat:v idx:?E]![] - n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] - n6[cat:sp idx:?Z det:plus]![] - { n8[cat:p]![] - { - n9 type:lex "a" - } - n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z - ] - } -} - -% vi: set cinoptions=0,p0: - - diff --git a/examples/promettre/trees b/examples/promettre/trees new file mode 100644 --- /dev/null +++ b/examples/promettre/trees @@ -0,0 +1,450 @@ +%% 02 april 2004 +%% 1. Jean promet un cadeau a Marie +%% 2. Jean promet a Marie de partir +%% 6. la personne qui promet un cadeau a Marie +%% 7. le cadeau que Jean promet a Marie +%% 8. la personne a qui Jean promet un cadeau +%% 9. promettre un cadeau a Marie +%% 10. promettant un cadeau a Marie +%% 11. donner un livre a marie + +% FIXME: eric the non-linguist set all cat:p nodes with unspecified mode to FIXME + +Det(?I) auxiliary +n1[cat:n idx:?I det:plus qu:minus]![cat:n idx:?I qu:minus] +{ + n2 type:anchor [cat:det]![] + n4 type:foot [cat:n idx:?I]![cat:n idx:?I det:minus] +} + +clitic:cl(?H ?X ! idx:?X ) initial +n1 type:anchor [cat:cl idx:?X]![cat:cl idx:?X] {} + +pronoun:pn(?H ?X ! idx:?X num:?Num gen:?Gen pers:?Pers) initial +n1 [cat:n idx:?X num:?Num gen:?Gen pers:?Pers]![cat:n idx:?X] +{ + n2 type:anchor [cat:pn num:?Num gen:?Gen pers:?Pers]![] +} + +% Common Nouns: voyage +nC(?I!num:?Num gen:?Gen) initial +n1 [cat:n num:?Num gen:?Gen idx:?I]![cat:n num:?Num gen:?Gen idx:?I det:minus qu:minus] +{ + n2 type:anchor [cat:n num:?Num gen:?Gen]![] +} + +% Proper Nouns: Jean +nP(?I!pers:?Pers num:?Num gen:?Gen) initial +n1 type:anchor [cat:n num:?Num pers:?Pers gen:?Gen idx:?I det:plus qu:minus]![cat:n idx:?I det:plus qu:minus] {} + + + +% jean se aimer -- note: we rely on top/bottom unification +% for this to work +vArity2:n0v(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?Y] + n5 [cat:se idx:?X det:plus qu:minus]![cat:se idx:?Y] + n3 type:anchor [cat:v idx:?E]![] +} + +vArity2:n0cl1v(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] + n3 type:anchor [cat:v idx:?E]![] +} + +vArity2:n0vn1(?E ?X ?Y) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + +% aimer N (jean espere [aimer Marie]) +vArity2:vinfn1(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + +% le aimer (jean espere [le aimer]) +cl0vinf(?E ?X ?Y) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n5 type:subst [cat:cl idx:?Y det:plus qu:minus]![cat:cl idx:?Y] + n2 type:anchor [cat:v idx:?E]![] +} + +% infinitive: le donner un livre (je promets de le donner un livre) +vArity3:cl2vinfn0(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n5 type:subst [cat:cl idx:?Z det:plus qu:minus]![cat:cl idx:?Z] + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] +} + + %1 declarative gn promet gn sp_a +vArity3:n0vn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n6[cat:sp idx:?Z det:plus]![] + { n8[cat:prep]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } +} + + + %2 infinitive ?V GN SP_a +vArity3:vinfn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } +} + +vArity3:n0vn1inf2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X pers:?Pers num:?Num det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:p]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + ] + } + n9 type:subst [cat:p idx:?Y mode:inf]![cat:p idx:?Y] +} + +%8 relative objet indirect +vArity3:rel2n0vn1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Z det:plus]![cat:n idx:?Z] +{ + n1 type:foot [cat:n idx:?Z]![cat:n idx:?Z] + n2[cat:p]![] + { + n3[cat:sp idx:?Z det:plus]![] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Z det:plus qu:plus]![cat:n idx:?Z qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + } + } +} + + %9 declarative GN V GN_a Pinf_de +vArity3control:n0vsp2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n pers:?Pers num:?Num idx:?X det:plus qu:minus]![cat:n idx:?X] + n3[cat:v idx:?E]![] + { + n4 type:anchor [cat:v pers:?Pers num:?Num]![] + } + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + } +} + + %10 infinitive V SP_a Inf_de +vArity3control:vinfsp2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4[cat:sp idx:?Y det:plus]![] + { n5[cat:prep]![] + { + n6 type:lex "a" + } + n7 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y + ] + } + n8[cat:p]![] + {n9[cat:prep]![] + { + n10 type:lex "de" + } + n11 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + + } +} + + % kowey: promettre a marie de faire... +vArity3control:vinfn2pinf1(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + } +} + + %13 relative sujet qui V sp_a pinf_de +vArity3control:rel0vsp2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6[cat:sp idx:?Y]![] + { n7[cat:prep]![] + { + n8 type:lex "a" + } + n9 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n + ] + } + n10[cat:p]![] + {n11[cat:prep]![] + { + n12 type:lex "de" + } + n13 type:subst [cat:p idx:?Y mode:inf sujidx:?X]![cat:p idx:?Y] + }}} + + +%14 relative objet indirect a qui GN v Pinf_de +vArity3control:rel2n0vpinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] +{ + n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] + n2[cat:p]![] + { + n3[cat:sp idx:?Y det:plus]![] + { n4[cat:prep]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] + } + }} + + +vArity3control:rel0vn2pinf1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n + ] + n7[cat:p]![] + {n8[cat:prep]![] + { + n9 type:lex "de" + } + n10 type:subst [cat:p idx:?Z mode:inf sujidx:?X]![cat:p idx:?Z] + }}} + +% relative sujet +vArity3control:rel0vn1sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:n idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n7[cat:sp idx:?Y]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] + } + } +} + +% relative objet +vArity3control:rel1vn0sp2(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?X det:plus]![cat:n idx:?X] +{ + n1 type:foot [cat:n idx:?X]![cat:n idx:?X] + n2[cat:p]![] + { + n3 type:subst [cat:cl idx:?X det:plus qu:minus]![cat:cl idx:?X] + n4 type:anchor [cat:v idx:?E]![] + n6 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n7[cat:sp idx:?Y]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n] + } + } +} + + % relative objet indirect +rel2vn0n1(?E ?X ?Y ?Z) auxiliary +n0[cat:n idx:?Y det:plus]![cat:n idx:?Y] +{ + n1 type:foot [cat:n idx:?Y]![cat:n idx:?Y] + n2[cat:p]![] + { + n3[cat:sp idx:?Y det:plus]![] + { n4[cat:p]![] + { + n5 type:lex "a" + } + n6 type:subst [cat:n idx:?Y det:plus qu:plus]![cat:n idx:?Y qu:plus] + } + n7[cat:p idx:?E]![] + { + n8 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X qu:minus] + n9 type:anchor [cat:v idx:?E]![cat:p idx:?E] + n11 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + } +} + + % kowey: for persuader instead of promettre + % (sujidx is set differently) +vArity3controlObj:n0vsp2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5[cat:sp idx:?Z det:plus]![] + { n6[cat:prep]![] + { + n7 type:lex "a" + } + n8 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + } + n9[cat:p]![] + {n10[cat:prep]![] + { + n11 type:lex "de" + } + n12 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %15 declarative gn0 persuade gn2 pinf_de1 n0vn2pinf1 +vArity3controlObj:n0vn2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n6[cat:p]![] + {n7[cat:prep]![] + { + n8 type:lex "de" + } + n9 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %15 infinitive persuader gn pinf_de vinfn2pinf1 +vArity3controlObj:vinfn2pinf1b(?E ?X ?Y ?Z) initial +n1[cat:p idx:?E mode:inf sujidx:?X]![cat:p] +{ + n2 type:anchor [cat:v idx:?E]![] + n4 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z] + n5[cat:p]![] + {n6[cat:prep]![] + { + n7 type:lex "de" + } + n8 type:subst [cat:p idx:?Y mode:inf sujidx:?Z]![cat:p idx:?Y] + } +} + + %18 rel-sjt n qui persuade gn pinf_de rel0vn2pinf1 +vArity3controlObj:n0vn1sp2(?E ?X ?Y ?Z) initial +n1[cat:p mode:FIXME]![] +{ + n2 type:subst [cat:n idx:?X det:plus qu:minus]![cat:n idx:?X] + n3 type:anchor [cat:v idx:?E]![] + n5 type:subst [cat:n idx:?Y det:plus qu:minus]![cat:n idx:?Y] + n6[cat:sp idx:?Z det:plus]![] + { n8[cat:p]![] + { + n9 type:lex "a" + } + n10 type:subst [cat:n idx:?Z det:plus qu:minus]![cat:n idx:?Z + ] + } +} + +% vi: set cinoptions=0,p0: + + diff --git a/examples/xmg-example/Makefile b/examples/xmg-example/Makefile --- a/examples/xmg-example/Makefile +++ b/examples/xmg-example/Makefile @@ -15,12 +15,12 @@ SUITE_LEXICON:=$(LEXICON_DIR)/$(FULL_LEXICON_PREFIX).lex SUITE_MORPH:=$(LEXICON_DIR)/$(MORPH_PREFIX).mph -GENI_GRAMMAR:=$(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).genib +GENI_GRAMMAR:=$(COMPILED_GRAMMAR_DIR)/$(GRAMMAR).geni GENI_LEXICON:=$(LEXICON_DIR)/$(FULL_LEXICON_PREFIX).glex GENI_MORPH:=$(LEXICON_DIR)/$(MORPH_PREFIX).gmorph GENI_SUITE:=suite -GENI_OPTIMISATIONS:='pol f-sem' +GENI_OPTIMISATIONS:='pol' GENI_LEX_FLAGS:=-l $(GENI_LEXICON) -s $(GENI_SUITE) ifdef ENABLE_MORPH @@ -59,7 +59,7 @@ NEW_DERIVATIONS:=new-derivations run: $(GENI_GRAMMAR) lexicon morph - $(GENI) -m $< $(GENI_FLAGS) --nogui --batchdir=results + $(GENI) -m $< $(GENI_FLAGS) --nogui --batchdir=results --rootfeat='[cat:s]' # -------------------------------------------------------------------- # running GenI @@ -109,11 +109,7 @@ %.geni : %.xml $(ECHO_STATUS) "converting to geni text format: $(basename $<)" - $(SILENTLY) geniconvert -f tagml -t geni $< -o $@ - -%.genib : %.geni - $(ECHO_STATUS) "converting to geni binary format: $<" - $(SILENTLY) geniconvert -f geni -t genib $< -o $@ + $(SILENTLY) xsltproc -o $@ xmg2geni.xsl $< # -------------------------------------------------------------------- # lexicon diff --git a/geni-test/MainTest.hs b/geni-test/MainTest.hs new file mode 100644 --- /dev/null +++ b/geni-test/MainTest.hs @@ -0,0 +1,5 @@ +module Main where + +import NLP.GenI.Test + +main = runTests diff --git a/geni-test/NLP/GenI/Test.hs b/geni-test/NLP/GenI/Test.hs new file mode 100644 --- /dev/null +++ b/geni-test/NLP/GenI/Test.hs @@ -0,0 +1,53 @@ +-- ---------------------------------------------------------------------- +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +-- ---------------------------------------------------------------------- + +module NLP.GenI.Test where + +import Data.List ( isPrefixOf ) +import System.Environment ( getArgs ) + +import Test.Framework + +import NLP.GenI.Test.FeatureStructure ( suite ) +import NLP.GenI.Test.Parser ( suite ) +import NLP.GenI.Test.GeniVal ( suite ) +import NLP.GenI.Test.LexicalSelection ( suite ) +import NLP.GenI.Test.Lexicon ( suite ) +import NLP.GenI.Test.Morphology ( suite ) +import NLP.GenI.Test.Polarity ( suite ) +import NLP.GenI.Test.Semantics ( suite ) +import NLP.GenI.Test.Simple.SimpleBuilder ( suite ) +import NLP.GenI.Regression + +runTests :: IO () +runTests = do + args <- filter (not . (`isPrefixOf` "--unit-tests")) `fmap` getArgs + funcSuite <- NLP.GenI.Regression.mkSuite + flip defaultMainWithArgs args + [ NLP.GenI.Test.GeniVal.suite + , NLP.GenI.Test.Parser.suite + , NLP.GenI.Test.FeatureStructure.suite + , NLP.GenI.Test.LexicalSelection.suite + , NLP.GenI.Test.Lexicon.suite + , NLP.GenI.Test.Morphology.suite + , NLP.GenI.Test.Polarity.suite + , NLP.GenI.Test.Semantics.suite + , NLP.GenI.Test.Simple.SimpleBuilder.suite + , funcSuite + ] diff --git a/geni/geni.hs b/geni/geni.hs new file mode 100644 --- /dev/null +++ b/geni/geni.hs @@ -0,0 +1,20 @@ +-- 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. + +module Main (module NLP.GenI.Main) where + +import NLP.GenI.Main diff --git a/src/BoolExp.hs b/src/BoolExp.hs new file mode 100644 --- /dev/null +++ b/src/BoolExp.hs @@ -0,0 +1,12 @@ +module BoolExp where + +data BoolExp a = Cond a + | And (BoolExp a) (BoolExp a) + | Or (BoolExp a) (BoolExp a) + | Not (BoolExp a) + +check :: (a -> Bool) -> BoolExp a -> Bool +check f (Cond x) = f x +check f (And x y) = check f x && check f y +check f (Or x y) = check f x || check f y +check f (Not x) = not (check f x) diff --git a/src/Data/FullList.hs b/src/Data/FullList.hs new file mode 100644 --- /dev/null +++ b/src/Data/FullList.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +module Data.FullList + (FullList, + fromFL, + indeedFL, + head, + tail, + (++), + sortNub, + Listable (..) + ) where + +import Data.FullList.Internal +import Prelude hiding ( head, tail, (++) ) diff --git a/src/Data/FullList/Internal.hs b/src/Data/FullList/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/FullList/Internal.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- from http://www.haskell.org/haskellwiki/Non-empty_list +-- Safe list functions + +module Data.FullList.Internal where + +import Data.Binary +import Control.DeepSeq +import Prelude hiding (head, tail, (++)) +import qualified Prelude +import Data.Data +import Data.List ( sort, nub ) + +newtype FullList a = FullList [a] -- data constructor is not exported! + deriving (Eq, Ord, Show, Data, Typeable) + +fromFL :: FullList a -> [a] +fromFL (FullList x) = x -- Injection into general lists + +-- The following is an analogue of `maybe' +indeedFL :: [a] -> w -> (FullList a -> w) -> w +indeedFL x on_empty on_full + | null x = on_empty + | otherwise = on_full $ FullList x + +-- The following are _total_ functions +-- They are guaranteed to be safe, and so we could have used +-- unsafeHead# and unsafeTail# if GHC provides though... + +head :: FullList a -> a +head (FullList (x:_)) = x +head (FullList _) = error "NList.head is broken" + +tail :: FullList a -> [a] +tail (FullList (_:x)) = x +tail (FullList _) = error "NList.tail is broken" + +(++) :: FullList a -> FullList a -> FullList a +(++) x y = FullList ((Prelude.++) (fromFL x) (fromFL y)) -- OK because both already full + +sortNub :: (Eq a, Ord a) => FullList a -> FullList a +sortNub xs = + case (sort . nub . fromFL $ xs) of + [] -> error "sortNub is broken" + (y:ys) -> y !: ys + +-- Mapping over a non-empty list gives a non-empty list +instance Functor FullList where + fmap f (FullList x) = FullList (map f x) + +-- Adding something to a general list surely gives a non-empty list +infixr 5 !: + +class Listable l where + (!:) :: a -> l a -> FullList a + +instance Listable [] where + (!:) h t = FullList (h:t) + +instance Listable FullList where + (!:) h (FullList t) = FullList (h:t) + +{-! +deriving instance NFData a => NFData (FullList a) +deriving instance Binary a => Binary (FullList a) +!-} +-- GENERATED START + + +instance (NFData a) => NFData (FullList a) where + rnf (FullList x1) = rnf x1 `seq` () + + +instance (Binary a) => Binary (FullList a) where + put (FullList x1) = put x1 + get + = do x1 <- get + return (FullList x1) +-- GENERATED STOP diff --git a/src/MainGeni.lhs b/src/MainGeni.lhs deleted file mode 100644 --- a/src/MainGeni.lhs +++ /dev/null @@ -1,126 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Main} - -Welcome to the GenI source code. The main module is where everything -starts from. If you're trying to figure out how GenI works, the main -action is in Geni and Tags -(chapters \ref{cha:Geni} and \ref{cha:Tags}). - -\begin{code} -module Main (main) where -\end{code} - -\ignore{ -\begin{code} -import Control.Applicative ((<$>)) -import Data.IORef(newIORef) -import Data.Typeable( Typeable ) -import Data.Version ( showVersion ) -import System.Environment(getArgs, getProgName) - -import Paths_GenI ( version ) - -import NLP.GenI.Geni(emptyProgState) -import NLP.GenI.Console(consoleGeni) -import NLP.GenI.Configuration (treatArgs, optionsForStandardGenI, processInstructions, - usage, optionsSections, Params, - hasFlagP, BatchDirFlg(..), DisableGuiFlg(..), - DumpDerivationFlg(..), FromStdinFlg(..), - HelpFlg(..), VersionFlg(..), TestCaseFlg(..), - RegressionTestModeFlg(..), RunUnitTestFlg(..), - ) -import NLP.GenI.Regression (regressionGeni) -import NLP.GenI.Test (runTests) - -#ifdef DISABLE_GUI -import NLP.GenI.Configuration(setFlagP) -import NLP.GenI.Geni(ProgStateRef) -#else -import NLP.GenI.Gui(guiGeni) -#endif - -#ifdef DISABLE_GUI -guiGeni :: ProgStateRef -> IO () -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 - pname <- getProgName - args <- getArgs - confArgs <- forceGuiFlag <$> (processInstructions =<< treatArgs optionsForStandardGenI args) - let pst = emptyProgState confArgs - pstRef <- newIORef pst - let has :: (Typeable f, Typeable x) => (x -> f) -> Bool - has = flip hasFlagP confArgs - mustRunInConsole = has DumpDerivationFlg || has FromStdinFlg || has BatchDirFlg - canRunInConsole = has TestCaseFlg - case () of - _ | has HelpFlg -> putStrLn (usage optionsSections pname) - | has VersionFlg -> putStrLn ("GenI " ++ showVersion version) - | has RunUnitTestFlg -> runTests - | has RegressionTestModeFlg -> regressionGeni pstRef - | mustRunInConsole -> consoleGeni pstRef - | not (has DisableGuiFlg) -> guiGeni pstRef - | canRunInConsole -> consoleGeni pstRef - | otherwise -> fail $ unlines - [ "GenI must either be run..." - , " - with the graphical interface enabled" - , " - in regression testing mode" - , " - in self-diagnostic unit test mode" - , " - with a test case specified" - , " - with a batch directory specified or" - , " - with --dump" - , " - with --from-stdin" - ] - -forceGuiFlag :: Params -> Params -#ifdef DISABLE_GUI -forceGuiFlag = setFlagP DisableGuiFlg () -#else -forceGuiFlag = id -#endif -\end{code} - -% TODO -% Define what is and what is not exported from the modules. -% In particular in BTypes take care to export the inspection function -% but not the types. -% Re-write functions in Main as needed. -% Change input in Lexicon and Grammar to allow more than one anchor. diff --git a/src/NLP/GenI.hs b/src/NLP/GenI.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI.hs @@ -0,0 +1,872 @@ +-- 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. + +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This is the interface between the front and backends of the generator. The GUI +-- and the console interface both talk to this module, and in turn, this module +-- talks to the input file parsers and the surface realisation engine. +module NLP.GenI ( + -- * Main interface + + -- ** Program state and configuration + ProgState(..), ProgStateRef, emptyProgState, + LexicalSelector, + + -- ** Running GenI + runGeni, + GeniResults(..), + GeniResult(..), isSuccess, GeniError(..), GeniSuccess(..), + GeniLexSel(..), + ResultType(..), + + -- * Helpers + initGeni, extractResults, + lemmaSentenceString, prettyResult, + showRealisations, histogram, + getTraces, + + -- ** Loading things + loadEverything, + Loadable(..), + loadLexicon, + loadGeniMacros, + loadTestSuite, parseSemInput, + loadRanking, BadInputException(..), + loadFromString, + ) +where + + +import Control.Applicative ((<$>),(<*>)) +import Control.DeepSeq +import Control.Exception +import Control.Monad.Error +import Data.Binary (Binary, decodeFile) +import Data.IORef (IORef, readIORef, modifyIORef) +import Data.List +import Data.Maybe (fromMaybe) +import Data.Monoid ( mappend, mempty ) +import Data.Text ( Text ) +import Data.Typeable (Typeable) +import System.CPUTime( getCPUTime ) +import System.IO ( stderr ) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Data.FullList ( fromFL ) +import Text.JSON +import qualified System.IO.UTF8 as UTF8 + +import NLP.GenI.Configuration + ( Params, customMorph, customSelector + , getFlagP, hasFlagP, hasOpt, Optimisation(NoConstraints) + , MacrosFlg(..), LexiconFlg(..), TestSuiteFlg(..) + , MorphInfoFlg(..), MorphCmdFlg(..) + , RankingConstraintsFlg(..) + , PartialFlg(..) + , FromStdinFlg(..), VerboseModeFlg(..) + , NoLoadTestSuiteFlg(..) + , RootFeatureFlg(..) + , TracesFlg(..) + , grammarType + , GrammarType(..) + ) +import NLP.GenI.General + ( histogram, geniBug, snd3, first3, ePutStr, ePutStrLn, eFlush, + -- mkLogname, + ) +import NLP.GenI.GeniVal +import NLP.GenI.LexicalSelection ( LexicalSelector, LexicalSelection(..), defaultLexicalSelector ) +import NLP.GenI.Lexicon +import NLP.GenI.Morphology +import NLP.GenI.OptimalityTheory +import NLP.GenI.Parser (geniMacros, geniTagElems, + geniLexicon, geniTestSuite, + geniTestSuiteString, geniSemanticInput, + geniMorphInfo, + runParser, + ParseError, + ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics +import NLP.GenI.Statistics +import NLP.GenI.Tag ( TagElem, idname, tsemantics, ttrace, setTidnums ) +import NLP.GenI.TestSuite ( TestCase(..) ) +import NLP.GenI.TreeSchema +import NLP.GenI.Warning +import qualified NLP.GenI.Builder as B + +-- -- DEBUG +-- import Control.Monad.Writer +-- import NLP.GenI.Lexicon +-- import NLP.GenI.LexicalSelection +-- import NLP.GenI.FeatureStructures + +-- -------------------------------------------------------------------- +-- ProgState +-- -------------------------------------------------------------------- + +-- | The program state consists of its configuration options and abstract, +-- cleaned up representations of all the data it's had to load into memory +-- (tree schemata files, lexicon files, etc). The intention is for the +-- state to stay static until the next time something triggers some file +-- loading. +data ProgState = ProgState + { pa :: Params -- ^ the current configuration + , gr :: Macros -- ^ tree schemata + , le :: Lexicon -- ^ lexical entries + , morphinf :: MorphInputFn -- ^ function to extract morphological + -- information from the semantics (you may + -- instead be looking for + -- 'NLP.GenI.Configuration.customMorph') + , ranking :: OtRanking -- ^ OT constraints (optional) + , traces :: [Text] -- ^ simplified traces (optional) + } + +type ProgStateRef = IORef ProgState + +-- | The program state when you start GenI for the very first time +emptyProgState :: Params -> ProgState +emptyProgState args = ProgState + { pa = args + , gr = [] + , le = [] + , morphinf = const Nothing + , traces = [] + , ranking = [] + } + +-- -------------------------------------------------------------------- +-- Interface +-- Loading and parsing +-- -------------------------------------------------------------------- + +-- | We have one master function that loads all the files GenI is expected to +-- use. This just calls the sub-loaders below, some of which are exported +-- for use by the graphical interface. The master function also makes sure +-- to complain intelligently if some of the required files are missing. +loadEverything :: ProgStateRef -> IO() +loadEverything pstRef = + do pst <- readIORef pstRef + -- + let config = pa pst + isMissing f = not $ hasFlagP f config + -- grammar type + isNotPreanchored = grammarType config /= PreAnchored + isNotPrecompiled = grammarType config /= PreCompiled + useTestSuite = isMissing FromStdinFlg + && isMissing NoLoadTestSuiteFlg + -- display + let errormsg = + concat $ intersperse ", " [ msg | (con, msg) <- errorlst, con ] + errorlst = + [ (isMissing RootFeatureFlg, + "a root feature [empty feature is fine if you are not using polarity filtering]") + , (isNotPrecompiled && isMissing MacrosFlg, + "a tree file") + , (isNotPreanchored && isMissing LexiconFlg, + "a lexicon file") + , (useTestSuite && isMissing TestSuiteFlg, + "a test suite") ] + unless (null errormsg) $ fail ("Please specify: " ++ errormsg) + -- we only have to read in grammars from the simple format + case grammarType config of + PreAnchored -> return () + PreCompiled -> return () + _ -> loadGeniMacros pstRef >> return () + -- we don't have to read in the lexicon if it's already pre-anchored + when isNotPreanchored $ loadLexicon pstRef >> return () + -- in any case, we have to... + loadMorphInfo pstRef + when useTestSuite $ loadTestSuite pstRef >> return () + -- the trace filter file + loadTraces pstRef + -- OT ranking + loadRanking pstRef + + +-- | The file loading functions all work the same way: we load the file, +-- and try to parse it. If this doesn't work, we just fail in IO, and +-- GenI dies. If we succeed, we update the program state passed in as +-- an IORef. +class Loadable x where + lParse :: FilePath -- ^ source (optional) + -> String -> Either ParseError x + lSet :: x -> ProgState -> ProgState + lSummarise :: x -> String + +-- | Note that here we assume the input consists of UTF-8 encoded file +lParseFromFile :: Loadable x => FilePath -> IO (Either ParseError x) +lParseFromFile f = lParse f `fmap` UTF8.readFile f + +-- | Returns the input too (convenient for type checking) +lSetState :: Loadable x => ProgStateRef -> x -> IO x +lSetState pstRef x = modifyIORef pstRef (lSet x) >> return x + +-- to be phased out +throwOnParseError :: String -> Either ParseError x -> IO x +throwOnParseError descr (Left err) = throwIO (BadInputException descr err) +throwOnParseError _ (Right p) = return p + +data BadInputException = BadInputException String ParseError + deriving (Show, Typeable) + +instance Exception BadInputException + +data L a = Loadable a => L + +-- | Load something, exiting GenI if we have not been given the +-- appropriate flag +loadOrDie :: forall f a . (Eq f, Typeable f, Loadable a) + => L a + -> (FilePath -> f) -- ^ flag + -> String + -> ProgStateRef + -> IO a +loadOrDie L flg descr pstRef = + withFlagOrDie flg pstRef descr $ \f -> do + v <- verbosity pstRef + x <- withLoadStatus v f descr lParseFromFile + >>= throwOnParseError descr + >>= lSetState pstRef + return x + +-- | Load something from a string rather than a file +loadFromString :: Loadable a => ProgStateRef + -> String -- ^ description + -> String -- ^ string to load + -> IO a +loadFromString pstRef descr s = + throwOnParseError descr (lParse "" s) >>= lSetState pstRef + +instance Loadable Lexicon where + lParse f = fmap toLexicon . runParser geniLexicon () f + where + fixEntry = finaliseVars "" -- anonymise singletons for performance + . sorter + toLexicon = map fixEntry + sorter l = l { isemantics = (sortByAmbiguity . isemantics) l } + lSet x p = p { le = x } + lSummarise x = show (length x) ++ " lemmas" + +instance Loadable Macros where + lParse f = runParser geniMacros () f + lSet x p = p { gr = x } + lSummarise x = show (length x) ++ " schemata" + +loadLexicon :: ProgStateRef -> IO Lexicon +loadLexicon = loadOrDie (L :: L Lexicon) LexiconFlg "lexicon" + +-- | The macros are stored as a hashing function in the monad. +loadGeniMacros :: ProgStateRef -> IO Macros +loadGeniMacros pstRef = + withFlagOrDie MacrosFlg pstRef descr $ \f -> do + v <- verbosity pstRef + withLoadStatus v f descr (parseFromFileMaybeBinary lParseFromFile) + >>= throwOnParseError "tree schemata" + >>= lSetState pstRef + where + descr = "trees" + +-- | Load something, but only if we are configured to do so +loadOptional :: forall f a . (Eq f, Typeable f, Loadable a) + => L a + -> (FilePath -> f) -- ^ flag + -> String + -> ProgStateRef + -> IO () +loadOptional L flg descr pstRef = + withFlagOrIgnore flg pstRef $ \f -> do + v <- verbosity pstRef + x <- withLoadStatus v f descr lParseFromFile + >>= throwOnParseError descr + >>= lSetState pstRef + let _ = x :: a + return () -- ignore + +newtype MorphFnL = MorphFnL MorphInputFn + +instance Loadable MorphFnL where + lParse f = fmap (MorphFnL . readMorph) . runParser geniMorphInfo () f + lSet (MorphFnL x) p = p { morphinf = x } + lSummarise _ = "morphinfo" + +newtype TracesL = TracesL [Text] + +instance Loadable TracesL where + lParse _ = Right . TracesL . T.lines . T.pack + lSet (TracesL xs) p = p { traces = xs } + lSummarise (TracesL xs) = show (length xs) ++ " traces" + +instance Loadable OtRanking where + lParse _ = resultToEither2 . decode + lSet r p = p { ranking = r } + lSummarise _ = "ranking" + +loadMorphInfo :: ProgStateRef -> IO () +loadMorphInfo = loadOptional (L :: L MorphFnL) MorphInfoFlg "morphological info" + +loadTraces :: ProgStateRef -> IO () +loadTraces = loadOptional (L :: L TracesL) TracesFlg "traces" + +loadRanking :: ProgStateRef -> IO () +loadRanking = loadOptional (L :: L OtRanking) RankingConstraintsFlg "OT constraints" + +resultToEither2 :: Result a -> Either ParseError a +resultToEither2 r = + case resultToEither r of + Left e -> runParser (fail e) () "" [] -- convoluted way to generate a Parsec error + Right x -> Right x + +-- Target semantics +-- +-- Reading in the target semantics (or test suite) is a little more +-- complicated. It follows the same general schema as above, except +-- that we parse the file twice: once for our internal representation, +-- and once to get a string representation of each test case. The +-- string representation is for the graphical interface; it avoids us +-- figuring out how to pretty-print things because we can assume the +-- user will format it the way s/he wants. + +newtype TestSuiteL = TestSuiteL [TestCase] + +instance Loadable TestSuiteL where + lParse f s = + case runParser geniTestSuite () f s of + Left e -> Left e + Right sem -> case runParser geniTestSuiteString () f s of + Left e -> Left e + Right mStrs -> Right (TestSuiteL (zipWith cleanup sem mStrs)) + where + cleanup tc str = + tc { tcSem = first3 sortSem (tcSem tc) + , tcSemString = str } + -- + lSet (TestSuiteL _) p = p + lSummarise (TestSuiteL x) = show (length x) ++ " cases" + +-- | +loadTestSuite :: ProgStateRef -> IO [TestCase] +loadTestSuite pstRef = do + TestSuiteL xs <- loadOrDie (L :: L TestSuiteL) TestSuiteFlg "test suite" pstRef + return xs + +parseSemInput :: String -> Either ParseError SemInput +parseSemInput = fmap smooth . runParser geniSemanticInput () "semantics" + where + smooth (s,r,l) = (sortSem s, sort r, l) + +-- Helpers for loading files + +withFlag :: forall f a . (Eq f, Typeable f) + => (FilePath -> f) -- ^ flag + -> ProgStateRef + -> IO a -- ^ null action + -> (FilePath -> IO a) -- ^ job + -> IO a +withFlag flag pstRef z job = + do config <- pa `fmap` readIORef pstRef + case getFlagP flag config of + Nothing -> z + Just x -> job x + +withFlagOrIgnore :: forall f . (Eq f, Typeable f) + => (FilePath -> f) -- ^ flag + -> ProgStateRef + -> (FilePath -> IO ()) + -> IO () +withFlagOrIgnore flag pstRef = withFlag flag pstRef (return ()) + +withFlagOrDie :: forall f a . (Eq f, Typeable f) + => (FilePath -> f) -- ^ flag + -> ProgStateRef + -> String + -> (FilePath -> IO a) + -> IO a +withFlagOrDie flag pstRef description = + withFlag flag pstRef (fail msg) + where + msg = "Please specify a " ++ description ++ " file!" + +withLoadStatus :: Loadable a + => Bool -- ^ verbose + -> FilePath -- ^ file to load + -> String -- ^ description + -> (FilePath -> IO (Either ParseError a)) -- ^ parsing cmd + -> IO (Either ParseError a) +withLoadStatus False f _ p = p f +withLoadStatus True f d p = do + ePutStr $ unwords [ "Loading", d, f ++ "... " ] + eFlush + mx <- p f + ePutStrLn $ either (const "ERROR") (\x -> lSummarise x ++ " loaded") mx + return mx + +parseFromFileMaybeBinary :: Binary a + => (FilePath -> IO (Either ParseError a)) + -> FilePath + -> IO (Either ParseError a) +parseFromFileMaybeBinary p f = + if (".genib" `isSuffixOf` f) + then Right `fmap` decodeFile f + else p f + +-- -------------------------------------------------------------------- +-- Surface realisation - entry point +-- -------------------------------------------------------------------- + +-- | 'GeniResults' is the outcome of running GenI on a single input semantics. +-- Each distinct result is returned as a single 'GeniResult' (NB: a single +-- result may expand into multiple strings through morphological +-- post-processing), +data GeniResults = GeniResults + { grResults :: [GeniResult] -- ^ one per chart item + , grGlobalWarnings :: [Text] -- ^ usually from lexical selection + , grStatistics :: Statistics -- ^ things like number of chart items + -- to help study efficiency + } + +data GeniResult = GError GeniError + | GSuccess GeniSuccess + deriving (Ord, Eq) + +isSuccess :: GeniResult -> Bool +isSuccess (GSuccess _) = True +isSuccess (GError _) = False + +data GeniError = GeniError [Text] + deriving (Ord, Eq) + +data GeniSuccess = GeniSuccess + { grLemmaSentence :: LemmaPlusSentence -- ^ “original” uninflected result + , grRealisations :: [Text] -- ^ results after morphology + , grResultType :: ResultType + , grWarnings :: [Text] -- ^ warnings “local” to this particular + -- item, cf. 'grGlobalWarnings' + , grDerivation :: B.TagDerivation -- ^ derivation tree behind the result + , grOrigin :: Integer -- ^ normally a chart item id + , grLexSelection :: [GeniLexSel] -- ^ the lexical selection behind + -- this result (info only) + , grRanking :: Int -- ^ see 'NLP.GenI.OptimalityTheory' + , grViolations :: [OtViolation] -- ^ which OT constraints were violated + } deriving (Ord, Eq) + +data GeniLexSel = GeniLexSel + { nlTree :: Text + , nlTrace :: [Text] + } deriving (Ord, Eq) + +data ResultType = CompleteResult | PartialResult deriving (Ord, Eq) + +instance Pretty GeniError where + pretty (GeniError xs) = T.intercalate "\n" $ map ("Error:" <+>) xs + +-- | Entry point! (the most useful function to know here) +-- +-- * Initialises the realiser (lexical selection, among other things), +-- +-- * Runs the builder (the surface realisation engine proper) +-- +-- * Unpacks the builder results +-- +-- * Finalises the results (morphological generation) +-- +-- In addition to the results, this returns a generator state. The latter is +-- is mostly useful for debugging via the graphical interface. +-- Note that we assumes that you have already loaded in your grammar and +-- parsed your input semantics. +runGeni :: ProgStateRef -> SemInput -> B.Builder st it Params -> IO (GeniResults,st) +runGeni pstRef semInput builder = do + pst <- readIORef pstRef + let config = pa pst + run = B.run builder + -- step 1: lexical selection + (initStuff, initWarns) <- initGeni pstRef semInput + --force evaluation before measuring start time to avoid including grammar/lexicon parsing. + start <- rnf initStuff `seq` getCPUTime + -- step 2: chart generation + let (finalSt, stats) = run initStuff config + -- step 3: unpacking and + -- step 4: post-processing + results <- extractResults pstRef builder finalSt + --force evaluation before measuring end time to account for all the work that should be done. + end <- rnf results `seq` getCPUTime + let elapsedTime = picosToMillis $! end - start + diff = round (elapsedTime :: Double) :: Int + stats2 = updateMetrics (incrIntMetric "gen_time" (fromIntegral diff) ) stats + gresults = GeniResults { grResults = results + , grStatistics = stats2 + , grGlobalWarnings = map showWarnings (fromGeniWarnings initWarns) + } + return (gresults, finalSt) + where + showWarnings = T.intercalate "\n" . showGeniWarning + +-- | This is a helper to 'runGenI'. It's mainly useful if you are building +-- interactive GenI debugging tools. +-- +-- Given a builder state, +-- +-- * Unpacks the builder results +-- +-- * Finalises the results (morphological generation) +extractResults :: ProgStateRef -> B.Builder st it Params -> st -> IO [GeniResult] +extractResults pstRef builder finalSt = do + config <- pa <$> readIORef pstRef + -- step 3: unpacking + let uninflected = B.unpack builder finalSt + (rawResults, resultTy) = + if null uninflected && hasFlagP PartialFlg config + then (B.partial builder finalSt, PartialResult) + else (uninflected , CompleteResult) + status = B.finished builder finalSt + -- step 4: post-processing + finaliseResults pstRef (resultTy, status, rawResults) + +-- -------------------------------------------------------------------- +-- Surface realisation - sub steps +-- -------------------------------------------------------------------- + +-- | 'initGeni' performs lexical selection and strips the input semantics of +-- any morpohological literals +initGeni :: ProgStateRef -> SemInput -> IO (B.Input, GeniWarnings) +initGeni pstRef semInput_ = do + pst <- readIORef pstRef + let semInput = stripMorphStuff pst + . maybeRemoveConstraints pst + $ semInput_ + -- lexical selection + selection <- runLexSelection pstRef semInput + -- strip morphological predicates + let initStuff = B.Input + { B.inSemInput = semInput + , B.inLex = lsLexEntries selection + , B.inCands = map (\c -> (c,-1)) (lsAnchored selection) + } + return (initStuff, lsWarnings selection) + where + stripMorphStuff pst = first3 (stripMorphSem (morphinf pst)) + -- disable constraints if the NoConstraintsFlg pessimisation is active + maybeRemoveConstraints pst = + if hasOpt NoConstraints (pa pst) then removeConstraints else id + +-- | 'finaliseResults' does any post-processing steps that we want to integrate +-- into mainline GenI. So far, this consists of morphological realisation and +-- OT ranking +finaliseResults :: ProgStateRef -> (ResultType, B.GenStatus, [B.Output]) -> IO [GeniResult] +finaliseResults pstRef (ty, status, os) = do + pst <- readIORef pstRef + -- morph TODO: make this a bit safer + mss <- case getFlagP MorphCmdFlg (pa pst) of + Nothing -> let morph = fromMaybe (map sansMorph) (customMorph (pa pst)) + in return (morph sentences) + Just cmd -> map snd `fmap` inflectSentencesUsingCmd cmd sentences + -- OT ranking + let unranked = zipWith (sansRanking pst) os mss + rank = rankResults (getTraces pst) grDerivation (ranking pst) + successes = map addRanking (rank unranked) + failures = case status of + B.Error str -> [GeniError [str]] + B.Finished -> [] + B.Active -> [] + return (map GError failures ++ map GSuccess successes) + where + sentences = map snd3 os + sansRanking pst (i,l,d) rs = GeniSuccess + { grLemmaSentence = l + , grRealisations = moRealisations rs + , grWarnings = moWarnings rs + , grDerivation = d + , grLexSelection = map (\x -> GeniLexSel x (getTraces pst x)) (B.lexicalSelection d) + , grRanking = -1 + , grViolations = [] + , grResultType = ty + , grOrigin = i + } + addRanking (i,res,vs) = res { grViolations = vs, grRanking = i } + +-- -------------------------------------------------------------------- +-- Displaying results +-- -------------------------------------------------------------------- + +-- | Show the sentences produced by the generator, in a relatively compact form +showRealisations :: [String] -> String +showRealisations [] = "(none)" +showRealisations xs = unlines . map sho . Map.toList . histogram $ xs + where + sho (x,1) = x + sho (x,c) = x ++ " (" ++ show c ++ " instances)" + +-- | No morphology! Pretend the lemma string is a sentence +lemmaSentenceString :: GeniSuccess -> Text +lemmaSentenceString = T.unwords . map lpLemma . grLemmaSentence + +prettyResult :: ProgState -> GeniSuccess -> Text +prettyResult pst nr = + T.intercalate "\n" . map showOne . grRealisations $ nr + where + showOne str = pretty theRanking <> ". " <> str <> "\n" <> violations + violations = prettyViolations tracesFn verbose (grViolations nr) + theRanking = grRanking nr + verbose = hasFlagP VerboseModeFlg (pa pst) + tracesFn = getTraces pst + +-- | 'getTraces' is most likely useful for grammars produced by a +-- metagrammar system. Given a tree name, we retrieve the ``trace'' +-- information from the grammar for all trees that have this name. We +-- assume the tree name was constructed by GenI; see the source code for +-- details. +getTraces :: ProgState -> Text -> [Text] +getTraces pst tname = + filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ] + where + filt = case traces pst of + [] -> id + theTs -> filter (`elem` theTs) + +-- | We assume the name was constructed by 'combineName' +readPidname :: Text -> Text +readPidname n = + case T.splitOn ":" n of + (_:_:p:_) -> p + _ -> geniBug "NLP.GenI.readPidname or combineName are broken" + +-- -------------------------------------------------------------------- +-- Lexical selection +-- -------------------------------------------------------------------- + +-- | Runs the lexical selection (be it the standard GenI version or +-- a custom function supplied by a user) and runs the results +-- through the universal 'finaliseLexSelection'. +-- +-- Also hunts for some warning conditions +runLexSelection :: ProgStateRef -> SemInput -> IO LexicalSelection +runLexSelection pstRef (tsem,_,litConstrs) = do + pst <- readIORef pstRef + let config = pa pst + verbose = hasFlagP VerboseModeFlg config + -- perform lexical selection + selector <- getLexicalSelector pstRef + selection <- selector (gr pst) (le pst) tsem + let lexCand = lsLexEntries selection + candFinal = finaliseLexSelection (morphinf pst) tsem litConstrs (lsAnchored selection) + -- status + when verbose $ T.hPutStrLn stderr . T.unlines $ + "Lexical items selected:" + : map (indent . showLexeme . fromFL . iword) lexCand + ++ ["Trees anchored (family) :"] + ++ map (indent . idname) candFinal + -- warnings + let semWarnings = case missingLiterals candFinal tsem of + [] -> [] + xs -> [NoLexSelection xs] + return $ selection { lsAnchored = candFinal + , lsWarnings = mkGeniWarnings semWarnings `mappend` lsWarnings selection + } + where + indent x = ' ' `T.cons` x + +-- | Grab the lexical selector from the config, or return the standard GenI +-- version if none is supplied +getLexicalSelector :: ProgStateRef -> IO LexicalSelector +getLexicalSelector pstRef = do + config <- pa <$> readIORef pstRef + case (customSelector config, grammarType config) of + (Just s, _) -> return s + (Nothing, PreAnchored) -> mkPreAnchoredLexicalSelector pstRef + (Nothing, _) -> return defaultLexicalSelector + +-- | @missingLiterals ts sem@ returns any literals in @sem@ that do not +-- appear in any of the @ts@ trees +missingLiterals :: [TagElem] -> [Literal GeniVal] -> [Literal GeniVal] +missingLiterals cands tsem = + tsem \\ (nub $ concatMap tsemantics cands) + +-- | Post-processes lexical selection results to things which +-- GenI considers applicable to all situations: +-- +-- * attaches morphological information to trees +-- +-- * throws out elementary trees that violate trace constraints +-- given by the user +-- +-- * filters out any elementary tree whose semantics contains +-- things that are not in the input semantics +finaliseLexSelection :: MorphInputFn -> Sem -> [LitConstr] -> [TagElem] -> [TagElem] +finaliseLexSelection morph tsem litConstrs = + setTidnums . considerCoherency . considerLc . considerMorph + where + -- attach any morphological information to the candidates + considerMorph = attachMorph morph tsem + -- filter out candidates which do not fulfill the trace constraints + matchesLc t = all (`elem` myTrace) constrs + where constrs = concat [ cs | (l,cs) <- litConstrs, l `elem` mySem ] + mySem = tsemantics t + myTrace = ttrace t + considerLc = filter matchesLc + -- filter out candidates whose semantics has bonus stuff which does + -- not occur in the input semantics + considerCoherency = filter (all (`elem` tsem) . tsemantics) + +-- -------------------------------------------------------------------- +-- Pre-selection and pre-anchoring +-- -------------------------------------------------------------------- + +newtype PreAnchoredL = PreAnchoredL [TagElem] + +instance Loadable PreAnchoredL where + lParse f = fmap PreAnchoredL + . runParser geniTagElems () f + lSet _ p = p -- this does not update prog state at all + lSummarise (PreAnchoredL xs) = show (length xs) ++ " trees" + +readPreAnchored :: ProgStateRef -> IO [TagElem] +readPreAnchored pstRef = do + PreAnchoredL xs <- loadOrDie (L :: L PreAnchoredL) + MacrosFlg "preanchored trees" pstRef + return xs + +mkPreAnchoredLexicalSelector :: ProgStateRef -> IO LexicalSelector +mkPreAnchoredLexicalSelector pstRef = do + xs <- readPreAnchored pstRef + return (\_ _ _ -> return (LexicalSelection xs [] mempty)) + +-- -------------------------------------------------------------------- +-- Boring utility code +-- -------------------------------------------------------------------- + +verbosity :: ProgStateRef -> IO Bool +verbosity = fmap (hasFlagP VerboseModeFlg . pa) + . readIORef + +instance JSON GeniResult where + readJSON j = + case readJSON j of + Ok s -> Ok (GSuccess s) + Error _ -> GError `fmap` readJSON j + showJSON (GSuccess x) = showJSON x + showJSON (GError x) = showJSON x + +instance JSON GeniSuccess where + readJSON j = do + jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + GeniSuccess <$> field "raw" + <*> field "realisations" + <*> field "result-type" + <*> field "warnings" + <*> field "derivation" + <*> field "chart-item" + <*> field "lexical-selection" + <*> field "ranking" + <*> field "violations" + showJSON nr = + JSObject . toJSObject $ [ ("raw", showJSON $ grLemmaSentence nr) + , ("realisations", showJSONs $ grRealisations nr) + , ("derivation", showJSONs $ grDerivation nr) + , ("lexical-selection", showJSONs $ grLexSelection nr) + , ("ranking", showJSON $ grRanking nr) + , ("violations", showJSONs $ grViolations nr) + , ("result-type", showJSON $ grResultType nr) + , ("chart-item", showJSON $ grOrigin nr) + , ("warnings", showJSONs $ grWarnings nr) + ] + +instance JSON GeniError where + readJSON j = + do jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + GeniError <$> field "errors" + showJSON (GeniError xs) = + JSObject . toJSObject $ [ ("errors", showJSON xs) ] + +instance JSON ResultType where + readJSON j = + do js <- fromJSString `fmap` readJSON j + case js of + "partial" -> return PartialResult + "complete" -> return CompleteResult + ty -> fail $ "unknown result type: " ++ ty + showJSON CompleteResult = JSString $ toJSString "complete" + showJSON PartialResult = JSString $ toJSString "partial" + +instance JSON GeniLexSel where + readJSON j = + do jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + GeniLexSel <$> field "lex-item" + <*> field "trace" + showJSON x = + JSObject . toJSObject $ [ ("lex-item", showJSON $ nlTree x) + , ("trace", showJSONs $ nlTrace x) + ] + +-- Converts picoseconds to milliseconds. +picosToMillis :: Integer -> Double +picosToMillis t = realToFrac t / (10^(9 :: Int)) + +{- +data MNAME = MNAME deriving Typeable +logname :: String +logname = mkLogname MNAME +-} + +{-! +deriving instance NFData GeniResult +deriving instance NFData GeniSuccess +deriving instance NFData GeniError +deriving instance NFData ResultType +deriving instance NFData GeniLexSel +!-} + +-- GENERATED START + + +instance NFData GeniResult where + rnf (GError x1) = rnf x1 `seq` () + rnf (GSuccess x1) = rnf x1 `seq` () + + +instance NFData GeniSuccess where + rnf (GeniSuccess x1 x2 x3 x4 x5 x6 x7 x8 x9) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` + rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` () + + +instance NFData GeniError where + rnf (GeniError x1) = rnf x1 `seq` () + + +instance NFData ResultType where + rnf CompleteResult = () + rnf PartialResult = () + + +instance NFData GeniLexSel where + rnf (GeniLexSel x1 x2) = rnf x1 `seq` rnf x2 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/Btypes.lhs b/src/NLP/GenI/Btypes.lhs deleted file mode 100644 --- a/src/NLP/GenI/Btypes.lhs +++ /dev/null @@ -1,757 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Btypes} -\label{cha:Btypes} - -This module provides basic datatypes like GNode, as well as operations -on trees, nodes and semantics. Things here are meant to be relatively -low-level and primitive (well, with the exception of feature structure -unification, that is). - -\ignore{ -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-} -module NLP.GenI.Btypes( - -- Datatypes - GNode(..), GType(Subs, Foot, Lex, Other), NodeName, - Ttree(..), MTtree, SemPols, TestCase(..), - Ptype(Initial,Auxiliar,Unspecified), - Pred, Flist, AvPair(..), GeniVal(..), - Lexicon, ILexEntry(..), MorphLexEntry, Macros, Sem, LitConstr, SemInput, Subst, - emptyLE, emptyGNode, emptyMacro, - - -- GNode stuff - gCategory, showLexeme, lexemeAttributes, gnnameIs, - - -- Functions from Tree GNode - plugTree, spliceTree, - root, rootUpd, foot, setLexeme, setAnchor, - - -- Functions from Sem - toKeys, subsumeSem, sortSem, showSem, showPred, - emptyPred, - - -- Functions from Flist - sortFlist, unify, unifyFeat, mergeSubst, - showFlist, showPairs, showAv, - - -- Other functions - replace, DescendGeniVal(..), replaceList, - Collectable(..), Idable(..), - alphaConvert, alphaConvertById, - fromGConst, fromGVar, - isConst, isVar, isAnon, - - -- Polarities - -) where - - --- import Debug.Trace -- for test stuff -import Data.List -import Data.Maybe ( mapMaybe ) -import Data.Function ( on ) -import Data.Generics (Data) -import Data.Typeable (Typeable) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Tree - -import Data.Generics.PlateDirect - -import NLP.GenI.General(filterTree, listRepNode, snd3, geniBug) -import NLP.GenI.GeniVal - ---instance Show (IO()) where --- show _ = "" -\end{code} -} - -% ---------------------------------------------------------------------- -\section{Grammar} -% ---------------------------------------------------------------------- - -A grammar is composed of some unanchored trees (macros) and individual -lexical entries. The trees are grouped into families. Every lexical -entry is associated with a single family. See section section -\ref{sec:combine_macros} for the process that combines lexical items -and trees into a set of anchored trees. - -\begin{code} -type MTtree = Ttree GNode -type Macros = [MTtree] - -data Ttree a = TT - { params :: [GeniVal] - , pfamily :: String - , pidname :: String - , pinterface :: Flist - , ptype :: Ptype - , psemantics :: Maybe Sem - , ptrace :: [String] - , tree :: Tree a } - deriving (Show, Data, Typeable) - -data Ptype = Initial | Auxiliar | Unspecified - deriving (Show, Eq, Data, Typeable) - -instance Biplate (Ttree String) GeniVal where - biplate (TT zps x1 x2 zint x3 zsem x4 x5) = - plate TT ||* zps |- x1 |- x2 - ||+ zint |- x3 - |+ zsem |- x4 |- x5 - -instance Biplate (Ttree GNode) GeniVal where - biplate (TT zps x1 x2 zint x3 zsem x4 zt) = - plate TT ||* zps |- x1 |- x2 - ||+ zint |- x3 - |+ zsem |- x4 - |+ zt - -instance DescendGeniVal (Ttree GNode) where - descendGeniVal s mt = - mt { params = descendGeniVal s (params mt) - , tree = descendGeniVal s (tree mt) - , pinterface = descendGeniVal s (pinterface mt) - , psemantics = descendGeniVal s (psemantics mt) } - -instance (Collectable a) => Collectable (Ttree a) where - collect mt = (collect $ params mt) . (collect $ tree mt) . - (collect $ psemantics mt) . (collect $ pinterface mt) - --- | A null tree which you can use for various debugging or display purposes. -emptyMacro :: MTtree -emptyMacro = TT { params = [], - pidname = "", - pfamily = "", - pinterface = [], - ptype = Unspecified, - psemantics = Nothing, - ptrace = [], - tree = Node emptyGNode [] - } -\end{code} - -\paragraph{Lexical entries} - -\begin{code} --- | A lexicon maps semantic predicates to lexical entries. -type Lexicon = Map.Map String [ILexEntry] -type SemPols = [Int] -data ILexEntry = ILE - { -- normally just a singleton, useful for merging synonyms - iword :: [String] - , ifamname :: String - , iparams :: [GeniVal] - , iinterface :: Flist - , ifilters :: Flist - , iequations :: Flist - , iptype :: Ptype - , isemantics :: Sem - , isempols :: [SemPols] } - deriving (Show, Eq, Data, Typeable) - -instance Biplate ILexEntry GeniVal where - biplate (ILE x1 x2 zps zint zfilts zeq x3 zsem x4) = - plate ILE |- x1 |- x2 - ||* zps - ||+ zint - ||+ zfilts - ||+ zeq |- x3 - ||+ zsem |- x4 - -instance DescendGeniVal ILexEntry where - descendGeniVal s i = - i { iinterface = descendGeniVal s (iinterface i) - , iequations = descendGeniVal s (iequations i) - , isemantics = descendGeniVal s (isemantics i) - , iparams = descendGeniVal s (iparams i) } - -instance Collectable ILexEntry where - collect l = (collect $ iinterface l) . (collect $ iparams l) . - (collect $ ifilters l) . (collect $ iequations l) . - (collect $ isemantics l) - -emptyLE :: ILexEntry -emptyLE = ILE { iword = [], - ifamname = "", - iparams = [], - iinterface = [], - ifilters = [], - iptype = Unspecified, - isemantics = [], - iequations = [], - isempols = [] } -\end{code} - -\begin{code} -type MorphLexEntry = (String,String,Flist) -\end{code} - -% ---------------------------------------------------------------------- -\section{TAG nodes (GNode)} -% ---------------------------------------------------------------------- - -\begin{code} --- | A single node of a TAG tree. -data GNode = GN{gnname :: NodeName, - gup :: Flist, -- ^ top feature structure - gdown :: Flist, -- ^ bottom feature structure - ganchor :: Bool, -- ^ @False@ for na nodes - glexeme :: [String], -- ^ @[]@ for na nodes - gtype :: GType, - gaconstr :: Bool, - gorigin :: String -- ^ for TAG, this would be the elementary tree - -- that this node originally came from - } - deriving (Eq, Data, Typeable) - -instance Biplate GNode GeniVal where - biplate (GN x1 zu zd x2 x3 x4 x5 x6) = - plate GN |- x1 - ||+ zu - ||+ zd |- x2 |- x3 |- x4 |- x5 |- x6 - -instance Biplate (Tree GNode) GeniVal where - biplate (Node zn zkids) = plate Node |+ zn ||+ zkids - --- Node type used during parsing of the grammar -data GType = Subs | Foot | Lex | Other - deriving (Show, Eq, Data, Typeable) - -type NodeName = String - --- | A null 'GNode' which you can use for various debugging or display purposes. -emptyGNode :: GNode -emptyGNode = GN { gnname = "", - gup = [], gdown = [], - ganchor = False, - glexeme = [], - gtype = Other, - gaconstr = False, - gorigin = "" } - -gnnameIs :: NodeName -> GNode -> Bool -gnnameIs n = (== n) . gnname -\end{code} - -A TAG node may have a category. In the core GenI algorithm, there is nothing -which distinguishes the category from any other attributes. But for some -other uses, such as checking if it is a result or for display purposes, we -do treat this attribute differently. We take here the convention that the -category of a node is associated to the attribute ``cat''. -\begin{code} --- | Return the value of the "cat" attribute, if available -gCategory :: Flist -> Maybe GeniVal -gCategory top = - case [ v | AvPair "cat" v <- top ] of - [] -> Nothing - [c] -> Just c - _ -> geniBug $ "Impossible case: node with more than one category" -\end{code} - -A TAG node might also have a lexeme. If we are lucky, this is explicitly -set in the glexeme field of the node. Otherwise, we try to guess it from -a list of distinguished attributes (in order of preference). -\begin{code} --- | Attributes recognised as lexemes, in order of preference -lexemeAttributes :: [String] -lexemeAttributes = [ "lex", "phon", "cat" ] -\end{code} - -\paragraph{show (GNode)} the default show for GNode tries to -be very compact; it only shows the value for cat attribute -and any flags which are marked on that node. - -\begin{code} -instance Show GNode where - show gn = - let cat_ = case gCategory.gup $ gn of - Nothing -> [] - Just c -> show c - lex_ = showLexeme $ glexeme gn - -- - stub = concat $ intersperse ":" $ filter (not.null) [ cat_, lex_ ] - extra = case (gtype gn) of - Subs -> " !" - Foot -> " *" - _ -> if (gaconstr gn) then " #" else "" - in stub ++ extra - --- FIXME: will have to think of nicer way - one which involves --- unpacking the trees :-( -showLexeme :: [String] -> String -showLexeme [] = "" -showLexeme [l] = l -showLexeme xs = concat $ intersperse "|" xs -\end{code} - -A Replacement on a GNode consists of replacements on its top and bottom -feature structures - -\begin{code} -instance DescendGeniVal GNode where - descendGeniVal s gn = - gn { gup = descendGeniVal s (gup gn) - , gdown = descendGeniVal s (gdown gn) } -\end{code} - -% ---------------------------------------------------------------------- -\section{Tree manipulation} -% ---------------------------------------------------------------------- - -\begin{code} -root :: Tree a -> a -root (Node a _) = a - -rootUpd :: Tree a -> a -> Tree a -rootUpd (Node _ l) b = (Node b l) - -foot :: Tree GNode -> GNode -foot t = case filterTree (\n -> gtype n == Foot) t of - [x] -> x - _ -> geniBug $ "foot returned weird result" -\end{code} - -\begin{code} --- | Given a lexical item @s@ and a Tree GNode t, returns the tree t' --- where l has been assigned to the anchor node in t' -setAnchor :: [String] -> Tree GNode -> Tree GNode -setAnchor s t = - let filt (Node a []) = (gtype a == Lex && ganchor a) - filt _ = False - in case listRepNode (setLexeme s) filt [t] of - ([r],True) -> r - _ -> geniBug $ "setLexeme " ++ show s ++ " returned weird result" - --- | Given a lexical item @l@ and a tree node @n@ (actually a subtree --- with no children), return the same node with the lexical item as --- its unique child. The idea is that it converts terminal lexeme nodes --- into preterminal nodes where the actual terminal is the given lexical --- item -setLexeme :: [String] -> Tree GNode -> Tree GNode -setLexeme l (Node a []) = Node a [ Node subanc [] ] - where subanc = emptyGNode { gnname = '_' : ((gnname a) ++ ('.' : (concat l))) - , gaconstr = True - , glexeme = l} -setLexeme _ _ = geniBug "impossible case in setLexeme - subtree with kids" -\end{code} - -\subsection{Substitution and Adjunction} - -This module handles just the tree-cutting aspects of TAG substitution and -adjunction. We do substitution with a very general \fnreflite{plugTree} -function, whose only job is to plug two trees together at a specified node. -Note that this function is also used to implement adjunction. - -\begin{code} --- | Plug the first tree into the second tree at the specified node. --- Anything below the second node is silently discarded. --- We assume the trees are pluggable; it is treated as a bug if --- they are not! -plugTree :: Tree NodeName -> NodeName -> Tree NodeName -> Tree NodeName -plugTree male n female = - case listRepNode (const male) (nmatch n) [female] of - ([r], True) -> r - _ -> geniBug $ "unexpected plug failure at node " ++ n - --- | Given two trees 'auxt' and 't', splice the tree 'auxt' into --- 't' via the TAG adjunction rule. -spliceTree :: NodeName -- ^ foot node of the aux tree - -> Tree NodeName -- ^ aux tree - -> NodeName -- ^ place to adjoin in target tree - -> Tree NodeName -- ^ target tree - -> Tree NodeName -spliceTree f auxT n targetT = - case findSubTree n targetT of -- excise the subtree at n - Nothing -> geniBug $ "Unexpected adjunction failure. " ++ - "Could not find node " ++ n ++ " of target tree." - Just eT -> -- plug the excised bit into the aux - let auxPlus = plugTree eT f auxT - -- plug the augmented aux at n - in plugTree auxPlus n targetT - -nmatch :: NodeName -> Tree NodeName -> Bool -nmatch n (Node a _) = a == n - -findSubTree :: NodeName -> Tree NodeName -> Maybe (Tree NodeName) -findSubTree n n2@(Node x ks) - | x == n = Just n2 - | otherwise = case mapMaybe (findSubTree n) ks of - [] -> Nothing - (h:_) -> Just h -\end{code} - -% ---------------------------------------------------------------------- -\section{Features and variables} -% ---------------------------------------------------------------------- - -\begin{code} -type Flist = [AvPair] -data AvPair = AvPair { avAtt :: String - , avVal :: GeniVal } - deriving (Ord, Eq, Data, Typeable) - -instance Biplate AvPair GeniVal where - biplate (AvPair a v) = plate AvPair |- a |* v -\end{code} - -\subsection{Collectable} - -A Collectable is something which can return its variables as a set. -By variables, what I most had in mind was the GVar values in a -GeniVal. This notion is probably not very useful outside the context of -alpha-conversion task, but it seems general enough that I'll keep it -around for a good bit, until either some use for it creeps up, or I find -a more general notion that I can transform this into. - -\begin{code} -class Collectable a where - collect :: a -> Set.Set String -> Set.Set String - -instance Collectable a => Collectable (Maybe a) where - collect Nothing s = s - collect (Just x) s = collect x s - -instance (Collectable a => Collectable [a]) where - collect l s = foldr collect s l - -instance (Collectable a => Collectable (Tree a)) where - collect = collect.flatten - --- Pred is what I had in mind here -instance ((Collectable a, Collectable b, Collectable c) - => Collectable (a,b,c)) where - collect (a,b,c) = collect a . collect b . collect c - -instance Collectable GeniVal where - collect (GVar v) s = Set.insert v s - collect _ s = s - -instance Collectable AvPair where - collect (AvPair _ b) = collect b - -instance Collectable GNode where - collect n = (collect $ gdown n) . (collect $ gup n) -\end{code} - -\subsection{DescendGeniVal} -\label{sec:replacable} -\label{sec:replacements} - -The idea of replacing one variable value with another is something that -appears all over the place in GenI. So we try to smooth out its use by -making a type class out of it. - -\begin{code} - -\end{code} - -Substitution on list consists of performing substitution on -each item. Each item, is independent of the other, -of course. - -\begin{code} -instance DescendGeniVal a => DescendGeniVal (Map.Map k a) where - descendGeniVal s = {-# SCC "descendGeniVal" #-} Map.map (descendGeniVal s) - -instance DescendGeniVal AvPair where - descendGeniVal s (AvPair a v) = {-# SCC "descendGeniVal" #-} AvPair a (descendGeniVal s v) - -instance DescendGeniVal a => DescendGeniVal (String, a) where - descendGeniVal s (n,v) = {-# SCC "descendGeniVal" #-} (n,descendGeniVal s v) - -instance DescendGeniVal ([String], Flist) where - descendGeniVal s (a,v) = {-# SCC "descendGeniVal" #-} (a, descendGeniVal s v) -\end{code} - -\subsection{Idable} - -\begin{code} --- | An Idable is something that can be mapped to a unique id. --- You might consider using this to implement Ord, but I won't. --- Note that the only use I have for this so far (20 dec 2005) --- is in alpha-conversion. -class Idable a where - idOf :: a -> Integer -\end{code} - -\subsection{Other feature and variable stuff} - -Our approach to $\alpha$-conversion works by appending a unique suffix -to all variables in an object. See section \ref{sec:fs_unification} for -why we want this. - -\begin{code} -alphaConvertById :: (Collectable a, DescendGeniVal a, Idable a) => a -> a -alphaConvertById x = {-# SCC "alphaConvertById" #-} - alphaConvert ('-' : (show . idOf $ x)) x - -alphaConvert :: (Collectable a, DescendGeniVal a) => String -> a -> a -alphaConvert suffix x = {-# SCC "alphaConvert" #-} - let vars = Set.elems $ collect x Set.empty - convert v = GVar (v ++ suffix) - subst = Map.fromList $ map (\v -> (v, convert v)) vars - in replace subst x -\end{code} - -\begin{code} --- | Sort an Flist according with its attributes -sortFlist :: Flist -> Flist -sortFlist = sortBy (compare `on` avAtt) - -showFlist :: Flist -> String -showFlist f = "[" ++ showPairs f ++ "]" - -showPairs :: Flist -> String -showPairs = unwords . map showAv - -showAv :: AvPair -> String -showAv (AvPair y z) = y ++ ":" ++ show z - -instance Show AvPair where - show = showAv -\end{code} - -% ---------------------------------------------------------------------- -\section{Semantics} -\label{btypes_semantics} -% ---------------------------------------------------------------------- - -\begin{code} --- handle, predicate, parameters -type Pred = (GeniVal, GeniVal, [GeniVal]) -type Sem = [Pred] -type LitConstr = (Pred, [String]) -type SemInput = (Sem,Flist,[LitConstr]) - -instance Biplate Pred GeniVal where - biplate (g1, g2, g3) = plate (,,) |* g1 |* g2 ||* g3 - -instance Biplate (Maybe Sem) GeniVal where - biplate (Just s) = plate Just ||+ s - biplate Nothing = plate Nothing - -data TestCase = TestCase - { tcName :: String - , tcSemString :: String -- ^ for gui - , tcSem :: SemInput - , tcExpected :: [String] -- ^ expected results (for testing) - , tcOutputs :: [(String, Map.Map (String,String) [String])] - -- ^ results we actually got, and their traces (for testing) - } deriving Show - -emptyPred :: Pred -emptyPred = (GAnon,GAnon,[]) -\end{code} - -A replacement on a predicate is just a replacement on its parameters - -\begin{code} -instance DescendGeniVal Pred where - descendGeniVal s (h, n, lp) = (descendGeniVal s h, descendGeniVal s n, descendGeniVal s lp) -\end{code} - -\begin{code} -showSem :: Sem -> String -showSem l = - "[" ++ (unwords $ map showPred l) ++ "]" - -showPred :: Pred -> String -showPred (h, p, l) = showh ++ show p ++ "(" ++ unwords (map show l) ++ ")" - where - hideh (GConst [x]) = "genihandle" `isPrefixOf` x - hideh _ = False - -- - showh = if (hideh h) then "" else (show h) ++ ":" -\end{code} - -\begin{code} --- | Given a Semantics, return the string with the proper keys --- (propsymbol+arity) to access the agenda -toKeys :: Sem -> [String] -toKeys l = map (\(_,prop,par) -> show prop ++ (show $ length par)) l -\end{code} - -\subsection{Semantic subsumption} -\label{fn:subsumeSem} - -FIXME: comment fix - -Given tsem the input semantics, and lsem the semantics of a potential -lexical candidate, returns a list of possible ways that the lexical -semantics could subsume the input semantics. We return a pair with -the semantics that would result from unification\footnote{We need to -do this because there may be anonymous variables}, and the -substitutions that need to be propagated throughout the rest of the -lexical item later on. - -Note: we return more than one possible substitution because s could be -different subsets of ts. Consider, for example, \semexpr{love(j,m), - name(j,john), name(m,mary)} and the candidate \semexpr{name(X,Y)}. - -TODO WE ASSUME BOTH SEMANTICS ARE ORDERED and that the input semantics is -non-empty. - -\begin{code} -subsumeSem :: Sem -> Sem -> [(Sem,Subst)] -subsumeSem tsem lsem = - subsumeSemHelper ([],Map.empty) (reverse tsem) (reverse lsem) -\end{code} - -This is tricky because each substep returns multiple results. We solicit -the help of accumulators to keep things from getting confused. - -\begin{code} -subsumeSemHelper :: (Sem,Subst) -> Sem -> Sem -> [(Sem,Subst)] -subsumeSemHelper _ [] _ = - error "input semantics is non-empty in subsumeSemHelper" -subsumeSemHelper acc _ [] = [acc] -subsumeSemHelper acc tsem (hd:tl) = - let (accSem,accSub) = acc - -- does the literal hd subsume the input semantics? - pRes = subsumePred tsem hd - -- toPred reconstructs the literal hd with new parameters p. - -- The head of the list is taken to be the handle. - toPred p = (head p, snd3 hd, tail p) - -- next adds a result from predication subsumption to - -- the accumulators and goes to the next recursive step - next (p,s) = subsumeSemHelper acc2 tsem2 tl2 - where tl2 = replace s tl - tsem2 = replace s tsem - acc2 = (toPred p : accSem, mergeSubst accSub s) - in concatMap next pRes -\end{code} - -\fnlabel{subsumePred} -The first Sem s1 and second Sem s2 are the same when we start we circle on s2 -looking for a match for Pred, and meanwhile we apply the partical substitutions -to s1. Note: we treat the handle as if it were a parameter. - -\begin{code} -subsumePred :: Sem -> Pred -> [([GeniVal],Subst)] -subsumePred [] _ = [] -subsumePred ((h1, p1, la1):l) (pred2@(h2,p2,la2)) = - -- if we found the proper predicate - if ((p1 == p2) && (length la1 == length la2)) - then let mrs = unify (h1:la1) (h2:la2) - next = subsumePred l pred2 - in maybe next (:next) mrs - else if (p1 < p2) -- note that the semantics have to be reversed! - then [] - else subsumePred l pred2 -\end{code} - -\subsection{Other semantic stuff} - -\begin{code} --- | Sort semantics first according to its predicate, and then to its handles. -sortSem :: Sem -> Sem -sortSem = sortBy (\(h1,p1,a1) (h2,p2,a2) -> compare (p1, h1:a1) (p2, h2:a2)) -\end{code} - -% -------------------------------------------------------------------- -\subsection{Feature structure unification} -\label{sec:fs_unification} -% -------------------------------------------------------------------- - -Feature structure unification takes two feature lists as input. If it -fails, it returns Nothing. Otherwise, it returns a tuple with: - -\begin{enumerate} -\item a unified feature structure list -\item a list of variable replacements that will need to be propagated - across other feature structures with the same variables -\end{enumerate} - -Unification fails if, at any point during the unification process, the -two lists have different constant values for the same attribute. -For example, unification fails on the following inputs because they have -different values for the \textit{number} attribute: - -\begin{quotation} -\fs{\it cat:np\\ \it number:3\\} -\fs{\it cat:np\\ \it number:2\\} -\end{quotation} - -Note that the following input should also fail as a result on the -coreference on \textit{?X}. - -\begin{quotation} -\fs{\it cat:np\\ \it one: 1\\ \it two:2\\} -\fs{\it cat:np\\ \it one: ?X\\ \it two:?X\\} -\end{quotation} - -On the other hand, any other pair of feature lists should unify -succesfully, even those that do not share the same attributes. -Below are some examples of successful unifications: - -\begin{quotation} -\fs{\it cat:np\\ \it one: 1\\ \it two:2\\} -\fs{\it cat:np\\ \it one: ?X\\ \it two:?Y\\} -$\rightarrow$ -\fs{\it cat:np\\ \it one: 1\\ \it two:2\\}, -\end{quotation} - -\begin{quotation} -\fs{\it cat:np\\ \it number:3\\} -\fs{\it cat:np\\ \it case:nom\\} -$\rightarrow$ -\fs{\it cat:np\\ \it case:nom\\ \it number:3\\}, -\end{quotation} - -\begin{code} --- | 'unifyFeat' performs feature structure unification, under the --- these assumptions about the input: --- --- * Features are ordered --- --- * The Flists do not share variables (renaming has already --- been done. --- --- The features are allowed to have different sets of attributes, --- beacuse we use 'alignFeat' to realign them. -unifyFeat :: Monad m => Flist -> Flist -> m (Flist, Subst) -unifyFeat f1 f2 = - {-# SCC "unification" #-} - let (att, val1, val2) = unzip3 $ alignFeat f1 f2 - in att `seq` - do (res, subst) <- unify val1 val2 - return (zipWith AvPair att res, subst) - --- | 'alignFeat' is a pre-procesing step used to ensure that feature structures --- have the same set of keys. If a key is missing in one, we copy it to the --- other with an anonymous value. --- --- The two feature structures must be sorted for this to work -alignFeat :: Flist -> Flist -> [(String,GeniVal,GeniVal)] -alignFeat f1 f2 = alignFeatH f1 f2 [] - -alignFeatH :: Flist -> Flist -> [(String,GeniVal,GeniVal)] -> [(String,GeniVal,GeniVal)] -alignFeatH [] [] acc = reverse acc -alignFeatH [] (AvPair f v :x) acc = alignFeatH [] x ((f,GAnon,v) : acc) -alignFeatH x [] acc = alignFeatH [] x acc -alignFeatH fs1@(AvPair f1 v1:l1) fs2@(AvPair f2 v2:l2) acc = - case compare f1 f2 of - EQ -> alignFeatH l1 l2 ((f1, v1, v2) : acc) - LT -> alignFeatH l1 fs2 ((f1, v1, GAnon) : acc) - GT -> alignFeatH fs1 l2 ((f2, GAnon, v2) : acc) -\end{code} - - diff --git a/src/NLP/GenI/BtypesBinary.hs b/src/NLP/GenI/BtypesBinary.hs deleted file mode 100644 --- a/src/NLP/GenI/BtypesBinary.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} -module NLP.GenI.BtypesBinary where - -import Data.Binary -import NLP.GenI.Btypes - --- auto-generated by the Data.Binary BinaryDerive tool -instance Binary NLP.GenI.Btypes.Ptype where - put Initial = putWord8 0 - put Auxiliar = putWord8 1 - put Unspecified = putWord8 2 - get = do - tag_ <- getWord8 - case tag_ of - 0 -> return Initial - 1 -> return Auxiliar - 2 -> return Unspecified - _ -> fail "no parse" -instance Binary NLP.GenI.Btypes.GeniVal where - put (GConst a) = putWord8 0 >> put a - put (GVar a) = putWord8 1 >> put a - put GAnon = putWord8 2 - get = do - tag_ <- getWord8 - case tag_ of - 0 -> get >>= \a -> return (GConst a) - 1 -> get >>= \a -> return (GVar a) - 2 -> return GAnon - _ -> fail "no parse" -instance Binary NLP.GenI.Btypes.GNode where - put (GN a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h - get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (GN a b c d e f g h) - -instance Binary NLP.GenI.Btypes.GType where - put Subs = putWord8 0 - put Foot = putWord8 1 - put Lex = putWord8 2 - put Other = putWord8 3 - get = do - tag_ <- getWord8 - case tag_ of - 0 -> return Subs - 1 -> return Foot - 2 -> return Lex - 3 -> return Other - _ -> fail "no parse" -instance (Binary a) => Binary (NLP.GenI.Btypes.Ttree a) where - put (TT a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h - get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (TT a b c d e f g h) - - -instance Binary NLP.GenI.Btypes.AvPair where - put (AvPair a b) = put a >> put b - get = get >>= \a -> get >>= \b -> return (AvPair a b) - -instance Binary NLP.GenI.Btypes.ILexEntry where - put (ILE a b c d e f g h i) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h >> put i - get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> get >>= \i -> return (ILE a b c d e f g h i) - diff --git a/src/NLP/GenI/Builder.hs b/src/NLP/GenI/Builder.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Builder.hs @@ -0,0 +1,404 @@ +-- 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. + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{-| +The heavy lifting of GenI, the whole chart/agenda mechanism, can be +implemented in many ways. To make it easier to write different +algorithms for GenI and compare them, we provide a single interface +for what we call Builders. + +This interface is then used called by the Geni module and by the +graphical interface. Note that each builder has its own graphical +interface and that we do a similar thing in the graphical interface +code to make it possible to use these GUIs. +-} + +module NLP.GenI.Builder ( + TagDerivation, Builder(..), GenStatus(..), + lexicalSelection, FilterStatus(..),incrCounter, num_iterations, + (>-->), + num_comparisons, chart_size, + SemBitMap, defineSemanticBits, semToBitVector, bitVectorToSem, DispatchFilter, condFilter, + defaultStepAll, + BuilderState, UninflectedDisjunction(..), Input(..), unlessEmptySem, + initStats, Output, SentenceAut, run, queryCounter, defaultMetricNames, preInit +) +where + +import Control.Monad.State.Strict +import Data.Bits ( (.&.), (.|.), bit ) +import Data.List ( delete, sort, nub ) +import Data.Maybe ( mapMaybe, fromMaybe, maybeToList ) +import Data.Tree ( flatten ) +import Prelude hiding ( init ) +import Data.Text ( Text ) +import qualified Data.Map as Map +import qualified Data.Text as T + +import Control.DeepSeq + +import Data.Generics ( Data ) +import Data.Typeable ( Typeable ) + +import NLP.GenI.Automaton (NFA, automatonPaths, automatonPathSets, numStates, numTransitions) +import NLP.GenI.Configuration + ( getListFlagP, getFlagP, modifyFlagP, Params, + DetectPolaritiesFlg(..), + MetricsFlg(..), + RootFeatureFlg(..), + Optimisation(..), hasOpt, + ) +import NLP.GenI.FeatureStructure ( Flist, sortFlist, mkFeatStruct ) +import NLP.GenI.General ( BitVector, snd3, thd3, geniBug ) +import NLP.GenI.GeniVal ( GeniVal, DescendGeniVal(..), Collectable(collect), finaliseVarsById ) +import NLP.GenI.Lexicon ( LexEntry ) +import NLP.GenI.Morphology.Types +import NLP.GenI.Polarity (PolResult(..), buildAutomaton, detectPolPaths) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( SemInput, Sem, Literal ) +import NLP.GenI.Statistics (Statistics, incrIntMetric, + Metric(IntMetric), updateMetrics, + queryMetrics, queryIntMetric, + addMetric, emptyStats, + ) +import NLP.GenI.Tag + ( TagElem(idname,tsemantics,ttree), setTidnums + , TagDerivation, dsChild, dsParent + ) +import NLP.GenI.TreeSchema ( GNode(..), GType(Subs, Foot) ) + +data GenStatus = Finished + | Active + | Error Text + +data Builder st it pa = Builder + { init :: Input -> pa -> (st, Statistics) + -- ^ initialise the machine from the semantics and lexical selection + , step :: BuilderState st () -- ^ run a realisation step + , stepAll :: BuilderState st () -- ^ run all realisations steps until completion + -- + , finished :: st -> GenStatus -- ^ determine if realisation is finished + , unpack :: st -> [Output] -- ^ unpack chart results into a list of sentences + , partial :: st -> [Output] + } + +type Output = (Integer, LemmaPlusSentence, TagDerivation) + +-- | To simplify interaction with the backend, we provide a single data +-- structure which represents all the inputs a backend could take. + +data Input = + Input { inSemInput :: SemInput + , inLex :: [LexEntry] -- ^ for the debugger + , inCands :: [(TagElem, BitVector)] -- ^ tag tree + } + +-- Uninflected words and sentences + +-- | A SentenceAut represents a set of sentences in the form of an automaton. +-- The labels of the automaton are the words of the sentence. But note! +-- “word“ in the sentence is in fact a tuple (lemma, inflectional feature +-- structures). Normally, the states are defined as integers, with the +-- only requirement being that each one, naturally enough, is unique. +type SentenceAut = NFA Int LemmaPlus + +data UninflectedDisjunction = UninflectedDisjunction [Text] (Flist GeniVal) deriving (Data, Typeable) + +instance DescendGeniVal UninflectedDisjunction where + descendGeniVal s (UninflectedDisjunction a v) = {-# SCC "descendGeniVal" #-} UninflectedDisjunction a (descendGeniVal s v) + +instance Collectable UninflectedDisjunction where + collect (UninflectedDisjunction _ b) = collect b + +-- BuilderState + +-- To cleanly seperate the tracking of statistics from the core functionality of a +-- builder, we use a State transformer to thread a Statistics state monad inside of +-- our main monad. +type BuilderState s a = StateT s (State Statistics) a + +-- ---------------------------------------------------------------------- +-- Helper functions for Builders +-- ---------------------------------------------------------------------- + +-- Initialisation +-- +-- There's a few things that need to be run before even initialising the builder. +-- One of these is running some of the optimisations (namely the polarity stuff), +-- which is made complicated by the fact that they are optional. Another of these +-- to assign each of the trees with a unique ID. Note that this has to be done +-- after the polarity optimisation because this optimisation may introduce new +-- items into the lexical selection. Finally, we must also make sure we perform +-- alpha conversion so that unification does not do the wrong thing when two trees +-- have the same variables. + +preInit :: Input -> Params -> (Input, PolResult) +preInit input config = + let (cand,_) = unzip $ inCands input + seminput = inSemInput input + -- + extraPol = Map.empty + polsToDetect = fromMaybe (error "there should be a default for --detect-pols") + $ getFlagP DetectPolaritiesFlg config + rootFeat = mkFeatStruct $ getListFlagP RootFeatureFlg config + -- do any optimisations + isPol = hasOpt Polarised config + -- polarity optimisation (if enabled) + autstuff = buildAutomaton polsToDetect rootFeat extraPol seminput cand + autpaths = map concat . automatonPathSets . prFinal $ autstuff + combosPol = if isPol then autpaths else [considerHasSem cand] + considerHasSem = filter (not . null . tsemantics) + -- polarity automaton construction uses the zero literal semantic + -- items, but it may be safer to filter them out now if we are not + -- using it + -- chart sharing optimisation + (cands2, pathIds) = unzip $ detectPolPaths combosPol + -- + fixate ts ps = zip (map finaliseVarsById $ setTidnums ts) ps + input2 = input { inCands = fixate cands2 pathIds + , inSemInput = (prSem autstuff, snd3 seminput, thd3 seminput) } + -- note: autstuff is only useful for the graphical debugger + in (input2, autstuff) + +-- | Equivalent to 'id' unless the input contains an empty or uninstatiated +-- semantics +unlessEmptySem :: Input -> Params -> a -> a +unlessEmptySem input _ + | null semanticsErr = id + | otherwise = error semanticsErr + where + (cands,_) = unzip $ inCands input + nullSemCands = [ idname t | t <- cands, (null.tsemantics) t ] + unInstSemCands = [ idname t | t <- cands, not $ Map.null $ collect (tsemantics t) Map.empty ] + nullSemErr = + "The following trees have a null semantics: " ++ + T.unpack (T.unwords nullSemCands) + unInstSemErr = + "The following trees have an uninstantiated semantics: " ++ + T.unpack (T.unwords unInstSemCands) + semanticsErr = + (if null nullSemCands then "" else nullSemErr ++ "\n") ++ + (if null unInstSemCands then "" else unInstSemErr) + +-- ---------------------------------------------------------------------- +-- Running a surface realiser +-- ---------------------------------------------------------------------- + +-- | Performs surface realisation from an input semantics and a lexical selection. +-- +-- Statistics tracked +-- +-- * pol_used_bundles - number of bundled paths through the polarity automaton. +-- see 'NLP.GenI.Automaton.automatonPathSets' +-- +-- * pol_used_paths - number of paths through the final automaton +-- +-- * pol_seed_paths - number of paths through the seed automaton (i.e. with no polarities). +-- This is normally just 1, unless you have multi-literal semantics +-- +-- * pol_total_states - combined number of states in the all the polarity automata +-- +-- * pol_total_tras - combined number of transitions in all polarity automata +-- +-- * pol_max_states - number of states in the polarity automaton with the most states +-- +-- * pol_total_tras - number of transitions in the polarity automata with the most transitions +-- +-- * sem_literals - number of literals in the input semantics +-- +-- * lex_trees - total number of lexically selected trees + +-- * lex_foot_nodes - total number of nodes of any sort in lexically selected trees +-- +-- * lex_subst_nodes - total number of sustitution nodes in lexically selected trees +-- +-- * lex_foot_nodes - total number of foot nodes in lexically selected trees +-- +-- * plex_... - same as the lex_ equivalent, but after polarity filtering +run :: Builder st it Params -> Input -> Params -> (st, Statistics) +run builder input config_ = + let -- 0 normalise the config + config = modifyFlagP RootFeatureFlg sortFlist config_ + -- 1 run the setup stuff + (input2, autstuff) = preInit input config + auts = map snd3 (prIntermediate autstuff) + -- 2 call the init stuff + (iSt, iStats) = init builder input2 config + -- 2b extra statistics + autpaths = map concat . automatonPathSets . prFinal $ autstuff + countsFor ts = (length ts, length nodes, length sn, length an) + where nodes = concatMap (flatten.ttree) ts + sn = [ n | n <- nodes, gtype n == Subs ] + an = [ n | n <- nodes, gtype n == Foot ] + (tsem,_,_) = inSemInput input + cands = nub . map fst $ inCands input + cands2 = nub . concatMap concat . automatonPathSets . prFinal $ autstuff + countUp = do incrCounter "sem_literals" $ length tsem + -- + incrCounter "lex_subst_nodes" snl + incrCounter "lex_foot_nodes" anl + incrCounter "lex_nodes" nl + incrCounter "lex_trees" tl + -- node count after polarities are taken into account + incrCounter "plex_subst_nodes" snl2 + incrCounter "plex_foot_nodes" anl2 + incrCounter "plex_nodes" nl2 + incrCounter "plex_trees" tl2 + where (tl , nl , snl , anl ) = countsFor cands + (tl2, nl2, snl2, anl2) = countsFor cands2 + -- 3 step through the whole thing + stepAll_ = do countUp + incrCounter "pol_used_bundles" $ length autpaths + incrCounter "pol_used_paths" $ length . automatonPaths . prFinal $ autstuff + incrCounter "pol_seed_paths" $ length . automatonPaths . prInitial $ autstuff + incrCounter "pol_total_states" $ sum $ map numStates auts + incrCounter "pol_total_trans" $ sum $ map numTransitions auts + incrCounter "pol_max_states" $ maximum $ map numStates auts + incrCounter "pol_max_trans" $ maximum $ map numTransitions auts + stepAll builder + in runState (execStateT stepAll_ iSt) iStats + +-- ---------------------------------------------------------------------- +-- Semantics and bit vectors +-- ---------------------------------------------------------------------- + +type SemBitMap = Map.Map (Literal GeniVal) BitVector + +-- | assign a bit vector value to each literal in the semantics +-- the resulting map can then be used to construct a bit vector +-- representation of the semantics +defineSemanticBits :: Sem -> SemBitMap +defineSemanticBits sem = Map.fromList $ zip sem bits + where + bits = map bit [0..] -- 0001, 0010, 0100... + +semToBitVector :: SemBitMap -> Sem -> BitVector +semToBitVector bmap sem = foldr (.|.) 0 $ map doLookup sem + where doLookup p = + case Map.lookup p bmap of + Nothing -> geniBug $ "predicate " ++ prettyStr p ++ " not found in semanticBit map" + Just b -> b + +bitVectorToSem :: SemBitMap -> BitVector -> Sem +bitVectorToSem bmap vector = + mapMaybe tryKey $ Map.toList bmap + where tryKey (p,k) = if (k .&. vector == k) then Just p else Nothing + +-- ---------------------------------------------------------------------- +-- Generate step +-- ---------------------------------------------------------------------- + +-- | Default implementation for the 'stepAll' function in 'Builder' +defaultStepAll :: Builder st it pa -> BuilderState st () +defaultStepAll b = + do s <- get + case finished b s of + Active -> step b >> defaultStepAll b + _ -> return () + +-- | Dispatching consists of assigning a chart item to the right part of the +-- chart (agenda, trash, results list, etc). This is implemented as a +-- series of filters which can either fail or succeed. If a filter fails, +-- it may modify the item before passing it on to future filters. +type DispatchFilter s a = a -> s (FilterStatus a) + +data FilterStatus a = Filtered | NotFiltered a + +-- | Sequence two dispatch filters. +(>-->) :: (Monad s) => DispatchFilter s a -> DispatchFilter s a -> DispatchFilter s a +f >--> f2 = \x -> f x >>= next + where + next y@Filtered = return y + next (NotFiltered x2) = f2 x2 + +-- | If the item meets some condition, use the first filter, otherwise +-- use the second one. +condFilter :: (Monad s) => (a -> Bool) + -> DispatchFilter s a -> DispatchFilter s a + -> DispatchFilter s a +condFilter cond f1 f2 = \x -> if cond x then f1 x else f2 x + +-- ---------------------------------------------------------------------- +-- Statistics +-- ---------------------------------------------------------------------- + +modifyStats :: (Metric -> Metric) -> BuilderState st () +modifyStats fn = lift $ modify $ updateMetrics fn + +incrCounter :: String -> Int -> BuilderState st () +incrCounter key n = modifyStats (incrIntMetric key n) + +queryCounter :: String -> Statistics -> Maybe Int +queryCounter key s = + case queryMetrics (queryIntMetric key) s of + [] -> Nothing + [c] -> Just c + _ -> geniBug $ "More than one instance of the metric: " ++ key + +-- Command line configuration + +initStats :: Params -> Statistics +initStats pa = + let mdefault ms = if "default" `elem` ms then defaultMetricNames else [] + identifyMs :: [String] -> [Metric] + identifyMs ms = map namedMetric $ mdefault ms ++ delete "default" ms + metrics = identifyMs $ fromMaybe [] $ getFlagP MetricsFlg pa + in execState (mapM_ addMetric metrics) emptyStats + +namedMetric :: String -> Metric +-- the default case is that it's an int metric +namedMetric n = IntMetric n 0 + +-- Note that the strings here are command-line strings, not metric names! +defaultMetricNames :: [ String ] +defaultMetricNames = [ num_iterations, chart_size, num_comparisons, gen_time ] + +-- Common counters +-- +-- These numbers allow us to keep track of how efficient our generator is +-- and where we are in the process (how many steps we've taken, etc) + +num_iterations, chart_size, num_comparisons, gen_time :: String + +num_iterations = "iterations" +chart_size = "chart_size" +num_comparisons = "comparisons" +gen_time = "gen_time" + +-- ---------------------------------------------------------------------- +-- strictly API-ish bits +-- ---------------------------------------------------------------------- + +-- | The names of lexically selected chart items used in a derivation +lexicalSelection :: TagDerivation -> [Text] +lexicalSelection = sort . nub + . concatMap (\d -> dsChild d : maybeToList (dsParent d)) + +{-! +deriving instance NFData Input +!-} + +-- GENERATED START + + +instance NFData Input where + rnf (Input x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + +-- GENERATED STOP diff --git a/src/NLP/GenI/Builder.lhs b/src/NLP/GenI/Builder.lhs deleted file mode 100644 --- a/src/NLP/GenI/Builder.lhs +++ /dev/null @@ -1,562 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Builder} -\label{cha:Builder} - -The heavy lifting of GenI, the whole chart/agenda mechanism, can be -implemented in many ways. To make it easier to write different -algorithms for GenI and compare them, we provide a single interface -for what we call Builders. - -This interface is then used called by the Geni module and by the -graphical interface. Note that each builder has its own graphical -interface and that we do a similar thing in the graphical interface -code to make it possible to use these GUIs. Maybe a little dose of -UML might help. See figure \ref{fig:builderUml}. - -\begin{figure} -\begin{center} -\includegraphics[scale=0.5]{images/builderUml.pdf} -\label{fig:builderUml} -\caption{Essentially what the Builder interface provides} -\end{center} -\end{figure} - -\ignore{ -\begin{code} -module NLP.GenI.Builder -where - -import Control.Applicative ( (<$>), (<*>) ) -import Control.Monad.State.Strict -import Data.Bits ( (.&.), (.|.), bit, xor ) -import Data.List ( (\\), maximum, delete, sort, nub ) -import qualified Data.Map as Map -import Data.Maybe ( mapMaybe, fromMaybe ) -import qualified Data.Set as Set -import Data.Tree ( flatten ) -import Prelude hiding ( init ) -import Text.JSON - -import Data.Generics.PlateDirect -import Data.Generics ( Data ) -import Data.Typeable ( Typeable ) - -import NLP.GenI.Automaton (NFA, automatonPaths, automatonPathSets, numStates, numTransitions) -import NLP.GenI.Configuration - ( getListFlagP, getFlagP, Params, - DetectPolaritiesFlg(..), - ExtraPolaritiesFlg(..), MetricsFlg(..), - RootFeatureFlg(..), - Optimisation(..), hasOpt, - ) -import NLP.GenI.General (geniBug, BitVector, multiGroupByFM, fst3, snd3, thd3) -import NLP.GenI.Btypes - ( ILexEntry, SemInput, Sem, Pred, showPred, showSem, - AvPair(..), Flist, showFlist, gtype, GType(Subs, Foot), - DescendGeniVal(..), Collectable(collect), alphaConvertById, - GeniVal(GConst) - ) -import NLP.GenI.GeniParsers ( geniFeats, runParser, CharParser ) -import NLP.GenI.Polarity (PolResult, buildAutomaton, detectPolPaths) -import NLP.GenI.Statistics (Statistics, incrIntMetric, - Metric(IntMetric), updateMetrics, - queryMetrics, queryIntMetric, - addMetric, emptyStats, - ) -import NLP.GenI.Tags ( TagElem(idname,tsemantics,ttree), setTidnums, TagDerivation, DerivationStep(..) ) -\end{code} -} - -\section{The interface} - -All backends provide the same essential functionality: -\begin{description} -\item [run] calls init and stepAll and potentially wraps it with some - other functionality. -\item [init] initialise the machine from the semantics and lexical selection -\item [step] run a realisation step -\item [stepAll] run all realisations steps until completion -\item [finished] determine if realisation is finished -\item [stats] extract various statistics from it -\item [setStats] set the statistical information -\item [unpack] unpack chart results into a list of sentences -\end{description} - -FIXME: need to update this comment - -\begin{code} -data Builder st it pa = Builder - { init :: Input -> pa -> (st, Statistics) - -- - , step :: BuilderState st () - , stepAll :: BuilderState st () - -- - , finished :: st -> Bool - , unpack :: st -> [Output] - , partial :: st -> [Output] } - -type Output = (LemmaPlusSentence, Derivation) -type Derivation = TagDerivation -\end{code} - -To simplify interaction with the backend, we provide a single data -structure which represents all the inputs a backend could take. - -\begin{code} -data Input = - Input { inSemInput :: SemInput - , inLex :: [ILexEntry] -- ^ for the debugger - , inCands :: [(TagElem, BitVector)] -- ^ tag tree - } -\end{code} - -\section{Uninflected words and sentences} - -Each word of an uninflected sentence consists of a lemma and some -feature structures. - -\paragraph -A SentenceAut represents a set of sentences in the form of an automaton. -The labels of the automaton are the words of the sentence. But note! -``word'' in the sentence is in fact a tuple (lemma, inflectional feature -structures). Normally, the states are defined as integers, with the -only requirement being that each one, naturally enough, is unique. - -\begin{code} -type SentenceAut = NFA Int LemmaPlus - -data UninflectedDisjunction = UninflectedDisjunction [String] Flist deriving (Show, Data, Typeable) - -instance Biplate UninflectedDisjunction GeniVal where - biplate (UninflectedDisjunction a v) = plate UninflectedDisjunction |- a ||+ v - -instance DescendGeniVal UninflectedDisjunction where - descendGeniVal s (UninflectedDisjunction a v) = {-# SCC "descendGeniVal" #-} UninflectedDisjunction a (descendGeniVal s v) - -instance Collectable UninflectedDisjunction where - collect (UninflectedDisjunction _ b) = collect b -\end{code} - -\section{BuilderState} - -To cleanly seperate the tracking of statistics from the core functionality of a -builder, we use a State transformer to thread a Statistics state monad inside of -our main monad. - -\begin{code} -type BuilderState s a = StateT s (State Statistics) a -\end{code} - -\section{Helper functions for Builders} - -\subsection{Initialisation} -\label{fn:Builder:preInit} - -There's a few things that need to be run before even initialising the builder. -One of these is running some of the optimisations (namely the polarity stuff), -which is made complicated by the fact that they are optional. Another of these -to assign each of the trees with a unique ID. Note that this has to be done -after the polarity optimisation because this optimisation may introduce new -items into the lexical selection. Finally, we must also make sure we perform -alpha conversion so that unification does not do the wrong thing when two trees -have the same variables. - -\begin{code} -preInit :: Input -> Params -> (Input, (Int,Int,Int), PolResult) -preInit input config = - let (cand,_) = unzip $ inCands input - seminput = inSemInput input - -- - extraPol = fromMaybe (Map.empty) $ getFlagP ExtraPolaritiesFlg config - polsToDetect = fromMaybe (error "there should be a default for --detect-pols") - $ getFlagP DetectPolaritiesFlg config - rootFeat = getListFlagP RootFeatureFlg config - -- do any optimisations - isPol = hasOpt Polarised config - -- polarity optimisation (if enabled) - autstuff = buildAutomaton polsToDetect rootFeat extraPol seminput cand - (_, seedAut, aut, sem2) = autstuff - autpaths = map concat $ automatonPathSets aut - combosPol = if isPol then autpaths else [cand] - -- chart sharing optimisation - (cands2, pathIds) = unzip $ detectPolPaths combosPol - -- the number of paths explored vs possible - polcount = (length autpaths, length $ automatonPaths aut, length $ automatonPaths seedAut) - -- - fixate ts ps = zip (map alphaConvertById $ setTidnums ts) ps - input2 = input { inCands = fixate cands2 pathIds - , inSemInput = (sem2, snd3 seminput, thd3 seminput) } - -- note: autstuff is only useful for the graphical debugger - in (input2, polcount, autstuff) -\end{code} - -\begin{code} --- | Equivalent to 'id' unless the input contains an empty or uninstatiated --- semantics -unlessEmptySem :: Input -> Params -> a -> a -unlessEmptySem input _ = - let (cands,_) = unzip $ inCands input - nullSemCands = [ idname t | t <- cands, (null.tsemantics) t ] - unInstSemCands = [ idname t | t <- cands, not $ Set.null $ collect (tsemantics t) Set.empty ] - nullSemErr = "The following trees have a null semantics: " ++ (unwords nullSemCands) - unInstSemErr = "The following trees have an uninstantiated semantics: " ++ (unwords unInstSemCands) - semanticsErr = (if null nullSemCands then "" else nullSemErr ++ "\n") ++ - (if null unInstSemCands then "" else unInstSemErr) - in if null semanticsErr - then id - else error semanticsErr -\end{code} - -\subsection{Running a surface realiser} - -\begin{code} --- | Performs surface realisation from an input semantics and a lexical selection. --- --- Statistics tracked --- --- * pol_used_bundles - number of bundled paths through the polarity automaton. --- see 'NLP.GenI.Automaton.automatonPathSets' --- --- * pol_used_paths - number of paths through the final automaton --- --- * pol_seed_paths - number of paths through the seed automaton (i.e. with no polarities). --- This is normally just 1, unless you have multi-literal semantics --- --- * pol_total_states - combined number of states in the all the polarity automata --- --- * pol_total_tras - combined number of transitions in all polarity automata --- --- * pol_max_states - number of states in the polarity automaton with the most states --- --- * pol_total_tras - number of transitions in the polarity automata with the most transitions -run :: Builder st it Params -> Input -> Params -> (st, Statistics) -run builder input config = - let -- 1 run the setup stuff - (input2, polcount, autstuff) = preInit input config - auts = (\(x,_,_,_) -> map snd3 x) autstuff - -- 2 call the init stuff - (iSt, iStats) = init builder input2 config - -- 3 step through the whole thing - stepAll_ = do incrCounter "pol_used_bundles" $ fst3 polcount - incrCounter "pol_used_paths" $ snd3 polcount - incrCounter "pol_seed_paths" $ thd3 polcount - incrCounter "pol_total_states" $ sum $ map numStates auts - incrCounter "pol_total_trans" $ sum $ map numTransitions auts - incrCounter "pol_max_states" $ maximum $ map numStates auts - incrCounter "pol_max_trans" $ maximum $ map numTransitions auts - stepAll builder - in runState (execStateT stepAll_ iSt) iStats -\end{code} - -\subsection{Semantics and bit vectors} - -\begin{code} -type SemBitMap = Map.Map Pred BitVector - --- | assign a bit vector value to each literal in the semantics --- the resulting map can then be used to construct a bit vector --- representation of the semantics -defineSemanticBits :: Sem -> SemBitMap -defineSemanticBits sem = Map.fromList $ zip sem bits - where - bits = map bit [0..] -- 0001, 0010, 0100... - -semToBitVector :: SemBitMap -> Sem -> BitVector -semToBitVector bmap sem = foldr (.|.) 0 $ map doLookup sem - where doLookup p = - case Map.lookup p bmap of - Nothing -> geniBug $ "predicate " ++ showPred p ++ " not found in semanticBit map" - Just b -> b - -bitVectorToSem :: SemBitMap -> BitVector -> Sem -bitVectorToSem bmap vector = - mapMaybe tryKey $ Map.toList bmap - where tryKey (p,k) = if (k .&. vector == k) then Just p else Nothing -\end{code} - -\subsection{Index accesibility filtering} -\label{sec:iaf} - -Index accesibility filtering was described in \cite{carroll05her}. This -is my attempt to adapt it to TAG. This filter works as a form of delayed -substitution, basically the exact opposite of delayed adjunction. - -This might be wrong, but we say that an index is originally accesible if -it is the root node's idx attribute (no atomic disjunction; atomic -disjunction is as good as a variable as far I'm concerned) - -FIXME: more about this later. -FIXME: are we sure we got the atomic disjunctions right? - -\begin{code} -type IafMap = Map.Map String Sem - --- | Return the literals of the semantics (in bit vector form) --- whose accesibility depends on the given index -dependentSem :: IafMap -> String -> Sem -dependentSem iafMap x = Map.findWithDefault [] x iafMap - --- | Return the handle and arguments of a literal -literalArgs :: Pred -> [GeniVal] -literalArgs (h,_,args) = h:args - -semToIafMap :: Sem -> IafMap -semToIafMap sem = - multiGroupByFM (concatMap fromUniConst . literalArgs) sem - --- | Like 'fromGConst' but only for the non-disjoint ones: meant to be used as Maybe or List -fromUniConst :: (Monad m) => GeniVal -> m String -fromUniConst (GConst [x]) = return x -fromUniConst _ = fail "not a unique constant" -- we don't actually expect this failure msg to be used - -getIdx :: Flist -> [GeniVal] -getIdx fs = [ v | AvPair "idx" v <- fs ] - -ts_iafFailure :: [String] -> [Pred] -> String -ts_iafFailure is sem = "index accesibility failure -" ++ (unwords is) ++ "- blocked: " ++ showSem sem - --- | Calculate the new set of accessibility/inaccesible indices, returning a --- a tuple of accesible / inaccesible indices -recalculateAccesibility :: (IafAble a) => a -> a -recalculateAccesibility i = - let oldAcc = iafAcc i - newAcc = iafNewAcc i - oldInacc = iafInacc i - newInacc = oldInacc ++ (oldAcc \\ newAcc) - in iafSetInacc newInacc $ iafSetAcc newAcc i - --- | Return, in bitvector form, the portion of a semantics that is inaccesible --- from an item -iafBadSem :: (IafAble a) => IafMap -> SemBitMap - -> BitVector -- ^ the input semantics - -> (a -> BitVector) -- ^ the semantics of the item - -> a -> BitVector -iafBadSem iafMap bmap sem semfn i = - let -- the semantics we can't reach - inaccessible = foldr (.|.) 0 $ map (semToBitVector bmap . dependentSem iafMap) $ iafInacc i - -- the semantics we still _need_ to be able to reach - remaining = sem `xor` (semfn i) - -- where we're in trouble - in inaccessible .&. remaining - -class IafAble a where - iafAcc :: a -> [String] - iafInacc :: a -> [String] - iafSetAcc :: [String] -> a -> a - iafSetInacc :: [String] -> a -> a - iafNewAcc :: a -> [String] -\end{code} - -\subsection{Generate step} - -\begin{code} --- | Default implementation for the 'stepAll' function in 'Builder' -defaultStepAll :: Builder st it pa -> BuilderState st () -defaultStepAll b = - do s <- get - unless (finished b s) $ - do step b - defaultStepAll b -\end{code} - -\subsection{Dispatching new chart items} -\label{sec:dispatching} - -Dispatching consists of assigning a chart item to the right part of the -chart (agenda, trash, results list, etc). This is implemented as a -series of filters which can either fail or succeed. - -Counter-intuitively, success is defined as returning \verb!Nothing!. -Failure is defined as return \verb!Just!, because if a filter fails, it -has the right to modify the item for the next filter. For example, the -top and bottom unification filter succeeds if it \emph{cannot} unify -the top and bottom features of a node. It suceeds by putting the item -into the trash and returning Nothing. If it \emph{can} perform top and -bottom unification, we want to return the item where the top and bottom -nodes are unified. Failure is success, war is peace, freedom is -slavery, erase is backspace. - -\begin{code} -type DispatchFilter s a = a -> s (Maybe a) - --- | Sequence two dispatch filters. -(>-->) :: (Monad s) => DispatchFilter s a -> DispatchFilter s a -> DispatchFilter s a -f >--> f2 = \x -> f x >>= maybe (return Nothing) f2 - --- | A filter that always fails (i.e. no filtering) -nullFilter :: (Monad s) => DispatchFilter s a -nullFilter = return.Just - --- | If the item meets some condition, use the first filter, otherwise --- use the second one. -condFilter :: (Monad s) => (a -> Bool) - -> DispatchFilter s a -> DispatchFilter s a - -> DispatchFilter s a -condFilter cond f1 f2 = \x -> if cond x then f1 x else f2 x -\end{code} - -\subsection{Statistics} - -\begin{code} -modifyStats :: (Metric -> Metric) -> BuilderState st () -modifyStats fn = lift $ modify $ updateMetrics fn - -incrCounter :: String -> Int -> BuilderState st () -incrCounter key n = modifyStats (incrIntMetric key n) - -queryCounter :: String -> Statistics -> Maybe Int -queryCounter key s = - case queryMetrics (queryIntMetric key) s of - [] -> Nothing - [c] -> Just c - _ -> geniBug $ "More than one instance of the metric: " ++ key -\end{code} - -\subsection{Command line configuration} - -\begin{code} -initStats :: Params -> Statistics -initStats pa = - let mdefault ms = if "default" `elem` ms then defaultMetricNames else [] - identifyMs :: [String] -> [Metric] - identifyMs ms = map namedMetric $ mdefault ms ++ delete "default" ms - metrics = identifyMs $ fromMaybe [] $ getFlagP MetricsFlg pa - in execState (mapM addMetric metrics) emptyStats - -namedMetric :: String -> Metric --- the default case is that it's an int metric -namedMetric n = IntMetric n 0 - --- Note that the strings here are command-line strings, not metric names! -defaultMetricNames :: [ String ] -defaultMetricNames = [ num_iterations, chart_size, num_comparisons ] -\end{code} - -\subsection{Common counters} - -These numbers allow us to keep track of how efficient our generator is -and where we are in the process (how many steps we've taken, etc) - -\begin{code} -num_iterations, chart_size, num_comparisons :: String - -num_iterations = "iterations" -chart_size = "chart_size" -num_comparisons = "comparisons" -\end{code} - -\section{The null builder} - -For the purposes of tracking certain statistics without interfering with the -lazy evaluation of the real builders. For example, one we would like to be -able to do is count the number of substitution and foot nodes in the lexical -selection. Doing so would in a real builder might cause it to walk entire -trees for ptoentially no good reason. - -\begin{code} -nullBuilder :: Builder () (NullState ()) Params -nullBuilder = Builder - { NLP.GenI.Builder.init = initNullBuilder - , step = return () - , stepAll = return () - , finished = const True - , unpack = return [] - , partial = return [] - } - -type NullState a = BuilderState () a - --- | Running the null builder allows you to track certain statistics --- --- * sem_literals - number of literals in the input semantics --- --- * lex_trees - total number of lexically selected trees - --- * lex_foot_nodes - total number of nodes of any sort in lexically selected trees --- --- * lex_subst_nodes - total number of sustitution nodes in lexically selected trees --- --- * lex_foot_nodes - total number of foot nodes in lexically selected trees --- --- * plex_... - same as the lex_ equivalent, but after polarity filtering -initNullBuilder :: Input -> Params -> ((), Statistics) -initNullBuilder input config = - let countsFor ts = (length ts, length nodes, length sn, length an) - where nodes = concatMap (flatten.ttree) ts - sn = [ n | n <- nodes, gtype n == Subs ] - an = [ n | n <- nodes, gtype n == Foot ] - -- - (tsem,_,_) = inSemInput input - cands = map fst $ inCands input - (_,_,(_,_,aut,_)) = preInit input config - cands2 = concatMap concat $ automatonPathSets aut - -- - countUp = do incrCounter "sem_literals" $ length tsem - -- - incrCounter "lex_subst_nodes" snl - incrCounter "lex_foot_nodes" anl - incrCounter "lex_nodes" nl - incrCounter "lex_trees" tl - -- node count after polarities are taken into account - incrCounter "plex_subst_nodes" snl2 - incrCounter "plex_foot_nodes" anl2 - incrCounter "plex_nodes" nl2 - incrCounter "plex_trees" tl2 - where (tl , nl , snl , anl ) = countsFor cands - (tl2, nl2, snl2, anl2) = countsFor cands2 - in runState (execStateT countUp ()) (initStats config) -\end{code} - -% ---------------------------------------------------------------------- -% strictly API-ish bits -% ---------------------------------------------------------------------- - -\ignore{ -\begin{code} --- | The names of lexically selected chart items used in a derivation -lexicalSelection :: Derivation -> [String] -lexicalSelection = sort . nub . concatMap (\d -> [dsChild d, dsParent d]) - --- | A lemma plus its morphological features -data LemmaPlus = LemmaPlus { lpLemma :: String - , lpFeats :: Flist } - deriving (Show, Eq, Ord) - --- | A sentence composed of 'LemmaPlus' instead of plain old words -type LemmaPlusSentence = [LemmaPlus] - -instance JSON LemmaPlus where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - let field x = maybe (fail $ "Could not find: " ++ x) readJSON - $ lookup x jo - LemmaPlus <$> field "lemma" - <*> (parsecToJSON "lemma-features" geniFeats =<< field "lemma-features") - showJSON (LemmaPlus l fs) = - JSObject . toJSObject $ [ ("lemma", showJSON l) - , ("lemma-features", showJSON $ showFlist fs) - ] - -parsecToJSON :: Monad m => String -> CharParser () b -> String -> m b -parsecToJSON description p str = - case runParser p () "" str of - Left err -> fail $ "Couldn't parse " ++ description ++ " because " ++ show err - Right res -> return res -\end{code} -} diff --git a/src/NLP/GenI/BuilderGui.lhs b/src/NLP/GenI/BuilderGui.lhs deleted file mode 100644 --- a/src/NLP/GenI/BuilderGui.lhs +++ /dev/null @@ -1,34 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\begin{code} -module NLP.GenI.BuilderGui -where - -import Graphics.UI.WX - -import qualified NLP.GenI.Builder as B -import NLP.GenI.Geni (ProgStateRef, GeniResult) -import NLP.GenI.Configuration (Params) -import NLP.GenI.Statistics (Statistics) -\end{code} - -\begin{code} -data BuilderGui = BuilderGui - { resultsPnl :: forall a . ProgStateRef -> (Window a) -> IO ([GeniResult],Statistics,Layout) - , debuggerPnl :: forall a . (Window a) -> Params -> B.Input -> String -> IO Layout } -\end{code} diff --git a/src/NLP/GenI/Configuration.hs b/src/NLP/GenI/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Configuration.hs @@ -0,0 +1,735 @@ +-- 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings, ViewPatterns #-} +module NLP.GenI.Configuration + ( Params(..) + -- + , mainBuilderTypes + , getFlagP, getListFlagP, modifyFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt + , emptyParams, defineParams + , treatArgs, treatArgsWithParams, usage, basicSections, optionsSections + , processInstructions + , optionsForStandardGenI + , optionsForBasicStuff, optionsForOptimisation, optionsForMorphology, optionsForInputFiles + , optionsForBuilder, optionsForTesting + , helpOption, verboseOption, macrosOption, lexiconOption + , nubBySwitches + , noArg, reqArg, optArg + , parseFlagWithParsec + -- * configration files + , readGlobalConfig, setLoggers + -- re-exports + , module System.Console.GetOpt + , module NLP.GenI.Flag + , Typeable + ) +where + +import Control.Applicative ( (<$>), pure ) +import Control.Arrow ( first ) +import Control.Monad ( liftM ) +import Data.Char ( toLower, isSpace ) +import Data.List ( find, intersperse, nubBy ) +import Data.Maybe ( fromMaybe, isNothing, fromJust ) +import Data.Maybe ( listToMaybe, mapMaybe ) +import Data.String ( IsString(..) ) +import Data.Text ( Text ) +import Data.Typeable ( Typeable ) +import System.Directory ( getAppUserDataDirectory, doesFileExist ) +import System.Environment ( getProgName ) +import System.FilePath +import System.IO ( stderr ) +import Text.ParserCombinators.Parsec ( runParser, CharParser ) +import qualified Data.ByteString.Char8 as BC +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Data.Yaml.YamlLight +import System.Console.GetOpt +import System.Log.Formatter +import System.Log.Handler ( LogHandler, setFormatter ) +import System.Log.Handler.Simple +import System.Log.Logger + +import NLP.GenI.Flag +import NLP.GenI.General ( geniBug, fst3, snd3 ) +import NLP.GenI.Parser ( geniFeats, tillEof ) +import NLP.GenI.Morphology.Types ( MorphRealiser ) +import NLP.GenI.Pretty +import NLP.GenI.Polarity.Types ( readPolarityAttrs ) +import NLP.GenI.LexicalSelection ( LexicalSelector ) + +-- -------------------------------------------------------------------- +-- Params +-- -------------------------------------------------------------------- + +-- | Holds the specification for how Geni should be run, its input +-- files, etc. This is the stuff that would normally be found in +-- the configuration file. +data Params = Params + { grammarType :: GrammarType + , builderType :: BuilderType + -- | Can still be overridden with a morph command mind you + , customMorph :: Maybe MorphRealiser + -- | Lexical selection function + -- (if you set this you may want to add 'PreAnchored' to the config) + , customSelector :: Maybe LexicalSelector + , geniFlags :: [Flag] + } + +{- +instance Show Params where + show p = unlines + [ unwords [ "GenI config :", show (grammarType p), show (builderType p), morph ] + , unwords $ "GenI flags :" : map show (geniFlags p) + ] + where + morph = "custom morph:" ++ show (isJust (customMorph p)) +-} + +-- | The default parameters configuration +emptyParams :: Params +emptyParams = Params + { builderType = SimpleBuilder + , grammarType = GeniHand + , customMorph = Nothing + , customSelector = Nothing + , geniFlags = emptyFlags + } + +hasOpt :: Optimisation -> Params -> Bool +hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p + +hasFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool +hasFlagP f = hasFlag f . geniFlags + +deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params +deleteFlagP f p = p { geniFlags = deleteFlag f (geniFlags p) } + +modifyFlagP :: (Eq f, Typeable f, Typeable x) + => (x -> f) -> (x -> x) -> Params -> Params +modifyFlagP f m p = p { geniFlags = modifyFlag f m (geniFlags p) } + +setFlagP :: (Eq f, Typeable f, Typeable x) + => (x -> f) -> x -> Params -> Params +setFlagP f v p = p { geniFlags = setFlag f v (geniFlags p) } + +getFlagP :: (Typeable f, Typeable x) + => (x -> f) -> Params -> Maybe x +getFlagP f = getFlag f . geniFlags + +getListFlagP :: (Typeable f, Typeable x) + => ([x] -> f) -> Params -> [x] +getListFlagP f = fromMaybe [] . getFlagP f + +emptyFlags :: [Flag] +emptyFlags = + [ Flag ViewCmdFlg "ViewTAG" + , Flag DetectPolaritiesFlg $ + readPolarityAttrs defaultPolarityAttrs + , Flag RootFeatureFlg $ + parseFlagWithParsec "default root feat" geniFeats defaultRootFeat + ] + +-- -------------------------------------------------------------------- +-- Command line arguments +-- -------------------------------------------------------------------- + +type OptSection = (String,[OptDescr Flag],[String]) + +-- | Uses the GetOpt library to process the command line arguments. +-- Note that we divide them into basic and advanced usage. +optionsForStandardGenI :: [OptDescr Flag] +optionsForStandardGenI = + nubBySwitches $ concatMap snd3 optionsSections + ++ [ Option ['p'] [] (reqArg WeirdFlg id "CMD") "" ] + -- TODO: what is this -p flag for, exactly? It's something + -- related to how GenI runs within an app bundle. Can we + -- do away with it? + +basicSections :: [OptSection] +basicSections = + map tweakBasic $ take 1 optionsSections + where + tweakBasic (x,y,z) = (x,y,z ++ ["See --help for more options"]) + +optionsSections :: [OptSection] +optionsSections = + [ ("Core options", optionsForBasicStuff, example) + , ("Input", optionsForInputFiles, []) + , ("Output", optionsForOutput, []) + , ("Algorithm", + (nubBySwitches $ optionsForBuilder ++ optionsForOptimisation), + usageForOptimisations) + , ("Morphology", optionsForMorphology, []) + , ("User interface", optionsForUserInterface, []) + , ("Batch processing", optionsForTesting, []) + ] + where + example = + [ "Example:" + , " geni -m examples/ej/mac -l examples/ej/lexicon -s examples/ej/suite" + ] + +getSwitches :: OptDescr a -> ([Char],[String]) +getSwitches (Option s l _ _) = (s,l) + +nubBySwitches :: [OptDescr a] -> [OptDescr a] +nubBySwitches = nubBy (\x y -> getSwitches x == getSwitches y) + +-- GetOpt wrappers +noArg :: forall f . (Eq f, Typeable f) + => (() -> f) -> ArgDescr Flag +noArg s = NoArg (Flag s ()) + +reqArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x) + => (x -> f) -- ^ flag + -> (String -> x) -- ^ string reader for flag (probably |id| if already a String) + -> String -- ^ description + -> ArgDescr Flag +reqArg s fn desc = ReqArg (\x -> Flag s (fn x)) desc + +optArg :: forall f x . (Eq f, Typeable f, Eq x, Typeable x) + => (x -> f) -- ^ flag + -> x -- ^ default value + -> (String -> x) -- ^ string reader (as in @reqArg@) + -> String -- ^ description + -> ArgDescr Flag +optArg s def fn desc = OptArg (\x -> Flag s (maybe def fn x)) desc + +-- ------------------------------------------------------------------- +-- Parsing command line arguments +-- ------------------------------------------------------------------- + +-- | Print out a GenI-style usage message with options divided into sections +usage :: [OptSection] -- ^ options + -> String -- ^ prog name + -> String +usage sections pname = + let header = "Usage: " ++ pname ++ " [OPTION...]\n" + body = unlines $ map usageSection sections + in header ++ body + +usageSection :: (String, [OptDescr Flag],[String]) -> String +usageSection (name, opts, comments) = + usageInfo (unlines $ [bar,name, bar]) opts ++ mcomments + where + bar = replicate 72 '=' + mcomments = if null comments then [] else "\n" ++ unlines comments + +treatArgs :: [OptDescr Flag] -> [String] -> IO Params +treatArgs options argv = treatArgsWithParams options argv emptyParams + +treatArgsWithParams :: [OptDescr Flag] -> [String] -> Params -> IO Params +treatArgsWithParams options argv initParams = + case getOpt Permute options argv of + (os,_,[] )-> return $ defineParams os initParams + (_,_,errs) -> do p <- getProgName + ioError (userError $ concat errs ++ usage basicSections p) + +defineParams :: [Flag] -> Params -> Params +defineParams flgs prms = + (\p -> foldr setDefault p $ geniFlags prms) + . (mergeFlagsP OptimisationsFlg) + . (mergeFlagsP MetricsFlg) + $ prms + { geniFlags = flgs + , builderType = fromFlags builderType BuilderFlg flgs + , grammarType = fromFlags grammarType GrammarTypeFlg flgs + } + where + setDefault (Flag f v) p = + if hasFlagP f p then p else setFlagP f v p + mergeFlagsP f p = + if hasFlagP f p + then setFlagP f (concat $ getAllFlags f flgs) p + else p + fromFlags default_ t fs = + fromMaybe (default_ prms) (getFlag t fs) + +-- -------------------------------------------------------------------- +-- Basic options +-- -------------------------------------------------------------------- + +optionsForBasicStuff :: [OptDescr Flag] +optionsForBasicStuff = + [ helpOption, verboseOption, noguiOption + , macrosOption , lexiconOption, testSuiteOption + , rootFeatureOption + , outputOption + ] + +-- -------------------------------------------------------------------- +-- Input files +-- -------------------------------------------------------------------- + +optionsForInputFiles :: [OptDescr Flag] +optionsForInputFiles = + [ macrosOption + , lexiconOption + , tracesOption + , testSuiteOption + , fromStdinOption + , morphInfoOption + , instructionsOption + , rankingOption + , Option [] ["preselected"] (NoArg (Flag GrammarTypeFlg PreAnchored)) + "do NOT perform lexical selection - treat the grammar as the selection" + ] + +instructionsOption, macrosOption, lexiconOption, tracesOption :: OptDescr Flag + +instructionsOption = + Option [] ["instructions"] (reqArg InstructionsFileFlg id "FILE") + "instructions file FILE" + +macrosOption = + Option ['t','m'] ["trees","macros"] (reqArg MacrosFlg id "FILE") + "tree schemata file FILE (unanchored trees)" + +lexiconOption = + Option ['l'] ["lexicon"] (reqArg LexiconFlg id "FILE") + "lexicon file FILE" + +tracesOption = + Option [] ["traces"] (reqArg TracesFlg id "FILE") + "traces file FILE (list of traces to display)" + +rankingOption :: OptDescr Flag +rankingOption = + Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") + "ranking constraints FILE (using Optimality Theory)" + +-- -------------------------------------------------------------------- +-- Output +-- -------------------------------------------------------------------- + +optionsForOutput :: [OptDescr Flag] +optionsForOutput = + [ outputOption + , Option [] ["dump"] (noArg DumpDerivationFlg) + "print derivation information on stdout (JSON)" + -- same as rankingOption but with output-centric help text + , partialOption + , Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") + "use constraints in FILE to rank output" + ] + +partialOption :: OptDescr Flag +partialOption = + Option [] ["partial"] (noArg PartialFlg) + "return partial result(s) if no complete solution is found" + +outputOption :: OptDescr Flag +outputOption = + Option ['o'] ["output"] (reqArg OutputFileFlg id "FILE") + "output file FILE (stdout if unset)" + +-- -------------------------------------------------------------------- +-- User interface +-- -------------------------------------------------------------------- + +optionsForUserInterface :: [OptDescr Flag] +optionsForUserInterface = + [ noguiOption, helpOption, versionOption + , Option [] ["viewcmd"] (reqArg ViewCmdFlg id "CMD") + "XMG tree-view command" + ] + +noguiOption :: OptDescr Flag +noguiOption = Option [] ["nogui"] (noArg DisableGuiFlg) + "disable graphical user interface" + +helpOption :: OptDescr Flag +helpOption = Option [] ["help"] (noArg HelpFlg) + "show full list of command line switches" + +versionOption :: OptDescr Flag +versionOption = Option [] ["version"] (noArg VersionFlg) + "display the version" + +verboseOption :: OptDescr Flag +verboseOption = Option ['v'] ["verbose"] (noArg VerboseModeFlg) + "verbose mode" + +-- -------------------------------------------------------------------- +-- Optimisations +-- -------------------------------------------------------------------- + +defaultPolarityAttrs :: String +defaultPolarityAttrs = "cat" + +exampleRootFeat :: String +exampleRootFeat = "[cat:s inv:- mode:ind|subj wh:-]" + +defaultRootFeat :: String +defaultRootFeat = "[cat:_]" + +optionsForOptimisation :: [OptDescr Flag] +optionsForOptimisation = + [ Option [] ["opts"] + (reqArg OptimisationsFlg readOptimisations "LIST") + "optimisations 'LIST' (--help for details)" + , Option [] ["detect-pols"] + (reqArg DetectPolaritiesFlg readPolarityAttrs "LIST") + ("attributes 'LIST' (eg. \"cat idx V.tense\", default:" ++ show defaultPolarityAttrs ++ ")") + , rootFeatureOption + , maxResultsOption + ] + +rootFeatureOption :: OptDescr Flag +rootFeatureOption = + Option ['r'] ["rootfeat"] + (reqArg RootFeatureFlg readRF "FEATURE") + ("root features 'FEATURE' (eg. " + ++ prettyStr exampleRF ++ ", default: " + ++ prettyStr defaultRF ++ ")") + where + exampleRF = readRF exampleRootFeat + defaultRF = readRF defaultRootFeat + readRF = parseFlagWithParsec "root feature" geniFeats + +coreOptimisationCodes :: [(Optimisation,String,String)] +coreOptimisationCodes = + [ (Polarised , "p", "polarity filtering") + , (NoConstraints , "nc", "disable semantic constraints (anti-optimisation!)") + ] + +optimisationCodes :: [(Optimisation,String,String)] +optimisationCodes = + coreOptimisationCodes ++ + [ (PolOpts , "pol", equivalentTo polOpts) + , (AdjOpts , "adj", equivalentTo adjOpts) + ] + where equivalentTo os = "equivalent to '" ++ (unwords $ map showOptCode os) ++ "'" + +polOpts, adjOpts :: [Optimisation] +polOpts = [Polarised] +adjOpts = [] + +-- --------------------------------------------------------------------- +-- Optimisation usage info +-- --------------------------------------------------------------------- + +lookupOpt:: Optimisation -> (String, String) +lookupOpt k = + case find (\x -> k == fst3 x) optimisationCodes of + Just (_, c, d) -> (c, d) + Nothing -> geniBug $ "optimisation " ++ show k ++ " unknown" + +showOptCode :: Optimisation -> String +showOptCode = fst.lookupOpt + +describeOpt :: (Optimisation, String, String) -> String +describeOpt (_,k,d) = k ++ " - " ++ d + +-- | Displays the usage text for optimisations. +-- It shows a table of optimisation codes and their meaning. +usageForOptimisations :: [String] +usageForOptimisations = + [ "Optimisations must be passed in as a space-delimited list" + , "(ex: --opt='p f-sem' for polarities and semantic filtering)" + , "" + , "Optimisations:" + , " " ++ unlinesTab (map describeOpt coreOptimisationCodes) + ] + where unlinesTab l = concat (intersperse "\n " l) + +-- --------------------------------------------------------------------- +-- Parsing optimisation stuff +-- --------------------------------------------------------------------- + +-- | If we do not recognise a code, we output an error message. We +-- also take the liberty of expanding thematic codes like 'pol' +-- into the respective list of optimisations. +readOptimisations :: String -> [Optimisation] +readOptimisations str = + case parseOptimisations str of + Left ick -> error $ "Unknown optimisations: " ++ (unwords ick) + Right os -> (addif PolOpts polOpts) . (addif AdjOpts adjOpts) $ os + where addif t x o = if (t `elem` o) then x ++ o else o + +-- | Returns |Left| for any codes we don't recognise, or +-- |Right| if everything is ok. +parseOptimisations :: String -> Either [String] [Optimisation] +parseOptimisations str = + let codes = words str + mopts = map lookupOptimisation codes + in if any isNothing mopts + then Left [ c | (c,o) <- zip codes mopts, isNothing o ] + else Right $ map fromJust mopts + +lookupOptimisation :: String -> Maybe Optimisation +lookupOptimisation code = + liftM fst3 $ find (\x -> snd3 x == code) optimisationCodes + +-- | TODO: This is a horrible and abusive use of 'error' +parseFlagWithParsec :: String -> CharParser () b -> String -> b +parseFlagWithParsec description p str = + case runParser (tillEof p) () "" str of + Left err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err + Right res -> res + +-- -------------------------------------------------------------------- +-- Builders +-- -------------------------------------------------------------------- + +optionsForBuilder :: [OptDescr Flag] +optionsForBuilder = + [ Option ['b'] ["builder"] (reqArg BuilderFlg readBuilderType "BUILDER") + ("use as realisation engine one of: " ++ (unwords $ map show mainBuilderTypes)) + , partialOption + , maxStepsOption + , maxResultsOption + ] + +mainBuilderTypes :: [BuilderType] +mainBuilderTypes = + [ SimpleBuilder, SimpleOnePhaseBuilder + ] + +-- | Hint: compose with (map toLower) to make it case-insensitive +mReadBuilderType :: String -> Maybe BuilderType +mReadBuilderType "simple" = Just SimpleBuilder +mReadBuilderType "simple-2p" = Just SimpleBuilder +mReadBuilderType "simple-1p" = Just SimpleOnePhaseBuilder +mReadBuilderType _ = Nothing + +-- | Is case-insensitive, error if unknown type +readBuilderType :: String -> BuilderType +readBuilderType b = + case mReadBuilderType $ map toLower b of + Just x -> x + Nothing -> error $ "Unknown builder type " ++ b + +-- -------------------------------------------------------------------- +-- Testing and profiling +-- -------------------------------------------------------------------- + +fromStdinOption :: OptDescr Flag +fromStdinOption = + Option [] ["from-stdin"] (noArg FromStdinFlg) "get testcase from stdin" + +testSuiteOption :: OptDescr Flag +testSuiteOption = + Option ['s'] ["testsuite"] (reqArg TestSuiteFlg id "FILE") "test suite FILE" + +maxResultsOption :: OptDescr Flag +maxResultsOption = + Option [] ["maxresults"] (reqArg MaxResultsFlg read "INT") + "return as soon as at least INT results are found" + +maxStepsOption :: OptDescr Flag +maxStepsOption = + Option [] ["maxsteps"] (reqArg MaxStepsFlg read "INT") + "abort and return any results found after INT steps" + +optionsForTesting :: [OptDescr Flag] +optionsForTesting = + [ testSuiteOption + , fromStdinOption + , Option [] ["testcase"] + (reqArg (TestCaseFlg . T.pack) id "STRING") + "run test case STRING" + , Option [] ["timeout"] (reqArg TimeoutFlg read "SECONDS") + "time out after SECONDS seconds" + , maxResultsOption + , maxStepsOption + , Option [] ["metrics"] (optArg MetricsFlg ["default"] words "LIST") + "keep track of performance metrics: (default: iterations comparisons chart_size)" + , Option [] ["statsfile"] (reqArg StatsFileFlg id "FILE") + "write performance data to file FILE (stdout if unset)" + , Option [] ["batchdir"] (reqArg BatchDirFlg id "DIR") + "batch process the test suite and save results to DIR" + , Option [] ["earlydeath"] (noArg EarlyDeathFlg) + "exit on first case with no results (batch processing) " + ] + +-- -------------------------------------------------------------------- +-- Morphology +-- -------------------------------------------------------------------- + +optionsForMorphology :: [OptDescr Flag] +optionsForMorphology = + [ morphInfoOption + , Option [] ["morphcmd"] (reqArg MorphCmdFlg id "CMD") + "morphological post-processor CMD (default: unset)" + ] + +morphInfoOption :: OptDescr Flag +morphInfoOption = Option [] ["morphinfo"] (reqArg MorphInfoFlg id "FILE") + "morphological features FILE (default: unset)" + +-- ==================================================================== +-- Scripting GenI +-- ==================================================================== + +-- | Update the internal instructions list, test suite and case +-- according to the contents of an instructions file. +-- +-- Basic approach +-- +-- * we always have instructions: if no instructions file, is specified +-- we infer virtual instructions from the test suite flag +-- * the testsuite and testcase flags are focusing tools, they pick out +-- a subset from the instructions +processInstructions :: Params -> IO Params +processInstructions config = do + instructions <- case getFlagP InstructionsFileFlg config of + Nothing -> return fakeInstructions + Just f -> instructionsFile `fmap` T.readFile f + let updateInstructions = setFlagP TestInstructionsFlg instructions + -- we have to set a test suite in case the user only supplies + -- an instructions argument so that NLP.GenI.loadEverything + -- knows that the user has given us a suite to load + updateTestSuite p = + if hasFlagP TestSuiteFlg p then p + else case (fst `fmap` listToMaybe instructions) of + Just s -> setFlagP TestSuiteFlg s p + Nothing -> p + return . updateTestSuite . updateInstructions $ config + where + fakeInstructions :: [Instruction] + fakeInstructions = + let cases = singleton <$> getFlagP TestCaseFlg config + mkInstr xs = singleton (xs, cases) + in maybe [] mkInstr $ getFlagP TestSuiteFlg config + +instructionsFile :: Text -> [Instruction] +instructionsFile = + mapMaybe inst . T.lines + where + inst l = case T.words (T.takeWhile (/= '%') l) of + [] -> Nothing + [f] -> Just (T.unpack f, Nothing) + (f:cs) -> Just (T.unpack f, Just cs) + +-- ==================================================================== +-- Configuration file +-- ==================================================================== + +readGlobalConfig :: IO (Maybe YamlLight) +readGlobalConfig = do + geniCfgDir <- getAppUserDataDirectory "geni" + let globalCfg = geniCfgDir "config.yaml" + hasCfg <- doesFileExist globalCfg + if hasCfg then Just `fmap` parseYamlFile globalCfg + else return Nothing + +data LoggerConfig = LoggerConfig { lcName :: String + , lcPriority :: Priority + , lcHandler :: LogTo + , lcFormatter :: LogFmt + } + deriving Show + +data LogTo = LogToFile FilePath | LogToErr + deriving Show + +data LogFmt = LogFmtNull | LogFmtSimple String + deriving Show + +logDefaultConfig :: String -> LoggerConfig +logDefaultConfig n = LoggerConfig + { lcName = n + , lcPriority = DEBUG + , lcHandler = LogToErr + , lcFormatter = LogFmtNull + } + +setLoggers :: YamlLight -> IO () +setLoggers y = do + -- it seems we need to explicitly create the root logger + -- we set this to the lowest priority because we want the user to + -- be able to set the priority on their loggers as low as they want + updateGlobalLogger "" $ setLevel DEBUG + . setHandlers noHandlers + mapM_ setGeniHandler $ fromMaybe [globalDefault] (loggerConfig y) + where + noHandlers :: [GenericHandler ()] + noHandlers = [] + globalDefault = (logDefaultConfig "NLP.GenI") { lcPriority = INFO } + +setGeniHandler :: LoggerConfig -> IO () +setGeniHandler lc = do + h <- flip setFormatter fmttr <$> handler (lcPriority lc) + updateGlobalLogger (lcName lc) (setHandlers [h]) + where + handler = case lcHandler lc of + LogToFile f -> fileHandler f + LogToErr -> streamHandler stderr + -- + fmttr = case lcFormatter lc of + LogFmtSimple str -> simpleLogFormatter str + LogFmtNull -> nullFormatter + +instance Read LogTo where + readsPrec _ (dropPrefix "stderr" -> ("", x)) = [ (LogToErr, x) ] + readsPrec p (dropPrefix "file" -> ("", x)) = map (first LogToFile) (readsQuotedStringPrec p x) + readsPrec _ _ = [] + +instance Read LogFmt where + readsPrec _ (dropPrefix "null" -> ("", x)) = [ (LogFmtNull, x) ] + readsPrec p (dropPrefix "simple" -> ("", x)) = map (first LogFmtSimple) (readsQuotedStringPrec p x) + readsPrec _ _ = [] + +readsQuotedStringPrec :: Int -> String -> [ (String, String) ] +readsQuotedStringPrec p x@(h:_) | isSpace h = + case dropWhile isSpace x of + xs@('"':_) -> readsPrec p xs + (break isSpace -> y) | not (null (fst y)) -> [y] + _ -> [] +readsQuotedStringPrec _ _ = [] + +loggerConfig :: YamlLight -> Maybe [LoggerConfig] +loggerConfig yaml = lookupYL "logging" yaml + >>= unSeq + >>= mapM unMap + >>= mapM readOne + where + readOne :: Map.Map YamlLight YamlLight -> Maybe LoggerConfig + readOne m = do + let name = fromMaybe "NLP.GenI" (get Just "name" m) + return $ updater "level" m (\x l -> l { lcPriority = x }) + . updater "handler" m (\x l -> l { lcHandler = x }) + . updater "format" m (\x l -> l { lcFormatter = x }) + $ logDefaultConfig name + updater str m fn = maybe id fn (get maybeRead str m) + get f x m = Map.lookup x m >>= unStr >>= (f . BC.unpack) + +instance IsString YamlLight where + fromString = YStr . fromString + +-- ---------------------------------------------------------------------- +-- +-- ---------------------------------------------------------------------- + +singleton :: a -> [a] +singleton = pure + +maybeRead :: Read a => String -> Maybe a +maybeRead s = case reads s of + [(x, rest)] | all isSpace rest -> Just x + _ -> Nothing + +dropPrefix :: Eq a => [a] -> [a] -> ([a],[a]) +dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys +dropPrefix left right = (left,right) diff --git a/src/NLP/GenI/Configuration.lhs b/src/NLP/GenI/Configuration.lhs deleted file mode 100644 --- a/src/NLP/GenI/Configuration.lhs +++ /dev/null @@ -1,891 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Command line arguments} - -\begin{code} -{-# LANGUAGE ExistentialQuantification #-} -module NLP.GenI.Configuration - ( Params(..), GrammarType(..), BuilderType(..), Instruction, Flag - -- * flags - , BatchDirFlg(..) - , DetectPolaritiesFlg(..) - , DisableGuiFlg(..) - , DumpDerivationFlg(..) - , EarlyDeathFlg(..) - , ExtraPolaritiesFlg(..) - , FromStdinFlg(..) - , HelpFlg(..) - , InstructionsFileFlg(..) - , LexiconFlg(..) - , MacrosFlg(..) - , MetricsFlg(..) - , MorphCmdFlg(..) - , MorphInfoFlg(..) - , NoLoadTestSuiteFlg(..) - , OptimisationsFlg(..) - , OutputFileFlg(..) - , PartialFlg(..) - , RankingConstraintsFlg(..) - , RegressionTestModeFlg(..) - , RootFeatureFlg(..) - , RunUnitTestFlg(..) - , StatsFileFlg(..) - , TestCaseFlg(..) - , TestInstructionsFlg(..) - , TestSuiteFlg(..) - , TimeoutFlg(..) - , TracesFlg(..) - , VerboseModeFlg(..) - , VersionFlg(..) - , ViewCmdFlg(..) - -- - , mainBuilderTypes - , getFlagP, getListFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt - , getFlag, setFlag, hasFlag - , Optimisation(..) - , emptyParams, defineParams - , treatArgs, treatArgsWithParams, usage, basicSections, optionsSections - , processInstructions - , optionsForStandardGenI - , optionsForBasicStuff, optionsForOptimisation, optionsForMorphology, optionsForInputFiles - , optionsForBuilder, optionsForTesting - , nubBySwitches - , noArg, reqArg, optArg - , parseFlagWithParsec - -- re-exports - , module System.Console.GetOpt - , Typeable - ) -where -\end{code} - -\ignore{ -\begin{code} -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Control.Monad ( liftM ) -import Data.Char ( toLower ) -import Data.Maybe ( listToMaybe, mapMaybe ) -import Data.Typeable ( Typeable, typeOf, cast ) -import System.Console.GetOpt -import System.Environment ( getProgName ) -import Data.List ( find, intersperse, nubBy ) -import Data.Maybe ( catMaybes, fromMaybe, isNothing, fromJust ) -import Text.ParserCombinators.Parsec ( runParser, CharParser ) - -import NLP.GenI.Btypes ( Flist, showFlist, ) -import NLP.GenI.General ( geniBug, fst3, snd3, Interval ) -import NLP.GenI.GeniParsers ( geniFeats, geniPolarities ) -import NLP.GenI.PolarityTypes ( PolarityKey(..), PolarityAttr(..), readPolarityAttrs ) -\end{code} -} - -% -------------------------------------------------------------------- -% Code for debugging. (should be latex-commented -% when not in use) -% -------------------------------------------------------------------- - -%\begin{code} -%import Debug.Trace -%\end{code} - -% -------------------------------------------------------------------- -% Params -% -------------------------------------------------------------------- - -\begin{code} --- | Holds the specification for how Geni should be run, its input --- files, etc. This is the stuff that would normally be found in --- the configuration file. -data Params = Prms{ - grammarType :: GrammarType, - builderType :: BuilderType, - geniFlags :: [Flag] -} deriving (Show) - -hasOpt :: Optimisation -> Params -> Bool -hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p - -hasFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool -deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params -setFlagP :: (Eq f, Show f, Show x, Typeable f, Typeable x) => (x -> f) -> x -> Params -> Params -getFlagP :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> Params -> Maybe x -getListFlagP :: (Show f, Show x, Typeable f, Typeable x) => ([x] -> f) -> Params -> [x] - -hasFlagP f = hasFlag f . geniFlags -deleteFlagP f p = p { geniFlags = deleteFlag f (geniFlags p) } -setFlagP f v p = p { geniFlags = setFlag f v (geniFlags p) } -getFlagP f = getFlag f . geniFlags -getListFlagP f = fromMaybe [] . getFlagP f --- | The default parameters configuration -emptyParams :: Params -emptyParams = Prms { - builderType = SimpleBuilder, - grammarType = GeniHand, - geniFlags = [ Flag ViewCmdFlg "ViewTAG" - , Flag DetectPolaritiesFlg (readPolarityAttrs defaultPolarityAttrs) - , Flag RootFeatureFlg (readRF defaultRootFeat) - ] -} - where readRF = parseFlagWithParsec "default root feature" geniFeats -\end{code} - -% -------------------------------------------------------------------- -\section{Command line arguments} -% -------------------------------------------------------------------- - -Command line arguments can be specified in the GNU style, for example -\texttt{--foo=bar} or \texttt{--foo bar}, or \texttt{-f bar} when a -short switch is available. For more information, type \texttt{geni ---help}. - - -\begin{code} -type OptSection = (String,[OptDescr Flag],[String]) - --- | Uses the GetOpt library to process the command line arguments. --- Note that we divide them into basic and advanced usage. -optionsForStandardGenI :: [OptDescr Flag] -optionsForStandardGenI = - nubBySwitches $ concatMap snd3 optionsSections - ++ -- FIXME: weird mac stuff - [ Option ['p'] [] (reqArg WeirdFlg id "CMD") "" ] - -basicSections :: [OptSection] -basicSections = map tweakBasic $ take 1 optionsSections - where - tweakBasic (x,y,z) = (x,y,z ++ ["See --help for more options"]) - -optionsSections :: [OptSection] -optionsSections = - [ ("Core options", optionsForBasicStuff, example) - , ("Input", optionsForInputFiles, []) - , ("Output", optionsForOutput, []) - , ("Algorithm", - (nubBySwitches $ optionsForBuilder ++ optionsForOptimisation), - usageForOptimisations) - , ("Morphology", optionsForMorphology, []) - , ("User interface", optionsForUserInterface, []) - , ("Batch processing", optionsForTesting, []) - ] - where - example = [ "Example:" - , " geni -m examples/ej/mac -l examples/ej/lexicon -s examples/ej/suite" - ] - -getSwitches :: OptDescr a -> ([Char],[String]) -getSwitches (Option s l _ _) = (s,l) - -nubBySwitches :: [OptDescr a] -> [OptDescr a] -nubBySwitches = nubBy (\x y -> getSwitches x == getSwitches y) - --- GetOpt wrappers -noArg :: forall f . (Eq f, Show f, Typeable f) - => (() -> f) -> ArgDescr Flag -noArg s = NoArg (Flag s ()) - -reqArg :: forall f x . (Eq f, Show f, Typeable f, Eq x, Show x, Typeable x) - => (x -> f) -- ^ flag - -> (String -> x) -- ^ string reader for flag (probably |id| if already a String) - -> String -- ^ description - -> ArgDescr Flag -reqArg s fn desc = ReqArg (\x -> Flag s (fn x)) desc - -optArg :: forall f x . (Eq f, Show f, Typeable f, Eq x, Show x, Typeable x) - => (x -> f) -- ^ flag - -> x -- ^ default value - -> (String -> x) -- ^ string reader (as in @reqArg@) - -> String -- ^ description - -> ArgDescr Flag -optArg s def fn desc = OptArg (\x -> Flag s (maybe def fn x)) desc -\end{code} - -\begin{code} --- ------------------------------------------------------------------- --- Parsing command line arguments --- ------------------------------------------------------------------- - --- | Print out a GenI-style usage message with options divided into sections -usage :: [OptSection] -- ^ options - -> String -- ^ prog name - -> String -usage sections pname = - let header = "Usage: " ++ pname ++ " [OPTION...]\n" - body = unlines $ map usageSection sections - in header ++ body - -usageSection :: (String, [OptDescr Flag],[String]) -> String -usageSection (name, opts, comments) = - usageInfo (unlines $ [bar,name, bar]) opts ++ mcomments - where - bar = replicate 72 '=' - mcomments = if null comments then [] else "\n" ++ unlines comments - -treatArgs :: [OptDescr Flag] -> [String] -> IO Params -treatArgs options argv = treatArgsWithParams options argv emptyParams - -treatArgsWithParams :: [OptDescr Flag] -> [String] -> Params -> IO Params -treatArgsWithParams options argv initParams = - case getOpt Permute options argv of - (os,_,[] )-> return $ defineParams os initParams - (_,_,errs) -> do p <- getProgName - ioError (userError $ concat errs ++ usage basicSections p) - -defineParams :: [Flag] -> Params -> Params -defineParams flgs prms = - (\p -> foldr setDefault p $ geniFlags prms) - . (mergeFlagsP OptimisationsFlg) - . (mergeFlagsP MetricsFlg) - $ prms - { geniFlags = flgs - , builderType = fromFlags builderType BuilderFlg flgs - , grammarType = fromFlags grammarType GrammarTypeFlg flgs - } - where - setDefault (Flag f v) p = - if hasFlagP f p then p else setFlagP f v p - mergeFlagsP f p = - if hasFlagP f p - then setFlagP f (concat $ getAllFlags f flgs) p - else p - fromFlags default_ t fs = - fromMaybe (default_ prms) (getFlag t fs) -\end{code} - -\section{Options by theme} -\label{sec:fancy_parameters} - -At the time of this writing (2009-09-25), it is highly unlikely that all the -options are documented here. See \verb!geni --help! for more details. - -Note that you might see an option described in more than one place -because it falls into multiple categories. - -% -------------------------------------------------------------------- -\subsection{Basic options} -% -------------------------------------------------------------------- - - -\begin{code} -optionsForBasicStuff :: [OptDescr Flag] -optionsForBasicStuff = - [ helpOption, verboseOption, noguiOption - , macrosOption , lexiconOption, testSuiteOption - , outputOption - ] -\end{code} - -% -------------------------------------------------------------------- -\subsection{Input files} -% -------------------------------------------------------------------- - -See Chapter \ref{cha:formats} for details on how to write these files. - -\begin{description} -\item[macros] - The \verb!macros! switch is used to supply GenI with FB-LTAG tree - schemata. -\item[lexicon] - The \verb!lexicon! is used for lexical entries that point to the - macros -\item[suite] - The \verb!suite! provides test cases on which to run GenI -\item[ranking] - The \verb!ranking! switch allows you to specify a file containing - Optimality Theory style constraints which GenI will use to rank - its output. See Chapter \ref{cha:ranking} for more details on the format - and use of this file. -\end{description} - -\begin{code} -optionsForInputFiles :: [OptDescr Flag] -optionsForInputFiles = - [ macrosOption - , lexiconOption - , tracesOption - , testSuiteOption - , fromStdinOption - , morphInfoOption - , instructionsOption - , rankingOption - , Option [] ["preselected"] (NoArg (Flag GrammarTypeFlg PreAnchored)) - "do NOT perform lexical selection - treat the grammar as the selection" - ] - -instructionsOption, macrosOption, lexiconOption, tracesOption :: OptDescr Flag - -instructionsOption = - Option [] ["instructions"] (reqArg InstructionsFileFlg id "FILE") - "instructions file FILE" - -macrosOption = - Option ['m'] ["macros"] (reqArg MacrosFlg id "FILE") - "tree schemata file FILE (unanchored trees)" - -lexiconOption = - Option ['l'] ["lexicon"] (reqArg LexiconFlg id "FILE") - "lexicon file FILE" - -tracesOption = - Option [] ["traces"] (reqArg TracesFlg id "FILE") - "traces file FILE (list of traces to display)" - -rankingOption :: OptDescr Flag -rankingOption = - Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") - "ranking constraints FILE (using Optimality Theory)" -\end{code} - -% -------------------------------------------------------------------- -\subsection{Output} -% -------------------------------------------------------------------- - -\begin{code} -optionsForOutput :: [OptDescr Flag] -optionsForOutput = - [ outputOption - , Option [] ["dump"] (noArg DumpDerivationFlg) - "print derivation information on stdout (JSON)" - , Option [] ["partial"] (noArg PartialFlg) - "return partial result(s) if no complete solution is found" - -- same as rankingOption but with output-centric help text - , Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE") - "use constraints in FILE to rank output" - ] - -outputOption :: OptDescr Flag -outputOption = - Option ['o'] ["output"] (reqArg OutputFileFlg id "FILE") - "output file FILE (stdout if unset)" -\end{code} - -% -------------------------------------------------------------------- -\subsection{User interface} -% -------------------------------------------------------------------- - -\begin{code} -optionsForUserInterface :: [OptDescr Flag] -optionsForUserInterface = - [ noguiOption, helpOption, versionOption - , Option [] ["regression"] (noArg RegressionTestModeFlg) - "Run in regression testing mode (needs grammar, etc)" - , Option [] ["unit-tests"] (noArg RunUnitTestFlg) - "Run in unit testing mode (no arguments needed)" - , Option [] ["viewcmd"] (reqArg ViewCmdFlg id "CMD") - "XMG tree-view command" - ] - -noguiOption :: OptDescr Flag -noguiOption = Option [] ["nogui"] (noArg DisableGuiFlg) - "disable graphical user interface" - -helpOption :: OptDescr Flag -helpOption = Option [] ["help"] (noArg HelpFlg) - "show full list of command line switches" - -versionOption :: OptDescr Flag -versionOption = Option [] ["version"] (noArg VersionFlg) - "display the version" - -verboseOption :: OptDescr Flag -verboseOption = Option ['v'] ["verbose"] (noArg VerboseModeFlg) - "verbose mode" -\end{code} - -% -------------------------------------------------------------------- -\subsection{Optimisations} -% -------------------------------------------------------------------- - -\begin{description} -\item[opt] - The opt switch lets you specify a list of optimisations - that GenI should use, for example, \texttt{--opt='pol S i'}. - We associate each optimisation with a short code like 'i' for - ``index accessibility filtering''. This code is what the - user passes in, and is sometimes used by GenI to tell the - user which optimisations it's using. See \texttt{geni - --help} for more detail on the codes. - - Optimisations can be accumulated. For example, if you say something - like \texttt{--opt='foo bar' --opt='quux'} it is the same as saying - \texttt{--opt='foo bar quux'}. - - Note that we also have two special thematic codes ``pol'' and - ``adj'' which tell GenI that it should enable all the - polarity-related, and all the adjunction-related - optimisations respectively. - -\item[detect-pols] - This tells GenI how to detect polarities in your grammar. You pass - this in in the form of a space-delimited string, where each word is either - an attribute or a ``restricted'' attribute. In lieu of an explanation, - here is an example: the string ``cat idx V.tense D.c'' tells GenI that - we should detect polarities on the ``cat'' and ``idx'' attribute - for all nodes and also on the ``tense'' attribute for all nodes - with the category ``V'' and the ``c'' attribute for all nodes with the - category ``D''. - - If your grammar comes with its own hand-written polarities, you can - suppress polarity detection altogether by supplying the empty string. - - Also, if you do not use this switch, the following defaults will be - used: - -\begin{includecodeinmanual} -\begin{code} -defaultPolarityAttrs :: String -defaultPolarityAttrs = "cat" -\end{code} -\end{includecodeinmanual} - -\item[rootfeat] - No results? Make sure your rootfeat are set correctly. GenI - will reject all sentences whose root category does not unify - with the rootfeat, the default of which is: -\begin{includecodeinmanual} -\begin{code} -defaultRootFeat :: String -defaultRootFeat = "[cat:s inv:- mode:ind|subj wh:-]" -\end{code} -\end{includecodeinmanual} - - You can set rootfeat to be empty (\verb![]!) if you want, in - which case the realiser proper will return all results; but - note that if you want to use polarity filtering, you must at - least specify a value for the \verb!cat! feature. - -\item[extrapols] - Allows to to preset some polarities. There's not very much use for - this, in my opinion. Most likely, what you really want is rootfeat. -\end{description} - -\begin{code} -optionsForOptimisation :: [OptDescr Flag] -optionsForOptimisation = - [ Option [] ["opts"] - (reqArg OptimisationsFlg readOptimisations "LIST") - "optimisations 'LIST' (--help for details)" - , Option [] ["detect-pols"] - (reqArg DetectPolaritiesFlg readPolarityAttrs "LIST") - ("attributes 'LIST' (eg. \"cat idx V.tense\", default:" ++ show defaultPolarityAttrs ++ ")") - , Option [] ["rootfeat"] - (reqArg RootFeatureFlg readRF "FEATURE") - ("root features 'FEATURE' (for polarities, default:" - ++ showFlist defaultRF ++ ")") - , Option [] ["extrapols"] - (reqArg ExtraPolaritiesFlg readPolarities "STRING") - "preset polarities (normally, you should use rootfeat instead)" - ] - where - defaultRF = getListFlagP RootFeatureFlg emptyParams - readRF = parseFlagWithParsec "root feature" geniFeats - readPolarities = parseFlagWithParsec "polarity string" geniPolarities - -data Optimisation = PolOpts - | AdjOpts - | Polarised - | NoConstraints - | SemFiltered - | Iaf -- ^ one phase only! - | EarlyNa - deriving (Show,Eq,Typeable) - -coreOptimisationCodes :: [(Optimisation,String,String)] -coreOptimisationCodes = - [ (Polarised , "p", "polarity filtering") - , (EarlyNa , "e-na", "detect null adjunction at earliest opportunity") - , (SemFiltered , "f-sem", "semantic filtering (two-phase only)") - , (Iaf , "i", "index accesibility filtering (one-phase only)") - , (NoConstraints , "nc", "disable semantic constraints (anti-optimisation!)") - ] - -optimisationCodes :: [(Optimisation,String,String)] -optimisationCodes = - coreOptimisationCodes ++ - [ (SemFiltered , "S", "semantic filtering (same as f-sem)") - , (PolOpts , "pol", equivalentTo polOpts) - , (AdjOpts , "adj", equivalentTo adjOpts) - ] - where equivalentTo os = "equivalent to '" ++ (unwords $ map showOptCode os) ++ "'" - -polOpts, adjOpts :: [Optimisation] -polOpts = [Polarised] -adjOpts = [EarlyNa, SemFiltered] -\end{code} - -\begin{code} --- --------------------------------------------------------------------- --- Optimisation usage info --- --------------------------------------------------------------------- - -lookupOpt:: Optimisation -> (String, String) -lookupOpt k = - case find (\x -> k == fst3 x) optimisationCodes of - Just (_, c, d) -> (c, d) - Nothing -> geniBug $ "optimisation " ++ show k ++ " unknown" - -showOptCode :: Optimisation -> String -showOptCode = fst.lookupOpt - -describeOpt :: (Optimisation, String, String) -> String -describeOpt (_,k,d) = k ++ " - " ++ d - --- | Displays the usage text for optimisations. --- It shows a table of optimisation codes and their meaning. -usageForOptimisations :: [String] -usageForOptimisations = - [ "Optimisations must be passed in as a space-delimited list" - , "(ex: --opt='p f-sem' for polarities and semantic filtering)" - , "" - , "Optimisations:" - , " " ++ unlinesTab (map describeOpt coreOptimisationCodes) - ] - where unlinesTab l = concat (intersperse "\n " l) -\end{code} - -\begin{code} --- --------------------------------------------------------------------- --- Parsing optimisation stuff --- --------------------------------------------------------------------- - --- | If we do not recognise a code, we output an error message. We --- also take the liberty of expanding thematic codes like 'pol' --- into the respective list of optimisations. -readOptimisations :: String -> [Optimisation] -readOptimisations str = - case parseOptimisations str of - Left ick -> error $ "Unknown optimisations: " ++ (unwords ick) - Right os -> (addif PolOpts polOpts) . (addif AdjOpts adjOpts) $ os - where addif t x o = if (t `elem` o) then x ++ o else o - --- | Returns |Left| for any codes we don't recognise, or --- |Right| if everything is ok. -parseOptimisations :: String -> Either [String] [Optimisation] -parseOptimisations str = - let codes = words str - mopts = map lookupOptimisation codes - in if any isNothing mopts - then Left [ c | (c,o) <- zip codes mopts, isNothing o ] - else Right $ map fromJust mopts - -lookupOptimisation :: String -> Maybe Optimisation -lookupOptimisation code = - liftM fst3 $ find (\x -> snd3 x == code) optimisationCodes - -parseFlagWithParsec :: String -> CharParser () b -> String -> b -parseFlagWithParsec description p str = - case runParser p () "" str of - Left err -> error $ "Couldn't parse " ++ description ++ " because " ++ show err - Right res -> res -\end{code} - -% -------------------------------------------------------------------- -\subsection{Builders} -% -------------------------------------------------------------------- - -\begin{description} -\item[builder] - A builder is basically a surface realisation algorithm. \geni has the - infrastructure to support different realisation algorithms, but some - broken ones have been removed. -\end{description} - -\begin{code} -data BuilderType = NullBuilder | - SimpleBuilder | SimpleOnePhaseBuilder - deriving (Eq, Typeable) - -instance Show BuilderType where - show NullBuilder = "null" - show SimpleBuilder = "simple-2p" - show SimpleOnePhaseBuilder = "simple-1p" - -optionsForBuilder :: [OptDescr Flag] -optionsForBuilder = - [ Option ['b'] ["builder"] (reqArg BuilderFlg readBuilderType "BUILDER") - ("use as realisation engine one of: " ++ (unwords $ map show mainBuilderTypes)) - ] - -mainBuilderTypes :: [BuilderType] -mainBuilderTypes = - [ SimpleBuilder, SimpleOnePhaseBuilder - ] - --- | Hint: compose with (map toLower) to make it case-insensitive -mReadBuilderType :: String -> Maybe BuilderType -mReadBuilderType "null" = Just NullBuilder -mReadBuilderType "simple" = Just SimpleBuilder -mReadBuilderType "simple-2p" = Just SimpleBuilder -mReadBuilderType "simple-1p" = Just SimpleOnePhaseBuilder -mReadBuilderType _ = Nothing - --- | Is case-insensitive, error if unknown type -readBuilderType :: String -> BuilderType -readBuilderType b = - case mReadBuilderType $ map toLower b of - Just x -> x - Nothing -> error $ "Unknown builder type " ++ b - -\end{code} - -% -------------------------------------------------------------------- -\subsection{Testing and profiling} -% -------------------------------------------------------------------- - -\begin{code} -fromStdinOption :: OptDescr Flag -fromStdinOption = - Option [] ["from-stdin"] (noArg FromStdinFlg) "get testcase from stdin" - -testSuiteOption :: OptDescr Flag -testSuiteOption = - Option ['s'] ["testsuite"] (reqArg TestSuiteFlg id "FILE") "test suite FILE" - -optionsForTesting :: [OptDescr Flag] -optionsForTesting = - [ testSuiteOption - , fromStdinOption - , Option [] ["testcase"] (reqArg TestCaseFlg id "STRING") - "run test case STRING" - , Option [] ["timeout"] (reqArg TimeoutFlg read "SECONDS") - "time out after SECONDS seconds" - , Option [] ["metrics"] (optArg MetricsFlg ["default"] words "LIST") - "keep track of performance metrics: (default: iterations comparisons chart_size)" - , Option [] ["statsfile"] (reqArg StatsFileFlg id "FILE") - "write performance data to file FILE (stdout if unset)" - , Option [] ["batchdir"] (reqArg BatchDirFlg id "DIR") - "batch process the test suite and save results to DIR" - , Option [] ["earlydeath"] (noArg EarlyDeathFlg) - "exit on first case with no results (batch processing) " - ] -\end{code} - -% -------------------------------------------------------------------- -\subsection{Morphology} -% -------------------------------------------------------------------- - -GenI provides two options for morphology: either you use an external -inflection program (morphcmd), or you pass in a morphological lexicon -(morphlexicon) and in doing so, use GenI's built in inflecter. The -GenI internal morphology mechanism is a simple and stupid lookup-and- -unify table, so you probably don't want to use it if you have a huge -lexicon. - -\begin{description} -\item[morphcmd] specifies the program used for morphology. Literate -GenI \cite{literateGeni} has a chapter describing how that program must work. -It will mostly likely be a script you wrote to wrap around some off-the-shelf -software. -\item[morphlexicon] specifies a morphological lexicon for use by -GenI's internal morphological generator. Specifying this option will -cause the morphcmd flag to be ignored. -\item[morphinfo] tells GenI which literals in the input semantics are -to be used by the morphological \emph{pre-}processor. The pre-processor -strips these features from the input and fiddles with the elementary -trees used by GenI so that the right features get attached to the leaf -nodes. An example of a ``morphological'' literal is something like -\texttt{past(p)}. -\end{description} - -\begin{code} -optionsForMorphology :: [OptDescr Flag] -optionsForMorphology = - [ morphInfoOption - , Option [] ["morphcmd"] (reqArg MorphCmdFlg id "CMD") - "morphological post-processor CMD (default: unset)" - ] - -morphInfoOption :: OptDescr Flag -morphInfoOption = Option [] ["morphinfo"] (reqArg MorphInfoFlg id "FILE") - "morphological features FILE (default: unset)" -\end{code} - -% -------------------------------------------------------------------- -\subsection{Other options} -% -------------------------------------------------------------------- - -\begin{code} -data GrammarType = GeniHand -- ^ geni's text format - | PreCompiled -- ^ built into geni, no parsing needed - | PreAnchored -- ^ lexical selection already done - deriving (Show, Eq, Typeable) -\end{code} - -% ==================================================================== -\section{Scripting GenI} -% ==================================================================== - -\begin{description} -\item[instructions] An instructions file can be used to run GenI on -a list of test suites and cases. - -Any input that you give to GenI will be interpreted as a list of test -suites (and test cases that you want to run). Each line has the format -\texttt{path/to/test-suite case1 case2 .. caseN}. You can omit the -test cases, which is interpreted as you wanting to run the entire test -suite. Also, the \verb!%! character and anything after is treated as -a comment. - -Interaction with \verb!--testsuite! and \verb!--testcase!: -\begin{itemize} -\item If only \verb!--instructions! is set, then the first test suite - and or test case from the instructions file is used. -\item If only \verb!--testsuite! and \verb!--testcase! are set, we - pretend that an instructions file was supplied saying that we - want to run the entirety of the test suite specified in - \verb!--testsuite!. -\item If both \verb!--instructions! and \verb!--testsuite!/ - \verb!--testcase! are set then the latter are used to - select from within the instructions. -\end{itemize} -\end{description} - - -\begin{code} -type Instruction = (FilePath, Maybe [String]) - --- | Update the internal instructions list, test suite and case --- according to the contents of an instructions file. -processInstructions :: Params -> IO Params -processInstructions config = - do instructions <- case getFlagP InstructionsFileFlg config of - Nothing -> return fakeInstructions - Just f -> instructionsFile `fmap` readFile f - -- basically set the test suite/case flag to the first instruction - -- note that with the above code (which sets the first instruction - -- to the test suite/case flag), this should work out to identity - -- when those flags are provided. - let updateInstructions = - setFlagP TestInstructionsFlg instructions - updateTestCase p = - if hasFlagP TestCaseFlg p then p - else case (listToMaybe instructions >>= snd >>= listToMaybe) of - Just c -> setFlagP TestCaseFlg c p - Nothing -> p - updateTestSuite p = - if hasFlagP TestSuiteFlg p then p - else case (fst `fmap` listToMaybe instructions) of - Just s -> setFlagP TestSuiteFlg s p - Nothing -> p - return . updateInstructions . updateTestSuite . updateTestCase $ config - where - fakeInstructions = - case getFlagP TestSuiteFlg config of - Just ts -> [ (ts, Nothing) ] - Nothing -> [] - -instructionsFile :: String -> [Instruction] -instructionsFile = mapMaybe inst . lines - where - inst l = case words (takeWhile (/= '%') l) of - [] -> Nothing - [f] -> Just (f, Nothing) - (f:cs) -> Just (f, Just cs) -\end{code} - -% ==================================================================== -% Flags -% ==================================================================== - -\begin{code} -{- -Flags are GenI's internal representation of command line arguments. We -use phantom existential types (?) for representing GenI flags. This -makes it simpler to do things such as ``get the value of the MacrosFlg'' -whilst preserving type safety (we always know that MacrosFlg is -associated with String). The alternative would be writing getters and -setters for each flag, and that gets really boring after a while. --} - -data Flag = forall f x . (Eq f, Show f, Show x, Typeable f, Typeable x) => - Flag (x -> f) x deriving (Typeable) - -instance Show Flag where - show (Flag f x) = "Flag " ++ show (f x) - -instance Eq Flag where - (Flag f1 x1) == (Flag f2 x2) - | (typeOf f1 == typeOf f2) && (typeOf x1 == typeOf x2) = - (fromJust . cast . f1 $ x1) == (f2 x2) - | otherwise = False - -isFlag :: (Typeable f, Typeable x) => (x -> f) -> Flag -> Bool -hasFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> Bool -deleteFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> [Flag] -setFlag :: (Eq f, Show f, Show x, Typeable f, Typeable x) => (x -> f) -> x -> [Flag] -> [Flag] -getFlag :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> [Flag] -> Maybe x -getAllFlags :: (Show f, Show x, Typeable f, Typeable x) => (x -> f) -> [Flag] -> [x] - -isFlag f1 (Flag f2 _) = typeOf f1 == typeOf f2 -hasFlag f = any (isFlag f) -deleteFlag f = filter (not.(isFlag f)) -setFlag f v fs = (Flag f v) : tl where tl = deleteFlag f fs -getFlag f fs = do (Flag _ v) <- find (isFlag f) fs ; cast v -getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- fs, isFlag f flg ] - - -{- -Below are just the individual flags, which unfortunately have to be -defined as separate data types because of our fancy existential -data type code. --} --- input files -#define FLAG(x,y) data x = x y deriving (Eq, Show, Typeable) - -FLAG (BatchDirFlg, FilePath) -FLAG (DisableGuiFlg, ()) -FLAG (DetectPolaritiesFlg, (Set.Set PolarityAttr)) -FLAG (DumpDerivationFlg, ()) -FLAG (EarlyDeathFlg, ()) -FLAG (ExtraPolaritiesFlg, (Map.Map PolarityKey Interval)) -FLAG (FromStdinFlg, ()) -FLAG (HelpFlg, ()) -FLAG (InstructionsFileFlg, FilePath) -FLAG (LexiconFlg, FilePath) -FLAG (MacrosFlg, FilePath) -FLAG (TracesFlg, FilePath) -FLAG (MetricsFlg, [String]) -FLAG (MorphCmdFlg, String) -FLAG (MorphInfoFlg, FilePath) -FLAG (OptimisationsFlg, [Optimisation]) -FLAG (OutputFileFlg, String) -FLAG (PartialFlg, ()) -FLAG (RankingConstraintsFlg, FilePath) -FLAG (RegressionTestModeFlg, ()) -FLAG (RootFeatureFlg, Flist) -FLAG (RunUnitTestFlg, ()) -FLAG (NoLoadTestSuiteFlg, ()) -FLAG (StatsFileFlg, FilePath) -FLAG (TestCaseFlg, String) -FLAG (TestInstructionsFlg, [Instruction]) -FLAG (TestSuiteFlg, FilePath) -FLAG (TimeoutFlg, Integer) -FLAG (VerboseModeFlg, ()) -FLAG (VersionFlg, ()) -FLAG (ViewCmdFlg, String) --- not to be exported (defaults) --- the WeirdFlg exists strictly to please OS X when you launch --- GenI in an application bundle (double-click)... for some --- reason it wants to pass an argument to -p -FLAG (BuilderFlg, BuilderType) -FLAG (GrammarTypeFlg, GrammarType) -FLAG (WeirdFlg, String) -\end{code} - - diff --git a/src/NLP/GenI/Console.hs b/src/NLP/GenI/Console.hs --- a/src/NLP/GenI/Console.hs +++ b/src/NLP/GenI/Console.hs @@ -18,51 +18,98 @@ -- | The console user interface including batch processing on entire -- test suites. -module NLP.GenI.Console(consoleGeni, runTestCaseOnly) where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Console ( consoleGeni, loadNextSuite ) where +import Control.Applicative ( pure, (<$>) ) 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 Data.List ( find, partition ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Text ( Text ) +import Data.Time ( getCurrentTime, formatTime ) +import Data.Typeable +import System.Log.Logger +import System.Locale ( defaultTimeLocale, iso8601DateFormat ) +import System.Directory( createDirectoryIfMissing, getTemporaryDirectory ) +import System.Exit ( exitWith, exitFailure, ExitCode(..) ) import System.FilePath ( (), takeFileName ) +import System.IO ( stderr ) +import System.Timeout ( timeout ) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T -import NLP.GenI.Btypes - ( SemInput, TestCase(tcSem, tcName) - ) -import qualified NLP.GenI.Btypes as G + import NLP.GenI.General - ( ePutStr, ePutStrLn, withTimeout, exitTimeout + ( ePutStr, ePutStrLn, ) -import NLP.GenI.Geni +import NLP.GenI import NLP.GenI.Configuration ( Params - , BatchDirFlg(..), DumpDerivationFlg(..), EarlyDeathFlg(..), FromStdinFlg(..), OutputFileFlg(..) - , MetricsFlg(..), RankingConstraintsFlg(..), StatsFileFlg(..) + , BatchDirFlg(..), DumpDerivationFlg(..), EarlyDeathFlg(..) + , MetricsFlg(..), RankingConstraintsFlg(..) , TestCaseFlg(..), TestSuiteFlg(..), TestInstructionsFlg(..) + , FromStdinFlg(..), OutputFileFlg(..), StatsFileFlg(..) , TimeoutFlg(..), VerboseModeFlg(..) , hasFlagP, getListFlagP, getFlagP, setFlagP , builderType , BuilderType(..) ) -import qualified NLP.GenI.Builder as B +import NLP.GenI.General ( mkLogname ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( SemInput ) import NLP.GenI.Simple.SimpleBuilder -import NLP.GenI.Statistics ( Statistics ) +import NLP.GenI.TestSuite ( TestCase(..) ) import Text.JSON import Text.JSON.Pretty ( render, pp_value ) consoleGeni :: ProgStateRef -> IO() consoleGeni pstRef = do - pst <- readIORef pstRef - loadEverything pstRef - case getFlagP TimeoutFlg (pa pst) of - Nothing -> runInstructions pstRef - Just t -> withTimeout t (timeoutErr t) $ runInstructions pstRef - where - timeoutErr t = do ePutStrLn $ "GenI timed out after " ++ (show t) ++ "s" - exitTimeout + config <- pa <$> readIORef pstRef + loadEverything pstRef + let job | hasFlagP FromStdinFlg config = runStdinTestCase pstRef + | hasFlagP BatchDirFlg config = runInstructions pstRef -- even if there is a testcase + | Just tc <- getFlagP TestCaseFlg config = runSpecificTestCase pstRef tc + | otherwise = runInstructions pstRef + case getFlagP TimeoutFlg config of + Nothing -> job + Just t -> withGeniTimeOut t job +withGeniTimeOut :: Int -- ^ seconds + -> IO () + -> IO () +withGeniTimeOut t job = do + status <- timeout (fromIntegral t * 1000000) job + case status of + Just () -> return () + Nothing -> do + ePutStrLn $ "GenI timed out after " ++ show t ++ "s" + exitWith (ExitFailure 2) + +-- | Run GenI without reading any test suites, just grab semantics from stdin +runStdinTestCase :: ProgStateRef -> IO () +runStdinTestCase pstRef = do + config <- pa <$> readIORef pstRef + mSemInput <- parseSemInput <$> getContents + case mSemInput of + Left err -> + fail $ "I didn't understand the semantics you gave me: " ++ show err + Right semInput -> + runOnSemInput pstRef (runAsStandalone config) semInput >> return () + +-- | Run a test case with the specified name +runSpecificTestCase :: ProgStateRef -> Text -> IO () +runSpecificTestCase pstRef cname = do + config <- pa <$> readIORef pstRef + fullsuite <- loadTestSuite pstRef + case find (\x -> tcName x == cname) fullsuite of + Nothing -> fail ("No such test case: " ++ T.unpack cname) + Just s -> runOnSemInput pstRef (runAsStandalone config) (tcSem s) >> return () + -- | Runs the tests specified in our instructions list. -- We assume that the grammar and lexicon are already -- loaded into the monadic state. @@ -72,123 +119,165 @@ runInstructions pstRef = do pst <- readIORef pstRef let config = pa pst - case getFlagP BatchDirFlg config of - Nothing -> runTestCaseOnly pstRef >> return () - Just bdir -> runBatch bdir + batchDir <- case getFlagP BatchDirFlg config of + Nothing -> do + t <- getTemporaryDirectory + utc <- fmtTime <$> getCurrentTime + return (t "geni-" ++ utc) + Just bdir -> return bdir + runBatch batchDir + unless (hasFlagP BatchDirFlg config) $ do + ePutStr $ unlines [ "" + , "Results saved to directory " ++ batchDir + , "To save results in a different directory, use the --batchdir flag" + ] where - runBatch bdir = - do config <- pa `fmap` readIORef pstRef - mapM_ (runSuite bdir) $ getListFlagP TestInstructionsFlg config - runSuite bdir (file, mtcs) = - do modifyIORef pstRef $ \p -> p { pa = setFlagP TestSuiteFlg file (pa p) } - config <- pa `fmap` readIORef pstRef + fmtTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M")) + runBatch bdir = do + config <- pa <$> readIORef pstRef + mapM_ (runSuite bdir) $ + getListFlagP TestInstructionsFlg config + runSuite bdir next@(file, _) = + do suite <- loadNextSuite pstRef next -- we assume the that the suites have unique filenames let bsubdir = bdir takeFileName file - createDirectoryIfMissing False bsubdir - fullsuite <- loadTestSuite pstRef - let suite = case (mtcs, getFlagP TestCaseFlg config) of - (_, Just c) -> filter (\t -> tcName t == c) fullsuite - (Nothing,_) -> fullsuite - (Just cs,_) -> filter (\t -> tcName t `elem` cs) fullsuite - if any null $ map tcName suite + createDirectoryIfMissing True bsubdir + if any (T.null . tcName) suite then fail $ "Can't do batch processing. The test suite " ++ file ++ " has cases with no name." else do ePutStrLn "Batch processing mode" mapM_ (runCase bsubdir) suite - runCase bdir (G.TestCase { tcName = n, tcSem = s }) = + runCase bdir (TestCase { tcName = n, tcSem = s }) = do config <- pa `fmap` readIORef pstRef let verbose = hasFlagP VerboseModeFlg config earlyDeath = hasFlagP EarlyDeathFlg config when verbose $ ePutStrLn "======================================================" - (res , _) <- runOnSemInput pstRef (PartOfSuite n bdir) s - ePutStrLn $ " " ++ n ++ " - " ++ (show $ length res) ++ " results" + gresults <- runOnSemInput pstRef (PartOfSuite n bdir) s + let res = grResults gresults + (goodres, badres) = partition isSuccess (grResults gresults) + T.hPutStrLn stderr $ + " " <> n <+> "-" <+> pretty (length goodres) <+> "results" <+> + parens (pretty (length badres)) when (null res && earlyDeath) $ do - ePutStrLn $ "Exiting early because test case " ++ n ++ " failed." - exitFailure + T.hPutStrLn stderr $ "Exiting early because test case" <+> n <+> "failed." + exitFailure --- | 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 +-- | Used in processing instructions files. Each instruction consists of a +-- suite file and a list of test case names from that file +-- +-- See for +-- how testsuite, testcase, and instructions are expected to interact +-- +-- (Exported for use by regression testing code) +loadNextSuite :: ProgStateRef -> (FilePath, Maybe [Text]) -> IO [TestCase] +loadNextSuite pstRef (file, mtcs) = do + debugM logname $ "Loading next test suite: " ++ file + debugM logname $ "Test case filter: " ++ maybe "none" (\xs -> show (length xs) ++ " items") mtcs + modifyIORef pstRef $ \p -> p { pa = setFlagP TestSuiteFlg file (pa p) } -- yucky statefulness! :-( + config <- pa `fmap` readIORef pstRef + let mspecific = getFlagP TestCaseFlg config + debugM logname . T.unpack $ "Test case to pick out:" <+> fromMaybe "none" mspecific + fullsuite <- loadTestSuite pstRef + return (filterSuite mtcs mspecific fullsuite) + where + filterSuite _ (Just c) suite = filter (\t -> tcName t == c) suite + filterSuite Nothing Nothing suite = suite + filterSuite (Just cs) Nothing suite = filter (\t -> tcName t `elem` cs) suite data RunAs = Standalone FilePath FilePath - | PartOfSuite String FilePath + | PartOfSuite Text FilePath +runAsStandalone :: Params -> RunAs +runAsStandalone config = + Standalone (fromMaybe "" $ getFlagP OutputFileFlg config) + (fromMaybe "" $ getFlagP StatsFileFlg config) + -- | 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, warnings = []}) - pst <- readIORef pstRef - let config = pa pst - dump = hasFlagP DumpDerivationFlg config - useRanking = hasFlagP RankingConstraintsFlg config - (results, stats) <- case builderType config of - NullBuilder -> helper B.nullBuilder - SimpleBuilder -> helper simpleBuilder_2p - SimpleOnePhaseBuilder -> helper simpleBuilder_1p - warningsOut <- warnings `fmap` readIORef pstRef - -- 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" - doWrite = case args of - Standalone _ _ -> const (return ()) - PartOfSuite n f -> writeFile $ f n "derivations" - soWrite = case args of - Standalone _ "" -> putStrLn - Standalone _ f -> writeFile f - PartOfSuite n f -> writeFile $ f n "stats" - -- - if dump - then oWrite . ppJSON $ results - else if useRanking - then oWrite . unlines . map (prettyResult pst) $ results - else oWrite . unlines . sort . concatMap grRealisations $ results - doWrite . ppJSON $ results - -- print any warnings we picked up along the way - when (not $ null warningsOut) $ - do let ws = reverse warningsOut - ePutStr $ "Warnings:\n" ++ (unlines $ map (\x -> " - " ++ x) ws) - case args of - PartOfSuite n f -> writeFile (f n "warnings") $ unlines ws - _ -> return () - -- print out statistical data (if available) - when (isJust $ getFlagP MetricsFlg config) $ soWrite (ppJSON stats) - -- - return (results, stats) + -> IO GeniResults +runOnSemInput pstRef args semInput = do + pst <- readIORef pstRef + case builderType (pa pst) of + SimpleBuilder -> helper pst simpleBuilder_2p + SimpleOnePhaseBuilder -> helper pst simpleBuilder_1p where - ppJSON :: JSON a => a -> String - ppJSON = render . pp_value . showJSON - helper builder = - do (results, stats, _) <- runGeni pstRef builder - return (results, stats) + helper pst builder = do + (res,_) <- runGeni pstRef semInput builder + writeResults pst args semInput res + return res +-- | Not just the global warnings but the ones local to each response too +allWarnings :: GeniResults -> [Text] +allWarnings res = concat $ grGlobalWarnings res + : [ grWarnings s | GSuccess s <- grResults res ] + +writeResults :: ProgState -> RunAs -> SemInput -> GeniResults -> IO () +writeResults pst args semInput gresults = do + -- create output directory as needed + case args of + PartOfSuite n f -> createDirectoryIfMissing True (f T.unpack n) + _ -> return () + -- print responses + if dump + then writeResponses $ ppJSON results + else writeResponses $ T.unlines . concatMap (fromResult formatResponses) $ results + -- print out statistical data (if available) + when (isJust $ getFlagP MetricsFlg config) $ + writeStats (ppJSON stats) + -- print any warnings we picked up along the way + unless (null warnings) $ do + T.hPutStrLn stderr $ "Warnings:\n" <> formatWarnings warnings + writeBatchFile "warnings" $ T.unlines warnings + -- other outputs when run in batch mode + writeBatchFile "semantics" $ pretty semInput + writeBatchFile "derivations"$ ppJSON results + where + results = grResults gresults + warnings = allWarnings gresults + stats = grStatistics gresults + config = pa pst + dump = hasFlagP DumpDerivationFlg config + -- do we print ranking information and all that other jazz? + formatResponses = if hasFlagP RankingConstraintsFlg config + then pure . prettyResult pst + else grRealisations + formatWarnings = T.unlines . map (" - " <>) + -- + writeBatchFile key = case args of + Standalone _ _ -> const (return ()) + PartOfSuite n f -> writeFileUtf8 (f T.unpack n key) + writeResponses = case args of + Standalone "" _ -> putStrLnUtf8 + Standalone f _ -> writeFileUtf8 f + PartOfSuite _ _ -> writeBatchFile "responses" + writeStats = case args of + Standalone _ "" -> putStrLnUtf8 + Standalone _ f -> writeFileUtf8 f + PartOfSuite _ _ -> writeBatchFile "stats" + -- + fromResult :: (GeniSuccess -> [Text]) -> GeniResult -> [Text] + fromResult _ (GError errs) = [ pretty errs ] + fromResult f (GSuccess x) = f x + +-- | TODO: If somebody puts together a render function that emits Data.Text +-- we should just use that instead +ppJSON :: JSON a => a -> Text +ppJSON = T.pack . render . pp_value . showJSON + +writeFileUtf8 :: FilePath -> Text -> IO () +writeFileUtf8 f = B.writeFile f . T.encodeUtf8 + +putStrLnUtf8 :: Text -> IO () +putStrLnUtf8 = B.putStr . T.encodeUtf8 . (<> "\n") + +-- ---------------------------------------------------------------------- +-- Odds and ends +-- ---------------------------------------------------------------------- + +data MNAME = MNAME deriving Typeable +logname :: String +logname = mkLogname MNAME diff --git a/src/NLP/GenI/FeatureStructure.hs b/src/NLP/GenI/FeatureStructure.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/FeatureStructure.hs @@ -0,0 +1,186 @@ +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.FeatureStructure where + +import Data.Binary +import Data.Function (on) +import Data.Generics (Data) +import Data.List (sortBy) +import qualified Data.Map as Map +import Data.Typeable (Typeable) +import Data.Text ( Text ) +import qualified Data.Text as T + +import NLP.GenI.GeniShow +import NLP.GenI.GeniVal +import NLP.GenI.General ( geniBug ) +import NLP.GenI.Pretty + +import Control.DeepSeq + +-- ---------------------------------------------------------------------- +-- Core types +-- ---------------------------------------------------------------------- + +type Flist a = [AvPair a] +data AvPair a = AvPair { avAtt :: Text + , avVal :: a } + deriving (Ord, Eq, Data, Typeable) + +-- experimental, alternative representation of Flist +-- which guarantees uniqueness of keys +type FeatStruct a = Map.Map Text a + +emptyFeatStruct :: FeatStruct a +emptyFeatStruct = Map.empty + +mkFeatStruct :: Flist GeniVal -> FeatStruct GeniVal +mkFeatStruct fs = Map.fromListWith oops . map fromPair $ fs + where + fromPair (AvPair a v) = (a,v) + oops _ _ = geniBug $ + "I've allowed a feature structure with multiple versions of a key" + ++ " to sneak through: " ++ prettyStr fs + +fromFeatStruct :: FeatStruct a -> Flist a +fromFeatStruct = sortFlist . map (uncurry AvPair) . Map.toList + +-- if we decide to move over to this representation of feature structures +-- we can get rid of showFlist, etc and probably just use toAscList +instance Pretty (FeatStruct GeniVal) where + pretty = pretty . fromFeatStruct + +instance GeniShow (FeatStruct GeniVal) where + geniShowText = geniShowText . fromFeatStruct + +-- ---------------------------------------------------------------------- +-- Basic functions +-- ---------------------------------------------------------------------- + +-- | Sort an Flist according with its attributes +sortFlist :: Flist a -> Flist a +sortFlist = sortBy (compare `on` avAtt) + +-- Traversal + +instance DescendGeniVal v => DescendGeniVal (AvPair v) where + descendGeniVal s (AvPair a v) = {-# SCC "descendGeniVal" #-} AvPair a (descendGeniVal s v) + +instance DescendGeniVal a => DescendGeniVal (String, a) where + descendGeniVal s (n,v) = {-# SCC "descendGeniVal" #-} (n,descendGeniVal s v) + +instance DescendGeniVal v => DescendGeniVal ([String], Flist v) where + descendGeniVal s (a,v) = {-# SCC "descendGeniVal" #-} (a, descendGeniVal s v) + +instance Collectable a => Collectable (AvPair a) where + collect (AvPair _ b) = collect b + +-- Pretty printing and output format + +instance Pretty (Flist GeniVal) where + pretty = geniShowText + +instance Pretty (AvPair GeniVal) where + pretty = geniShowText + +instance GeniShow (Flist GeniVal) where + geniShowText = squares . T.unwords . map geniShowText + +instance GeniShow (AvPair GeniVal) where + geniShowText (AvPair a v) = a `T.append` ":" `T.append` geniShowText v + +{- +instance Show (AvPair GeniVal) where + show = showAv +-} + +-- -------------------------------------------------------------------- +-- Feature structure unification +-- -------------------------------------------------------------------- + +-- | 'unifyFeat' performs feature structure unification, under the +-- these assumptions about the input: +-- +-- * Features are ordered +-- +-- * The Flists do not share variables (renaming has already +-- been done. +-- +-- The features are allowed to have different sets of attributes, +-- beacuse we use 'alignFeat' to realign them. +unifyFeat :: Monad m => Flist GeniVal -> Flist GeniVal -> m (Flist GeniVal, Subst) +unifyFeat f1 f2 = + {-# SCC "unification" #-} + let (att, val1, val2) = unzip3 $ alignFeat f1 f2 + in att `seq` + do (res, subst) <- unify val1 val2 + return (zipWith AvPair att res, subst) + +-- | 'alignFeat' is a pre-procesing step used to ensure that feature structures +-- have the same set of keys. If a key is missing in one, we copy it to the +-- other with an anonymous value. +-- +-- The two feature structures must be sorted for this to work +alignFeat :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)] +alignFeat f1 f2 = alignFeatH f1 f2 [] + +alignFeatH :: Flist GeniVal -> Flist GeniVal -> [(Text,GeniVal,GeniVal)] -> [(Text,GeniVal,GeniVal)] +alignFeatH [] [] acc = reverse acc +alignFeatH [] (AvPair f v :x) acc = alignFeatH [] x ((f,mkGAnon,v) : acc) +alignFeatH x [] acc = alignFeatH [] x acc +alignFeatH fs1@(AvPair f1 v1:l1) fs2@(AvPair f2 v2:l2) acc = + case compare f1 f2 of + EQ -> alignFeatH l1 l2 ((f1, v1, v2) : acc) + LT -> alignFeatH l1 fs2 ((f1, v1, mkGAnon) : acc) + GT -> alignFeatH fs1 l2 ((f2, mkGAnon, v2) : acc) + +-- -------------------------------------------------------------------- +-- Fancy disjunction +-- -------------------------------------------------------------------- + +crushAvPair :: AvPair [GeniVal] -> Maybe (AvPair GeniVal) +crushAvPair (AvPair a v) = AvPair a `fmap` crushOne v + +crushFlist :: Flist [GeniVal] -> Maybe (Flist GeniVal) +crushFlist = mapM crushAvPair + +{-! +deriving instance Binary AvPair +deriving instance NFData AvPair +!-} + +-- GENERATED START + + +instance (Binary a) => Binary (AvPair a) where + put (AvPair x1 x2) + = do put x1 + put x2 + get + = do x1 <- get + x2 <- get + return (AvPair x1 x2) + + +instance (NFData a) => NFData (AvPair a) where + rnf (AvPair x1 x2) = rnf x1 `seq` rnf x2 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/Flag.hs b/src/NLP/GenI/Flag.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Flag.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This module can be treated as public domain + +module NLP.GenI.Flag where + +-- This module exists purely for the purpose of making it more convenient +-- to modify the flag set in GenI (by eliminating the need to explicitly +-- export the types for individual flags). To add a flag: +-- +-- 1. add a type here +-- 2. write the help text in NLP.GenI.Configuration +-- 3. add the getopt stuff and find a section for the flag + +import Data.List ( find ) +import qualified Data.Set as Set +import Data.Maybe ( catMaybes, fromJust ) +import Data.Text ( Text ) +import Data.Typeable + +import NLP.GenI.FeatureStructure ( Flist ) +import NLP.GenI.GeniVal ( GeniVal ) +import NLP.GenI.Polarity.Types + +-- ---------------------------------------------------------------------- +-- configuration stuff +-- this stuff really belongs in NLP.GenI.Configuration but we move it here +-- to avoid an import cycle (sigh) +-- ---------------------------------------------------------------------- + +data Optimisation = PolOpts + | AdjOpts + | Polarised + | NoConstraints + deriving (Show,Eq,Typeable) + +type Instruction = (FilePath, Maybe [Text]) + +data BuilderType = SimpleBuilder | SimpleOnePhaseBuilder + deriving (Eq, Typeable) + +data GrammarType = GeniHand -- ^ geni's text format + | PreCompiled -- ^ built into geni, no parsing needed + | PreAnchored -- ^ lexical selection already done + deriving (Show, Eq, Typeable) + +instance Show BuilderType where + show SimpleBuilder = "simple-2p" + show SimpleOnePhaseBuilder = "simple-1p" + +-- ---------------------------------------------------------------------- +-- flag core +-- ---------------------------------------------------------------------- + +{- | +Flags are GenI's internal representation of command line arguments. We +use phantom existential types (?) for representing GenI flags. This +makes it simpler to do things such as ``get the value of the MacrosFlg'' +whilst preserving type safety (we always know that MacrosFlg is +associated with String). The alternative would be writing getters and +setters for each flag, and that gets really boring after a while. +-} +data Flag = forall f x . (Eq f, Typeable f, Typeable x) => + Flag (x -> f) x deriving (Typeable) + +{- +instance Show Flag where + show (Flag f x) = "Flag " ++ show (f x) +-} + +instance Eq Flag where + (Flag f1 x1) == (Flag f2 x2) + | (typeOf f1 == typeOf f2) && (typeOf x1 == typeOf x2) = + (fromJust . cast . f1 $ x1) == (f2 x2) + | otherwise = False + +isFlag :: (Typeable f, Typeable x) => (x -> f) -> Flag -> Bool +isFlag f1 (Flag f2 _) = typeOf f1 == typeOf f2 + +hasFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> Bool +hasFlag = any . isFlag + +deleteFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> [Flag] +deleteFlag f = filter (not.(isFlag f)) + +-- | This only has an effect if the flag is set +modifyFlag :: (Eq f, Typeable f, Typeable x) => (x -> f) -> (x -> x) -> [Flag] -> [Flag] +modifyFlag f m fs = + case getFlag f fs of + Nothing -> fs + Just v -> setFlag f (m v) fs + +setFlag :: (Eq f, Typeable f, Typeable x) => (x -> f) -> x -> [Flag] -> [Flag] +setFlag f v fs = (Flag f v) : tl where tl = deleteFlag f fs + +getFlag :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> Maybe x +getFlag f fs = do (Flag _ v) <- find (isFlag f) fs ; cast v + +getAllFlags :: (Typeable f, Typeable x) => (x -> f) -> [Flag] -> [x] +getAllFlags f fs = catMaybes [ cast v | flg@(Flag _ v) <- fs, isFlag f flg ] + +-- ---------------------------------------------------------------------- +-- Below are just the individual flags, which unfortunately have to be +-- defined as separate data types because of our fancy existential +-- data type code. +-- ---------------------------------------------------------------------- + +newtype BatchDirFlg = BatchDirFlg FilePath deriving (Eq, Typeable) +newtype DisableGuiFlg = DisableGuiFlg () deriving (Eq, Typeable) +newtype DetectPolaritiesFlg = DetectPolaritiesFlg (Set.Set PolarityAttr) deriving (Eq, Typeable) +newtype DumpDerivationFlg = DumpDerivationFlg () deriving (Eq, Typeable) +newtype EarlyDeathFlg = EarlyDeathFlg () deriving (Eq, Typeable) +newtype FromStdinFlg = FromStdinFlg () deriving (Eq, Typeable) +newtype HelpFlg = HelpFlg () deriving (Eq, Typeable) +newtype InstructionsFileFlg = InstructionsFileFlg FilePath deriving (Eq, Typeable) +newtype LexiconFlg = LexiconFlg FilePath deriving (Eq, Typeable) +newtype MacrosFlg = MacrosFlg FilePath deriving (Eq, Typeable) +newtype TracesFlg = TracesFlg FilePath deriving (Eq, Typeable) +newtype MaxStepsFlg = MaxStepsFlg Integer deriving (Eq, Typeable) +newtype MaxResultsFlg = MaxResultsFlg Integer deriving (Eq, Typeable) +newtype MetricsFlg = MetricsFlg [String] deriving (Eq, Typeable) +newtype MorphCmdFlg = MorphCmdFlg String deriving (Eq, Typeable) +newtype MorphInfoFlg = MorphInfoFlg FilePath deriving (Eq, Typeable) +newtype OptimisationsFlg = OptimisationsFlg [Optimisation] deriving (Eq, Typeable) +newtype OutputFileFlg = OutputFileFlg String deriving (Eq, Typeable) +newtype PartialFlg = PartialFlg () deriving (Eq, Typeable) +newtype RankingConstraintsFlg = RankingConstraintsFlg FilePath deriving (Eq, Typeable) +newtype RootFeatureFlg = RootFeatureFlg (Flist GeniVal) deriving (Eq, Typeable) +newtype NoLoadTestSuiteFlg = NoLoadTestSuiteFlg () deriving (Eq, Typeable) +newtype StatsFileFlg = StatsFileFlg FilePath deriving (Eq, Typeable) +newtype TestCaseFlg = TestCaseFlg Text deriving (Eq, Typeable) +newtype TestInstructionsFlg = TestInstructionsFlg [Instruction] deriving (Eq, Typeable) +newtype TestSuiteFlg = TestSuiteFlg FilePath deriving (Eq, Typeable) +newtype TimeoutFlg = TimeoutFlg Int deriving (Eq, Typeable) +newtype VerboseModeFlg = VerboseModeFlg () deriving (Eq, Typeable) +newtype VersionFlg = VersionFlg () deriving (Eq, Typeable) +newtype ViewCmdFlg = ViewCmdFlg String deriving (Eq, Typeable) +newtype BuilderFlg = BuilderFlg BuilderType deriving (Eq, Typeable) +newtype GrammarTypeFlg = GrammarTypeFlg GrammarType deriving (Eq, Typeable) +-- the WeirdFlg exists strictly to please OS X when you launch +-- GenI in an application bundle (double-click)... for some +-- reason it wants to pass an argument to -p +newtype WeirdFlg = WeirdFlg String deriving (Eq, Typeable) diff --git a/src/NLP/GenI/General.hs b/src/NLP/GenI/General.hs --- a/src/NLP/GenI/General.hs +++ b/src/NLP/GenI/General.hs @@ -20,30 +20,30 @@ -- to replace these functions with versions that are available in the standard -- libraries, or the Haskell platform ones, or on hackage. +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} module NLP.GenI.General ( -- * IO ePutStr, ePutStrLn, eFlush, - -- ** Strict readFile - readFile', - lazySlurp, - -- ** Timeouts - withTimeout, - exitTimeout, -- * Strings + isGeniIdentLetter, dropTillIncluding, trim, toUpperHead, toLowerHead, toAlphaNum, + quoteString, quoteText, + clumpBy, -- * Triples + first3, second3, third3, fst3, snd3, thd3, -- * Lists map', - boundsCheck, + buckets, isEmptyIntersect, groupByFM, - multiGroupByFM, insertToListMap, - groupAndCount, + histogram, combinations, mapMaybeM, repList, @@ -57,32 +57,31 @@ -- * Bit vectors BitVector, showBitVector, - -- * Bugs + -- * Errors, logging and exceptions geniBug, + prettyException, + mkLogname, ) where +import Control.Arrow (first) +import Control.Exception (IOException) import Control.Monad (liftM) import Data.Bits (shiftR, (.&.)) -import Data.Char (isDigit, isSpace, toUpper, toLower) +import Data.Char (isAlphaNum, isDigit, isSpace, toUpper, toLower) import Data.Function ( on ) -import Data.List (foldl', intersect, groupBy, group, sort) +import Data.List (foldl', intersect, inits, intersperse, groupBy, sortBy) +import Data.Typeable ( typeOf, Typeable ) import Data.Tree import System.IO (hPutStrLn, hPutStr, hFlush, stderr) +import System.IO.Error (isUserError, ioeGetErrorString) import qualified Data.Map as Map - --- for timeout -import Control.Concurrent -import Control.Exception -import Data.Dynamic(Typeable, typeOf, TyCon, mkTyCon, mkTyConApp, toDyn) -import Data.Unique -import System.Exit(exitWith, ExitCode(ExitFailure)) - --- for non-lazy IO -import System.IO (openFile, IOMode(ReadMode), hFileSize, hGetBuf) -import System.IO.Unsafe (unsafeInterleaveIO) -import Foreign (mallocForeignPtrBytes, withForeignPtr, ForeignPtr, Ptr, peekElemOff, plusPtr, Word8) -import Data.Char (chr) +import Prelude hiding ( catch ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Binary +import Text.JSON -- ---------------------------------------------------------------------- -- IO @@ -102,6 +101,13 @@ -- Strings -- ---------------------------------------------------------------------- +instance Binary Text where + put = put . T.encodeUtf8 + get = liftM T.decodeUtf8 get + +isGeniIdentLetter :: Char -> Bool +isGeniIdentLetter x = isAlphaNum x || x `elem` "_'+-." + trim :: String -> String trim = reverse . (dropWhile isSpace) . reverse . (dropWhile isSpace) @@ -119,6 +125,44 @@ toLowerHead [] = [] toLowerHead(h:t) = (toLower h):t +quoteString :: String -> String +quoteString xs = "\"" ++ concatMap helper xs ++ "\"" + where + helper '"' = [ '\\', '\"' ] + helper '\\' = [ '\\', '\\' ] + helper x = [ x ] + +quoteText :: Text -> Text +quoteText t = + q `T.append` escape t `T.append` q + where + escape = T.replace q escQ . T.replace s escS + q = "\"" + s = "\\" + escQ = s `T.append` q + escS = s `T.append` s + +-- | break a list of items into sublists of length < the clump +-- size, taking into consideration that each item in the clump +-- will have a single gap of padding interspersed +-- +-- any item whose length is greater than the clump size +-- is put into a clump by itself +-- +-- given a length function +-- @clumpBy (length.show) 8 ["hello", "this", "is", "a", "list"]@ +clumpBy :: (a -> Int) -> Int -> [a] -> [[a]] +clumpBy f l items = iter [] items + where + iter acc [] = reverse acc + iter acc cs = + case break toobig (drop 1 $ inits cs) of + ([],_) -> next 1 -- first too big + (_,[]) -> iter (cs:acc) [] -- none too big + (_,(x:_)) -> next (length x - 1) + where next n = iter (take n cs : acc) (drop n cs) + toobig x = (sum . intersperse 1 . map f) x > l + -- ---------------------------------------------------------------------- -- Alphanumeric sort -- ---------------------------------------------------------------------- @@ -149,6 +193,15 @@ -- Triples -- ---------------------------------------------------------------------- +first3 :: (a -> a2) -> (a, b, c) -> (a2, b, c) +first3 f (x,y,z) = (f x, y, z) + +second3 :: (b -> b2) -> (a, b, c) -> (a, b2, c) +second3 f (x,y,z) = (x, f y, z) + +third3 :: (c -> c2) -> (a, b, c) -> (a, b, c2) +third3 f (x,y,z) = (x, y, f z) + fst3 :: (a,b,c) -> a fst3 (x,_,_) = x @@ -167,11 +220,6 @@ map' _ [] = [] map' f (x:xs) = let a = f x in a `seq` (a:(map' f xs)) --- | Makes sure that index s is in the bounds of list l. --- Surely there must be some more intelligent way to deal with this. -boundsCheck :: Int -> [a] -> Bool -boundsCheck s l = s >= 0 && s < length l - -- | True if the intersection of two lists is empty. isEmptyIntersect :: (Eq a) => [a] -> [a] -> Bool isEmptyIntersect a b = null $ intersect a b @@ -189,15 +237,6 @@ helper acc x = addfn x acc (fn x) in foldl' helper Map.empty list --- | Same as 'groupByFM', except that we let an item appear in --- multiple groups. The fn extracts the property from the item, --- and returns multiple results in the form of a list -multiGroupByFM :: (Ord b) => (a -> [b]) -> [a] -> (Map.Map b [a]) -multiGroupByFM fn list = - let addfn x acc key = insertToListMap key x acc - helper acc x = foldl' (addfn x) acc (fn x) - in foldl' helper Map.empty list - {-# INLINE insertToListMap #-} insertToListMap :: (Ord b) => b -> a -> Map.Map b [a] -> Map.Map b [a] insertToListMap k i m = @@ -205,14 +244,15 @@ Nothing -> Map.insert k [i] m Just p -> Map.insert k (i:p) m --- | Convert a list of items into a list of tuples (a,b) where --- a is an item in the list and b is the number of times a --- in occurs in the list. -groupAndCount :: (Eq a, Ord a) => [a] -> [(a, Int)] -groupAndCount xs = - map (\x -> (head x, length x)) grouped - where grouped = (group.sort) xs +histogram :: Ord a => [a] -> Map.Map a Int +histogram xs = Map.fromListWith (+) $ zip xs (repeat 1) +buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ] +buckets f = map (first head . unzip) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\x -> (f x, x)) + -- Given a list of lists, return all lists such that one item from each sublist is chosen. -- If returns the empty list if there are any empty sublists. combinations :: [[a]] -> [[a]] @@ -256,9 +296,10 @@ -- | Return pairs of (parent, terminal) preTerminals :: Tree a -> [(a,a)] -preTerminals (Node _ []) = [] -preTerminals (Node x ks) = - [ (x,y) | (Node y ys) <- ks, null ys ] ++ concatMap preTerminals ks +preTerminals (Node r xs) = concatMap (helper r) xs + where + helper p (Node k []) = [ (p,k) ] + helper _ (Node p ys) = concatMap (helper p) ys -- | 'repNode' @fn filt t@ returns a version of @t@ in which the first -- node which @filt@ matches is transformed using @fn@. @@ -307,7 +348,7 @@ _ -> geniBug "Unexpected result in repNode" -- ---------------------------------------------------------------------- --- Errors +-- Errors, exceptions and logging -- ---------------------------------------------------------------------- -- | errors specifically in GenI, which is very likely NOT the user's fault. @@ -315,6 +356,15 @@ geniBug s = error $ "Bug in GenI!\n" ++ s ++ "\nPlease file a report on http://trac.haskell.org/GenI/newticket" +-- stolen from Darcs +prettyException :: IOException -> String +prettyException e | isUserError e = ioeGetErrorString e +prettyException e = show e + +-- | The module name for an arbitrary data type +mkLogname :: Typeable a => a -> String +mkLogname = reverse . drop 1 . dropWhile (/= '.') . reverse + . show . typeOf -- ---------------------------------------------------------------------- -- Intervals -- ---------------------------------------------------------------------- @@ -349,75 +399,9 @@ showBitVector min_ x = showBitVector (min_ - 1) (shiftR x 1) ++ (show $ x .&. 1) -- ---------------------------------------------------------------------- --- Strict readfile --- Simon Marlow wrote this code on the Haskell mailing list 2005-08-02. --- ---------------------------------------------------------------------- - --- | Using readFile' can be a good idea if you're dealing with not-so-huge --- files (i.e. where you don't want lazy evaluation), because it ensures --- that the handles are closed. No more ``too many open files'' -readFile' :: FilePath -> IO String -readFile' f = do - h <- openFile f ReadMode - s <- hFileSize h - fp <- mallocForeignPtrBytes (fromIntegral s) - len <- withForeignPtr fp $ \buf -> hGetBuf h buf (fromIntegral s) - lazySlurp fp 0 len - -buf_size :: Int -buf_size = 4096 :: Int - -lazySlurp :: ForeignPtr Word8 -> Int -> Int -> IO String -lazySlurp fp ix len - | fp `seq` False = undefined - | ix >= len = return [] - | otherwise = do - cs <- unsafeInterleaveIO (lazySlurp fp (ix + buf_size) len) - ws <- withForeignPtr fp $ \p -> loop (min (len-ix) buf_size - 1) - ((p :: Ptr Word8) `plusPtr` ix) cs - return ws - where - loop :: Int -> Ptr Word8 -> String -> IO String - loop sublen p acc - | sublen `seq` p `seq` False = undefined - | sublen < 0 = return acc - | otherwise = do - w <- peekElemOff p sublen - loop (sublen-1) p (chr (fromIntegral w):acc) - --- ---------------------------------------------------------------------- --- Timeouts +-- JSON -- ---------------------------------------------------------------------- -data TimeOut = TimeOut Unique - -timeOutTc :: TyCon -timeOutTc = mkTyCon "TimeOut" - -instance Typeable TimeOut where - typeOf _ = mkTyConApp timeOutTc [] - -withTimeout :: Integer - -> IO a -- ^ action to run upon timing out - -> IO a -- ^ main action to run - -> IO a -withTimeout secs on_timeout action = - do parent <- myThreadId - i <- newUnique - block $ do - timeout <- forkIO (timeout_thread secs parent i) - Control.Exception.catchDyn - ( unblock $ do result <- action - killThread timeout - return result ) - ( \ex -> case ex of - TimeOut u | u == i -> unblock on_timeout - _ -> killThread timeout >>= throwDyn ex ) - where - timeout_thread secs_ parent i = - do threadDelay $ (fromInteger secs_) * 1000000 - throwTo parent (DynException $ toDyn $ TimeOut i) - --- | Like 'exitFailure', except that we return with a code that we reserve for timing out -exitTimeout :: IO () -exitTimeout = exitWith $ ExitFailure 2 +instance JSON Text where + readJSON = fmap T.pack . readJSON + showJSON = showJSON . T.unpack diff --git a/src/NLP/GenI/Geni.lhs b/src/NLP/GenI/Geni.lhs deleted file mode 100644 --- a/src/NLP/GenI/Geni.lhs +++ /dev/null @@ -1,1149 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Geni} -\label{cha:Geni} - -Geni is the interface between the front and backends of the generator. The GUI -and the console interface both talk to this module, and in turn, this module -talks to the input file parsers and the surface realisation engine. This -module also does lexical selection and anchoring because these processes might -involve some messy IO performance tricks. - -\begin{code} -module NLP.GenI.Geni ( - -- * main interface - ProgState(..), ProgStateRef, emptyProgState, - initGeni, - runGeni, runGeniWithSelector, - GeniResult(..), ResultType(..), - -- * helpers - lemmaSentenceString, prettyResult, - showRealisations, groupAndCount, - getTraces, Selector, - loadEverything, loadLexicon, loadGeniMacros, - loadTestSuite, loadTargetSemStr, - loadRanking, readRanking, - combine, - - -- used by auxiliary tools only - chooseLexCand, - ) -where -\end{code} - -\ignore{ -\begin{code} -import Control.Applicative ((<$>),(<*>)) -import Control.Arrow ((&&&)) -import Control.Monad.Error -import Control.Monad (unless) - -import Data.Binary (Binary, decodeFile) -import Data.Function ( on ) -import Data.IORef (IORef, readIORef, modifyIORef) -import Data.List -import Data.List.Split ( wordsBy ) -import qualified Data.Map as Map -import Data.Maybe (mapMaybe, fromMaybe, isJust) -import Data.Tree (Tree(Node)) -import Data.Typeable (Typeable) - -import qualified System.IO.UTF8 as UTF8 - -import System.IO.Unsafe (unsafePerformIO) -import Text.JSON --- import System.Process - - -import NLP.GenI.General(filterTree, repAllNode, - groupAndCount, multiGroupByFM, - geniBug, - repNodeByNode, - fst3, - ePutStr, ePutStrLn, eFlush, - ) - -import NLP.GenI.Btypes - (Macros, MTtree, ILexEntry, Lexicon, - replace, replaceList, - Sem, SemInput, TestCase(..), sortSem, subsumeSem, params, - GeniVal(GConst), fromGVar, AvPair(..), - GNode(ganchor, gnname, gup, gdown, gaconstr, gtype, gorigin), - GType(Subs, Other), - isemantics, ifamname, iword, iparams, iequations, - iinterface, ifilters, - isempols, - toKeys, - showLexeme, showSem, - pidname, pfamily, pinterface, ptype, psemantics, ptrace, - setAnchor, setLexeme, tree, unifyFeat, - alphaConvert, - ) -import NLP.GenI.BtypesBinary () - -import NLP.GenI.Tags (Tags, TagElem, emptyTE, - idname, ttreename, - ttype, tsemantics, ttree, tsempols, - tinterface, ttrace, - setTidnums) - -import NLP.GenI.Configuration - ( Params, getFlagP, hasFlagP, hasOpt, Optimisation(NoConstraints) - , MacrosFlg(..), LexiconFlg(..), TestSuiteFlg(..), TestCaseFlg(..) - , MorphInfoFlg(..), MorphCmdFlg(..) - , RankingConstraintsFlg(..) - , PartialFlg(..) - , FromStdinFlg(..), VerboseModeFlg(..) - , NoLoadTestSuiteFlg(..) - , TracesFlg(..) - , grammarType - , GrammarType(..) ) - -import qualified NLP.GenI.Builder as B - -import NLP.GenI.GeniParsers (geniMacros, geniTagElems, - geniLexicon, geniTestSuite, - geniTestSuiteString, geniSemanticInput, - geniMorphInfo, - parseFromFile, runParser, Parser, - ) -import NLP.GenI.Morphology -import NLP.GenI.OptimalityTheory -import NLP.GenI.Statistics (Statistics) - --- import CkyBuilder --- import SimpleBuilder (simpleBuilder) -\end{code} -} - -\begin{code} -myEMPTY :: String -myEMPTY = "MYEMPTY" -\end{code} - -% -------------------------------------------------------------------- -\section{ProgState} -% -------------------------------------------------------------------- - -\begin{code} -data ProgState = ST{ -- | the current configuration being processed - pa :: Params, - -- - gr :: Macros, - le :: Lexicon, - morphinf :: MorphFn, - ts :: SemInput, - -- | names of test case to run - tcase :: String, - -- | name, original string (for gui), sem - tsuite :: [TestCase], - -- | OT constraints (optional) - ranking :: OtRanking, - -- | simplified traces (optional) - traces :: [String], - -- | any warnings accumulated during realisation - -- (most recent first) - warnings :: [String] - } - -type ProgStateRef = IORef ProgState - --- | The program state when you start GenI for the very first time -emptyProgState :: Params -> ProgState -emptyProgState args = - ST { pa = args - , gr = [] - , le = Map.empty - , morphinf = const Nothing - , ts = ([],[],[]) - , tcase = [] - , tsuite = [] - , traces = [] - , ranking = [] - , warnings = [] - } - --- | Log another warning in our internal program state -addWarning :: ProgStateRef -> String -> IO () -addWarning pstRef s = modifyIORef pstRef $ \p -> p { warnings = s : warnings p } -\end{code} - -% -------------------------------------------------------------------- -\section{Interface} -\subsection{Loading and parsing} -% -------------------------------------------------------------------- - -We have one master function that loads all the files GenI is expected to -use. This just calls the sub-loaders below, some of which are exported -for use by the graphical interface. The master function also makes sure -to complain intelligently if some of the required files are missing. - -\begin{code} -loadEverything :: ProgStateRef -> IO() -loadEverything pstRef = - do pst <- readIORef pstRef - -- - let config = pa pst - isMissing f = not $ hasFlagP f config - -- grammar type - isNotPreanchored = grammarType config /= PreAnchored - isNotPrecompiled = grammarType config /= PreCompiled - useTestSuite = isMissing FromStdinFlg - && isMissing NoLoadTestSuiteFlg - -- display - let errormsg = - concat $ intersperse ", " [ msg | (con, msg) <- errorlst, con ] - errorlst = - [ (isNotPrecompiled && isMissing MacrosFlg, - "a tree file") - , (isNotPreanchored && isMissing LexiconFlg, - "a lexicon file") - , (useTestSuite && isMissing TestSuiteFlg, - "a test suite") ] - unless (null errormsg) $ fail ("Please specify: " ++ errormsg) - -- we only have to read in grammars from the simple format - case grammarType config of - PreAnchored -> return () - PreCompiled -> return () - _ -> loadGeniMacros pstRef - -- we don't have to read in the lexicon if it's already pre-anchored - when isNotPreanchored $ loadLexicon pstRef - -- in any case, we have to... - loadMorphInfo pstRef - when useTestSuite $ loadTestSuite pstRef >> return () - -- the trace filter file - loadTraces pstRef - -- OT ranking - loadRanking pstRef -\end{code} - -The file loading functions all work the same way: we load the file, -and try to parse it. If this doesn't work, we just fail in IO, and -GenI dies. If we succeed, we update the program state passed in as -an IORef. - -\begin{code} -loadLexicon :: ProgStateRef -> IO () -loadLexicon pstRef = - do let getSem l = isemantics l - sorter l = l { isemantics = (sortSem . getSem) l } - cleanup = mapBySemKeys isemantics . map sorter - xs <- loadThingOrDie LexiconFlg "lexicon" pstRef - (parseFromFileOrFail geniLexicon) - modifyIORef pstRef (\p -> p { le = cleanup xs }) - --- | The macros are stored as a hashing function in the monad. -loadGeniMacros :: ProgStateRef -> IO () -loadGeniMacros pstRef = - do xs <- loadThingOrDie MacrosFlg "trees" pstRef parser - modifyIORef pstRef (\p -> p { gr = xs }) - where parser = parseFromFileMaybeBinary geniMacros - --- | The results are stored as a lookup function in the monad. -loadMorphInfo :: ProgStateRef -> IO () -loadMorphInfo pstRef = - do xs <- loadThingOrIgnore MorphInfoFlg "morphological info" pstRef parser - modifyIORef pstRef (\p -> p { morphinf = readMorph xs } ) - where parser = parseFromFileOrFail geniMorphInfo - -loadTraces :: ProgStateRef -> IO () -loadTraces pstRef = - do xs <- loadThingOrIgnore TracesFlg "traces" pstRef - (\f -> lines `fmap` readFile f) - modifyIORef pstRef (\p -> p {traces = xs}) - -loadRanking :: ProgStateRef -> IO () -loadRanking pstRef = - do config <- pa `fmap` readIORef pstRef - let verbose = hasFlagP VerboseModeFlg config - case getFlagP RankingConstraintsFlg config of - Nothing -> return () - Just f -> do r <- readRanking verbose f - modifyIORef pstRef (\p -> p { ranking = r }) - -readRanking :: Bool -- ^ verbose - -> FilePath -> IO OtRanking -readRanking verbose f = - do when verbose $ do - ePutStr $ unwords [ "Loading OT constraints", f ++ "... " ] - eFlush - mr <- (resultToEither . decode) `fmap` UTF8.readFile f -- utf-8? - when verbose $ ePutStr "done" - either fail return mr -\end{code} - -\subsubsection{Target semantics} - -Reading in the target semantics (or test suite) is a little more -complicated. It follows the same general schema as above, except -that we parse the file twice: once for our internal representation, -and once to get a string representation of each test case. The -string representation is for the graphical interface; it avoids us -figuring out how to pretty-print things because we can assume the -user will format it the way s/he wants. - -\begin{code} --- | Stores the results in the tcase and tsuite fields -loadTestSuite :: ProgStateRef -> IO [TestCase] -loadTestSuite pstRef = do - config <- pa `fmap` readIORef pstRef - let parser f = do - sem <- parseFromFileOrFail geniTestSuite f - mStrs <- parseFromFileOrFail geniTestSuiteString f - return $ zip sem mStrs - updater s x = - x { tsuite = s - , tcase = fromMaybe "" $ getFlagP TestCaseFlg config} - cleanup (tc,str) = - tc { tcSem = (sortSem sm, sort sr, lc) - , tcSemString = str } - where (sm, sr, lc) = tcSem tc - xs <- map cleanup `fmap` loadThingOrDie TestSuiteFlg "test suite" pstRef parser - modifyIORef pstRef (updater xs) - return xs -\end{code} - -Sometimes, the target semantics does not come from a file, but from -the graphical interface, so we also provide the ability to parse an -arbitrary string as the semantics. - -\begin{code} --- | Updates program state the same way as 'loadTestSuite' -loadTargetSemStr :: ProgStateRef -> String -> IO () -loadTargetSemStr pstRef str = - do parseSem - where - parseSem = do - let sem = runParser geniSemanticInput () "" str - case sem of - Left err -> fail (show err) - Right sr -> modifyIORef pstRef (\x -> x{ts = smooth sr}) - smooth (s,r,l) = (sortSem s, sort r, l) -\end{code} - -\subsubsection{Helpers for loading files} - -\begin{code} -loadThingOrIgnore, loadThingOrDie :: forall f a . (Eq f, Show f, Typeable f) - => (FilePath -> f) -- ^ flag - -> String - -> ProgStateRef - -> (FilePath -> IO [a]) - -> IO [a] - --- | Load the file if the relevant option is set, otherwise ignore -loadThingOrIgnore flag description pstRef parser = - do config <- pa `fmap` readIORef pstRef - case getFlagP flag config of - Nothing -> return [] - Just f -> loadThing f description pstRef parser - --- | Load the file if the relevant option is set, otherwise complain and die -loadThingOrDie flag description pstRef parser = - do config <- pa `fmap` readIORef pstRef - case getFlagP flag config of - Nothing -> fail $ "Please specify a " ++ description ++ "!" - Just f -> loadThing f description pstRef parser - -loadThing :: FilePath -- ^ file to load - -> String -- ^ description - -> ProgStateRef - -> (FilePath -> IO [a]) -- ^ parsing cmd - -> IO [a] -loadThing filename description pstRef parser = - do config <- pa `fmap` readIORef pstRef - let verbose = hasFlagP VerboseModeFlg config - when verbose $ do - ePutStr $ unwords [ "Loading", description, filename ++ "... " ] - eFlush - theTs <- parser filename - when verbose $ ePutStr $ (show $ length theTs) ++ " entries\n" - return theTs - -parseFromFileOrFail :: Parser a -> FilePath -> IO a -parseFromFileOrFail p f = parseFromFile p f >>= either (fail.show) (return) - -parseFromFileMaybeBinary :: Binary a - => Parser a - -> FilePath - -> IO a -parseFromFileMaybeBinary p f = - if (".genib" `isSuffixOf` f) - then decodeFile f - else parseFromFileOrFail p f -\end{code} - -% -------------------------------------------------------------------- -\subsection{Surface realisation - entry point} -% -------------------------------------------------------------------- - -This is your basic entry point. You call this if the only thing you want to do -is run the surface realiser. - -\begin{enumerate} -\item It initialises the realiser (lexical selection, among other things), - via \fnref{initGeni} -\item It runs the builder (the surface realisation engine proper) -\item It unpacks the builder results -\item It finalises the results (morphological generation) -\end{enumerate} - -\begin{code} -data GeniResult = GeniResult - { grLemmaSentence :: B.LemmaPlusSentence - , grRealisations :: [String] - , grDerivation :: B.Derivation - , grLexSelection :: [ GeniLexSel ] - , grRanking :: Int - , grViolations :: [ OtViolation ] - , grResultType :: ResultType - } deriving (Ord, Eq) - -data GeniLexSel = GeniLexSel - { nlTree :: String - , nlTrace :: [String] - } deriving (Ord, Eq) - -data ResultType = CompleteResult | PartialResult deriving (Ord, Eq) - --- | Returns a list of sentences, a set of Statistics, and the generator state. --- The generator state is mostly useful for debugging via the graphical interface. --- Note that we assumes that you have already loaded in your grammar and --- parsed your input semantics. -runGeni :: ProgStateRef -> B.Builder st it Params -> IO ([GeniResult], Statistics, st) -runGeni pstRef builder = runGeniWithSelector pstRef defaultSelector builder - -runGeniWithSelector :: ProgStateRef -> Selector -> B.Builder st it Params -> IO ([GeniResult], Statistics, st) -runGeniWithSelector pstRef selector builder = - do pst <- readIORef pstRef - let config = pa pst - run = B.run builder - unpack = B.unpack builder - -- step 1: lexical selection - initStuff <- initGeniWithSelector pstRef selector - -- step 2: chart generation - let (finalSt, stats) = run initStuff config - -- step 3: unpacking - let uninflected = unpack finalSt - tryPartial = null uninflected && hasFlagP PartialFlg config - rawResults = if tryPartial then B.partial builder finalSt else uninflected - resultTy = if tryPartial then PartialResult else CompleteResult - -- step 4: post-processing - results <- finaliseResults pstRef resultTy rawResults - return (results, stats, finalSt) -\end{code} - -% -------------------------------------------------------------------- -\subsection{Surface realisation - sub steps} -% -------------------------------------------------------------------- - -Below are the initial and final steps of \fnreflite{runGeni}. These functions -are seperated out so that they may be individually called from the graphical -debugger. The middle steps (running and unpacking the builder) depend on your -builder implementation. - -\begin{code} --- | 'initGeni' performs lexical selection and strips the input semantics of --- any morpohological literals -initGeni :: ProgStateRef -> IO (B.Input) -initGeni pstRef = initGeniWithSelector pstRef defaultSelector - -initGeniWithSelector :: ProgStateRef -> Selector -> IO (B.Input) -initGeniWithSelector pstRef lexSelector = - do -- disable constraints if the NoConstraintsFlg anti-optimisation is active - modifyIORef pstRef - (\p -> if hasOpt NoConstraints (pa p) - then p { ts = (fst3 (ts p),[],[]) } - else p) - -- lexical selection - (cand, lexonly) <- lexSelector pstRef - pst <- readIORef pstRef - -- strip morphological predicates - let (tsem,tres,lc) = ts pst - tsem2 = stripMorphSem (morphinf pst) tsem - -- - let initStuff = B.Input - { B.inSemInput = (tsem2, tres, lc) - , B.inLex = lexonly - , B.inCands = map (\c -> (c,-1)) cand - } - return initStuff - --- | 'finaliseResults' does any post-processing steps that we want to integrate --- into mainline GenI. So far, this consists of morphological realisation and --- OT ranking -finaliseResults :: ProgStateRef -> ResultType -> [B.Output] -> IO [GeniResult] -finaliseResults pstRef ty os = - do pst <- readIORef pstRef - -- morph TODO: make this a bit safer - mss <- case getFlagP MorphCmdFlg (pa pst) of - Nothing -> return $ map sansMorph sentences - Just cmd -> map snd `fmap` inflectSentencesUsingCmd cmd sentences - -- OT ranking - let unranked = zipWith (sansRanking pst) os mss - rank = rankResults (getTraces pst) grDerivation (ranking pst) - return . map addRanking . rank $ unranked - where - sentences = map fst os - sansRanking pst (l,d) rs = - GeniResult { grLemmaSentence = l - , grRealisations = rs - , grDerivation = d - , grLexSelection = map (\x -> GeniLexSel x (getTraces pst x)) (B.lexicalSelection d) - , grRanking = -1 - , grViolations = [] - , grResultType = ty - } - addRanking (i,res,vs) = res { grViolations = vs, grRanking = i } -\end{code} - -% -------------------------------------------------------------------- -\subsection{Displaying results} -% -------------------------------------------------------------------- - -\begin{code} --- | Show the sentences produced by the generator, in a relatively compact form -showRealisations :: [String] -> String -showRealisations sentences = - let sentencesGrouped = map (\ (s,c) -> s ++ countStr c) g - where g = groupAndCount sentences - countStr c = if c > 1 then " (" ++ show c ++ " instances)" - else "" - in if null sentences - then "(none)" - else unlines sentencesGrouped - --- | No morphology! Pretend the lemma string is a sentence -lemmaSentenceString :: GeniResult -> String -lemmaSentenceString = unwords . map lpLemma . grLemmaSentence - -prettyResult :: ProgState -> GeniResult -> String -prettyResult pst nr = - concat . intersperse "\n" . map showOne . grRealisations $ nr - where - showOne str = show theRanking ++ ". " ++ str ++ "\n" ++ violations - violations = prettyViolations tracesFn verbose (grViolations nr) - theRanking = grRanking nr - verbose = hasFlagP VerboseModeFlg (pa pst) - tracesFn = getTraces pst - --- | 'getTraces' is most likely useful for grammars produced by a --- metagrammar system. Given a tree name, we retrieve the ``trace'' --- information from the grammar for all trees that have this name. We --- assume the tree name was constructed by GenI; see the source code for --- details. -getTraces :: ProgState -> String -> [String] -getTraces pst tname = - filt $ concat [ ptrace t | t <- gr pst, pidname t == readPidname tname ] - where - filt = case traces pst of - [] -> id - theTs -> filter (`elem` theTs) - --- | We assume the name was constructed by 'combineName' -readPidname :: String -> String -readPidname n = - case wordsBy (== ':') n of - (_:_:p:_) -> p - _ -> geniBug "readPidname or combineName are broken" -\end{code} - -% -------------------------------------------------------------------- -\section{Lexical selection} -\label{sec:candidate_selection} \label{sec:lexical_selecetion} \label{par:lexSelection} -% -------------------------------------------------------------------- - -\paragraph{runLexSelection} \label{fn:runLexSelection} determines which -candidates trees which will be used to generate the current target semantics. -In addition to the anchored candidate trees, we also return the lexical items -themselves. This list of lexical items is useful for debugging a grammar; -it lets us know if GenI managed to lexically select something, but did not -succeed in anchoring it. - -\begin{code} -runLexSelection :: ProgStateRef -> IO ([TagElem], [ILexEntry]) -runLexSelection pstRef = - do pst <- readIORef pstRef - -- select lexical items first - let (tsem,_,litConstrs) = ts pst - lexicon = le pst - lexCand = chooseLexCand lexicon tsem - config = pa pst - verbose = hasFlagP VerboseModeFlg config - -- then anchor these lexical items to trees - let grammar = gr pst - combineWithGr l = - do let (lexCombineErrors, res) = combineList grammar l - familyMembers = [ p | p <- grammar, pfamily p == ifamname l ] - mapM_ (addWarning pstRef . showErr) $ compressLexCombineErrors - $ lexCombineErrors - -- snippets of error message - let lexeme = showLexeme.iword $ l - _outOfFamily n = show n ++ "/" ++ (show $ length familyMembers) - ++ " instances of " ++ lexeme ++ ":" ++ ifamname l - -- print out missing coanchors list - case concatMap (missingCoanchors l) familyMembers of - [] -> return () - cs -> mapM_ showWarning . group . sort $ cs - where showWarning [] = geniBug "silly error in Geni.runLexSelection" - showWarning xs@(x0:_) = addWarning pstRef $ "Missing co-anchor '" ++ x0 ++ "'" ++ " in " ++ _outOfFamily (length xs) ++ "." - -- print out enrichment errors -{- - unless (null enrichEs) $ do - let numDiscards = length enrichEs - badEnrichments = [ av | av <- iequations l, hasMatch av ] - hasMatch (a,_) = any (== parsePathEq a) errLocs - errLocs = map eeLocation enrichEs - ePutStrLn $ "Warning: Discarded " - ++ _outOfFamily numDiscards - ++ "\n due to enrichment failure with " - ++ "[" ++ showPairs badEnrichments ++ "]." - mapM (ePutStrLn.show) otherEs --} - - -- FIXMENOW when (not.null $ errs) $ ePutStrLn (unlines errs) - return res - cand <- case grammarType config of - PreAnchored -> readPreAnchored pst - _ -> concat `liftM` mapM combineWithGr lexCand - -- attach any morphological information to the candidates - let considerMorph = attachMorph (morphinf pst) tsem - -- filter out candidates which do not fulfill the trace constraints - let matchesLc t = all (`elem` myTrace) constrs - where constrs = concat [ cs | (l,cs) <- litConstrs, l `elem` mySem ] - mySem = tsemantics t - myTrace = ttrace t - considerLc = filter matchesLc - -- filter out candidates whose semantics has bonus stuff which does - -- not occur in the input semantics - let considerCoherency = filter (all (`elem` tsem) . tsemantics) - considerHasSem = filter (not . null . tsemantics) - -- - let candFinal = setTidnums . considerCoherency . considerHasSem - . considerLc . considerMorph $ cand - indent x = ' ' : x - unlinesIndentAnd :: (x -> String) -> [x] -> String - unlinesIndentAnd f = unlines . map (indent . f) - when verbose $ - do ePutStrLn $ "Lexical items selected:\n" ++ (unlinesIndentAnd (showLexeme.iword) lexCand) - ePutStrLn $ "Trees anchored (family) :\n" ++ (unlinesIndentAnd idname candFinal) - -- lexical selection failures - let missedSem = tsem \\ (nub $ concatMap tsemantics candFinal) - hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand - where lsem = isemantics l - missedLex = filter (not.hasTree) lexCand - unless (null missedSem) $ addWarning pstRef $ "no lexical selection for " ++ showSem missedSem - unless (null missedLex) $ forM_ missedLex $ \l -> addWarning pstRef $ - "'" ++ showLex l ++ "' was lexically selected, but not anchored to any trees" - return (candFinal, lexCand) - where showLex l = (showLexeme $ iword l) ++ "-" ++ (ifamname l) - showErr (c, e) = show e ++ " (" ++ show c ++ " times)" - -compressLexCombineErrors :: [LexCombineError] -> [(Int, LexCombineError)] -compressLexCombineErrors = map (length &&& head) . groupBy h - where - h (EnrichError m1 l1 _) (EnrichError m2 l2 _) = pfamily m1 == pfamily m2 && - iword l1 == iword l2 - h _ _ = False - --- | Select and returns the set of entries from the lexicon whose semantics --- subsumes the input semantics. -chooseLexCand :: Lexicon -> Sem -> [ILexEntry] -chooseLexCand slex tsem = - let keys = toKeys tsem - -- we choose candidates that match keys - lookuplex t = Map.findWithDefault [] t slex - cand = concatMap lookuplex $ myEMPTY : keys - -- and refine the selection... - cand2 = chooseCandI tsem cand - -- treat synonyms as a single lexical entry - -- FIXME: disabled see mergeSynonyms for explanation - -- cand3 = mergeSynonyms cand2 - in cand2 -\end{code} - -With a helper function, we refine the candidate selection by -instatiating the semantics, at the same time filtering those which -do not stay within the target semantics, and finally eliminating -the duplicates. - -\begin{code} -chooseCandI :: Sem -> [ILexEntry] -> [ILexEntry] -chooseCandI tsem cand = - let replaceLex i (sem,sub) = - (replace sub i) { isemantics = sem } - -- - helper :: ILexEntry -> [ILexEntry] - helper l = if null sem then [l] - else map (replaceLex l) psubsem - where psubsem = subsumeSem tsem sem - sem = isemantics l - -- - in nub $ concatMap helper cand -\end{code} - -A semantic key is a semantic literal boiled down to predicate plus arity -(see section \ref{btypes_semantics}). - - -\begin{code} --- | 'mapBySemKeys' @xs fn@ organises items (@xs@) by their semantic key --- (retrieved by @fn@). An item may have multiple keys. ---- This is used to organise the lexicon by its semantics. -mapBySemKeys :: (a -> Sem) -> [a] -> Map.Map String [a] -mapBySemKeys semfn xs = - let gfn t = if (null s) then [myEMPTY] else toKeys s - where s = semfn t - in multiGroupByFM gfn xs -\end{code} - -\fnlabel{mergeSynonyms} is a factorisation technique that uses -atomic disjunction to merge all synonyms into a single lexical -entry. Two lexical entries are considered synonyms if their -semantics match and they point to the same tree families. - -FIXME: 2006-10-11 - note that this is no longer being used, -because it breaks the case where two lexical entries differ -only by their use of path equations. Perhaps it's worthwhile -just to add a check that the path equations match exactly. - -\begin{code} -{- -mergeSynonyms :: [ILexEntry] -> [ILexEntry] -mergeSynonyms lexEntry = - let mergeFn l1 l2 = l1 { iword = (iword l1) ++ (iword l2) } - keyFn l = (ifamname l, isemantics l) - synMap = foldr helper Map.empty lexEntry - where helper x acc = Map.insertWith mergeFn (keyFn x) x acc - in Map.elems synMap --} -\end{code} - -% -------------------------------------------------------------------- -\subsection{Basic anchoring} -\label{sec:combine_macros} -% -------------------------------------------------------------------- - -This section of the code helps you to combined a selected lexical item with -a macro or a list of macros. This is a process that can go fail for any -number of reasons, so we try to record the possible failures for book-keeping. - -\begin{code} -data LexCombineError = - BoringError String - | EnrichError { eeMacro :: MTtree - , eeLexEntry :: ILexEntry - , eeLocation :: PathEqLhs } - | OtherError MTtree ILexEntry String - -instance Error LexCombineError where - noMsg = strMsg "error combining items" - strMsg s = BoringError s - -instance Show LexCombineError where - show (BoringError s) = s - show (OtherError t l s) = s ++ " on " ++ pfamily t ++ " (" ++ (showLexeme $ iword l) ++ ")" - show (EnrichError t l _) = show (OtherError t l "enrichment error") -\end{code} - -The first step in lexical selection is to collect all the features and -parameters that we want to combine. - -\begin{code} --- | 'combine' @macros lex@ creates the 'Tags' repository combining lexical --- entries and un-anchored trees from the grammar. It also unifies the --- parameters used to specialize un-anchored trees and propagates additional --- features given in the 'ILexEntry'. -combine :: Macros -> Lexicon -> Tags -combine gram lexicon = - let helper li = mapEither (combineOne li) macs - where tn = ifamname li - macs = [ t | t <- gram, pfamily t == tn ] - in Map.map (\e -> concatMap helper e) lexicon - -mapEither :: (a -> Either l r) -> [a] -> [r] -mapEither fn = mapMaybe (\x -> either (const Nothing) Just $ fn x) -\end{code} - -\begin{code} --- | Given a lexical item, looks up the tree families for that item, and --- anchor the item to the trees. -combineList :: Macros -> ILexEntry - -> ([LexCombineError],[TagElem]) -- ^ any warnings, plus the results -combineList gram lexitem = - case [ t | t <- gram, pfamily t == tn ] of - [] -> ([BoringError $ "Family " ++ tn ++ " not found in Macros"],[]) - macs -> unzipEither $ map (combineOne lexitem) macs - where tn = ifamname lexitem - -unzipEither :: (Error e, Show b) => [Either e b] -> ([e], [b]) -unzipEither es = helper ([],[]) es where - helper accs [] = accs - helper (eAcc, rAcc) (Left e : next) = helper (e:eAcc,rAcc) next - helper (eAcc, rAcc) (Right r : next) = helper (eAcc,r:rAcc) next -\end{code} - -\begin{code} --- | Combine a single tree with its lexical item to form a bonafide TagElem. --- This process can fail, however, because of filtering or enrichement -combineOne :: ILexEntry -> MTtree -> Either LexCombineError TagElem -combineOne lexRaw eRaw = -- Maybe monad - -- trace ("\n" ++ (show wt)) $ - do let l1 = alphaConvert "-l" lexRaw - e1 = alphaConvert "-t" eRaw - (l,e) <- unifyParamsWithWarning (l1,e1) - >>= unifyInterfaceUsing iinterface - >>= unifyInterfaceUsing ifilters -- filtering - >>= enrichWithWarning -- enrichment - let name = concat $ intersperse ":" $ filter (not.null) - [ head (iword l) , pfamily e , pidname e ] - return $ emptyTE - { idname = name - , ttreename = pfamily e - , ttype = ptype e - , ttree = setOrigin name . setLemAnchors . setAnchor (iword l) $ tree e - , tsemantics = - sortSem $ case psemantics e of - Nothing -> isemantics l - Just s -> s - , tsempols = isempols l - , tinterface = pinterface e - , ttrace = ptrace e - } - where - unifyParamsWithWarning (l,t) = - -- trace ("unify params " ++ wt) $ - let lp = iparams l - tp = map fromGVar $ params t - psubst = zip tp lp - in if (length lp) /= (length tp) - then Left $ OtherError t l $ "Parameter length mismatch" - else Right $ (replaceList psubst l, replaceList psubst t) - -- - unifyInterfaceUsing ifn (l,e) = - -- trace ("unify interface" ++ wt) $ - case unifyFeat (ifn l) (pinterface e) of - Nothing -> Left $ OtherError e l $ "Interface unification error" - Just (int2, fsubst) -> Right $ (replace fsubst l, e2) - where e2 = (replace fsubst e) { pinterface = int2 } - -- - enrichWithWarning (l,e) = - -- trace ("enrich" ++ wt) $ - do e2 <- enrich l e - return (l,e2) -\end{code} - -\subsubsection{Enrichment} - -Enrichment is a process which adds features to either the interface, an -explicitly named node or the co-anchor of a lexically selected tree. The -enrichement information comes from the lexicon in the form of a path equations -which specify -\begin{enumerate} -\item the location -\item top or bottom -\item the attribute -\item what value to associate with it -\end{enumerate} - -The conventions taken by GenI for path equations are: - -\begin{tabular}{|l|p{8cm}|} -\hline -\verb!interface.foo=bar! & -\fs{foo=bar} is unified into the interface (not the tree) \\ -\hline -\verb!anchor.bot.foo=bar! & -\fs{foo=bar} is unified into the bottom feature of the node -which is marked anchor. \\ -\hline -\verb!toto.top.foo=bar! & -\fs{foo=bar} is unified into the top feature of node named toto \\ -\hline -\verb!toto.bot.foo=bar! & -\fs{foo=bar} is unified into the bot feature of node named toto \\ -\hline -\verb!anchor.foo=bar! & -same as \verb!anchor.bot.foo=bar! \\ -\hline -\verb!anc.whatever...! & -same as \verb!anchor.whatever...! \\ -\hline -\verb!top.foo=bar! & -same as \verb!anchor.top.foo=bar! \\ -\hline -\verb!bot.foo=bar! & -same as \verb!anchor.bot.foo=bar! \\ -\hline -\verb!foo=bar! & -same as \verb!anchor.bot.foo=bar! \\ -\hline -\verb!toto.foo=bar! & -same as \verb!toto.top.foo=bar! (creates a warning) \\ -\hline -\end{tabular} - -\begin{code} --- | (node, top, att) (node is Nothing if anchor) -type PathEqLhs = (String, Bool, String) -type PathEqPair = (PathEqLhs, GeniVal) - -enrich :: ILexEntry -> MTtree -> Either LexCombineError MTtree -enrich l t = - do -- separate into interface/anchor/named - let (intE, namedE) = lexEquations l - -- enrich the interface and everything else - t2 <- foldM enrichInterface t intE - -- enrich everything else - foldM (enrichBy l) t2 namedE - where - toAvPair ((_,_,a),v) = AvPair a v - enrichInterface tx en = - do (i2, isubs) <- unifyFeat [toAvPair en] (pinterface tx) - `catchError` (\_ -> throwError $ ifaceEnrichErr en) - return $ (replace isubs tx) { pinterface = i2 } - ifaceEnrichErr (loc,_) = EnrichError - { eeMacro = t - , eeLexEntry = l - , eeLocation = loc } - -enrichBy :: ILexEntry -- ^ lexeme (for debugging info) - -> MTtree - -> (PathEqLhs, GeniVal) -- ^ enrichment eq - -> Either LexCombineError MTtree -enrichBy lexEntry t (eqLhs, eqVal) = - case seekCoanchor eqName t of - Nothing -> return t -- to be robust, we accept if the node isn't there - Just a -> - do let tfeat = (if eqTop then gup else gdown) a - (newfeat, sub) <- unifyFeat [AvPair eqAtt eqVal] tfeat - `catchError` (\_ -> throwError enrichErr) - let newnode = if eqTop then a {gup = newfeat} - else a {gdown = newfeat} - return $ fixNode newnode $ replace sub t - where - (eqName, eqTop, eqAtt) = eqLhs - fixNode n mt = mt { tree = repNodeByNode (matchNodeName eqName) n (tree mt) } - enrichErr = EnrichError { eeMacro = t - , eeLexEntry = lexEntry - , eeLocation = eqLhs } - -pathEqName :: PathEqPair -> String -pathEqName = fst3.fst - -missingCoanchors :: ILexEntry -> MTtree -> [String] -missingCoanchors lexEntry t = - -- list monad - do eq <- nubBy ((==) `on` pathEqName) $ snd $ lexEquations lexEntry - let name = pathEqName eq - case seekCoanchor name t of - Nothing -> [name] - Just _ -> [] - --- | Split a lex entry's path equations into interface enrichement equations --- or (co-)anchor modifiers -lexEquations :: ILexEntry -> ([PathEqPair], [PathEqPair]) -lexEquations = - partition (nameIs "interface") . map parseAv . iequations - where - parseAv (AvPair a v) = - case parsePathEq a of - Left (err,peq) -> unsafePerformIO $ do putStrLn err - return (peq,v) - Right peq -> (peq, v) - nameIs n x = pathEqName x == n - -seekCoanchor :: String -> MTtree -> Maybe GNode -seekCoanchor eqName t = - case filterTree (matchNodeName eqName) (tree t) of - [a] -> Just a - [] -> Nothing - _ -> geniBug $ "Tree with multiple matches in enrichBy. " ++ - "\nTree: " ++ pidname t ++ "\nFamily: " ++ pfamily t ++ - "\nMatching on: " ++ eqName - -matchNodeName :: String -> GNode -> Bool -matchNodeName "anchor" = ganchor -matchNodeName n = (== n) . gnname - --- | Parse a path equation using the GenI conventions --- This always succeeds, but can return @Just warning@ --- if anything anomalous comes up -parsePathEq :: String -> Either (String,PathEqLhs) (PathEqLhs) -parsePathEq e = - case wordsBy (== '.') e of - (n:"top":r) -> Right (n, True, rejoin r) - (n:"bot":r) -> Right (n, False, rejoin r) - ("top":r) -> Right ("anchor", True, rejoin r) - ("bot":r) -> Right ("anchor", False, rejoin r) - ("anc":r) -> parsePathEq $ rejoin $ "anchor":r - ("anchor":r) -> Right ("anchor", False, rejoin r) - ("interface":r) -> Right ("interface", False, rejoin r) - (n:r) -> Left (err, (n, True, rejoin r)) - where err = "Warning: Interpreting path equation " ++ e ++ - " as applying to top of " ++ n ++ "." - _ -> Left (err, ("", True, e)) - where err = "Warning: could not interpret path equation " ++ e - where - rejoin = concat . intersperse "." -\end{code} - -\subsubsection{Lemanchor mechanism} - -One problem in building reversible grammars is the treatment of co-anchors. -In the French language, for example, we have some structures like -\natlang{C'est Jean qui regarde Marie} -\natlang{It is John who looks at Mary} - -One might be tempted to hard code the ce (it) and the être (is) into the tree -for regarder (look at), something like \texttt{s(ce, être, n$\downarrow$, qui, -v(regarder), n$\downarrow$)}. Indeed, this would work just fine for -generation, but not for parsing. When you parse, you would encounter inflected -forms for these items for example \natlang{c'} for \natlang{ce} or -\natlang{sont} or \natlang{est} for \natlang{être}. Hard-coding the \natlang{ce} -into such trees would break parsing. - -To work around this, we propose a mechanism to have our co-anchors and parsing -too. Co-anchors that are susceptible to morphological variation should be -\begin{itemize} -\item marked in a substitution site (this is to keep parsers happy) -\item have a feature \texttt{bot.lemanchor:foo} where foo is the - coanchor you want -\end{itemize} - -GenI will convert these into non-substitution sites with a lexical item -leaf node. - -\begin{code} -setLemAnchors :: Tree GNode -> Tree GNode -setLemAnchors t = - repAllNode fn filt t - where - filt (Node a []) = gtype a == Subs && (isJust. lemAnchor) a - filt _ = False - fn (Node x k) = setLexeme (lemAnchorMaybeFake x) $ - Node (x { gtype = Other, gaconstr = False }) k - -- - lemAnchorMaybeFake :: GNode -> [String] - lemAnchorMaybeFake n = - case lemAnchor n of - Nothing -> ["ERR_UNSET_LEMMANCHOR"] - Just l -> l - lemAnchor :: GNode -> Maybe [String] - lemAnchor n = - case [ v | AvPair a v <- gdown n, a == _lemanchor ] of - [GConst l] -> Just l - _ -> Nothing - -_lemanchor :: String -_lemanchor = "lemanchor" -\end{code} - -\subsubsection{Node origins} - -After lexical selection, we label each tree node with its origin, most -likely the name and id of its elementary tree. This is useful for -building derivation trees - -\begin{code} -setOrigin :: String -> Tree GNode -> Tree GNode -setOrigin t = fmap (\g -> g { gorigin = t }) -\end{code} - -% -------------------------------------------------------------------- -\subsection{Pre-selection and pre-anchoring} -\label{sec:pre-anchor} -% -------------------------------------------------------------------- - -For testing purposes, we can perform lexical selection ahead of time and store -it somewhere else. - -\begin{code} --- | Only used for instances of GenI where the grammar is compiled --- directly into GenI. -type Selector = ProgStateRef -> IO ([TagElem],[ILexEntry]) - -defaultSelector :: Selector -defaultSelector = runLexSelection -\end{code} - -For debugging purposes, it is often useful to perform lexical selection and -surface realisation separately. Pre-anchored mode allows the user to just -pass the lexical selection in as a file of anchored trees associated with a -semantics. - -\begin{code} -readPreAnchored :: ProgState -> IO [TagElem] -readPreAnchored pst = - case getFlagP MacrosFlg (pa pst) of - Nothing -> fail "No macros file specified (preanchored mode)" - Just file -> parseFromFileOrFail geniTagElems file -\end{code} - -% -------------------------------------------------------------------- -% Boring utility code -% -------------------------------------------------------------------- - -\ignore{ -\begin{code} -instance JSON GeniResult where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - let field x = maybe (fail $ "Could not find: " ++ x) readJSON - $ lookup x jo - GeniResult <$> field "raw" - <*> field "realisations" - <*> field "derivation" - <*> field "lexical-selection" - <*> field "ranking" - <*> field "violations" - <*> field "result-type" - showJSON nr = - JSObject . toJSObject $ [ ("raw", showJSON $ grLemmaSentence nr) - , ("realisations", showJSONs $ grRealisations nr) - , ("derivation", showJSONs $ grDerivation nr) - , ("lexical-selection", showJSONs $ grLexSelection nr) - , ("ranking", showJSON $ grRanking nr) - , ("violations", showJSONs $ grViolations nr) - , ("result-type", showJSON $ grResultType nr) - ] - -instance JSON ResultType where - readJSON j = - do js <- fromJSString `fmap` readJSON j - case js of - "partial" -> return PartialResult - "complete" -> return CompleteResult - ty -> fail $ "unknown result type: " ++ ty - showJSON CompleteResult = JSString $ toJSString "complete" - showJSON PartialResult = JSString $ toJSString "partial" - -instance JSON GeniLexSel where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - let field x = maybe (fail $ "Could not find: " ++ x) readJSON - $ lookup x jo - GeniLexSel <$> field "lex-item" - <*> field "trace" - showJSON x = - JSObject . toJSObject $ [ ("lex-item", showJSON $ nlTree x) - , ("trace", showJSONs $ nlTrace x) - ] -\end{code} -} - diff --git a/src/NLP/GenI/GeniParsers.lhs b/src/NLP/GenI/GeniParsers.lhs deleted file mode 100644 --- a/src/NLP/GenI/GeniParsers.lhs +++ /dev/null @@ -1,919 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{File formats} -\label{cha:formats} -\label{cha:GeniParsers} - -This chapter is a description of the file formats used by \geni. We'll be -using EBNFs to describe the format below. Here are some rules and types of -rules we leave out, and prefer to describe informally: - -\begin{verbatim} - - (stuff between quotes) - (systematically... "" | ) - (systematically.. "whatever" ":") -\end{verbatim} - -\ignore{ -\begin{code} -module NLP.GenI.GeniParsers ( - -- * Test suites - geniTestSuite, geniSemanticInput, geniTestSuiteString, - geniDerivations, - toSemInputString, - -- * Trees - geniMacros, geniTagElems, - -- * Lexicon and morph - geniLexicon, geniMorphInfo, - -- * Basics - geniFeats, geniPolarities, geniSemantics, geniValue, geniWords, - -- * Helpers - geniWord, geniLanguageDef, tillEof, - -- - parseFromFile, -- UTF-8 version - module Text.ParserCombinators.Parsec -) where - -import NLP.GenI.General ((!+!), Interval, ival) -import NLP.GenI.Btypes -import NLP.GenI.Tags (TagElem(..), emptyTE, setTidnums) -import NLP.GenI.GeniShow (GeniShow(geniShow)) -import NLP.GenI.PolarityTypes - -import Control.Monad (liftM, when) -import Data.List (sort) -import qualified Data.Map as Map -import qualified Data.Tree as T -import Text.ParserCombinators.Parsec hiding (parseFromFile) -import Text.ParserCombinators.Parsec.Language (emptyDef) -import Text.ParserCombinators.Parsec.Token (TokenParser, - LanguageDef(..), makeTokenParser) -import qualified Text.ParserCombinators.Parsec.Token as P -import qualified System.IO.UTF8 as UTF8 - -\end{code} -} - -\section{General notes} - -\subsection{Comments} - -Any \geni format file can include comments. Comments start \verb!%!. -There is also the option of using \verb'/* */' for embedded comments. - -\subsection{Reserved words} - -The following are reserved words. You should not use them as variable names. -NB: the reserved words are indicated below between quotes; eg. ``semantics''. -You can ignore C pre-processor noise such as \verb!#define SEMANTICS! - -\begin{includecodeinmanual} -\begin{code} --- reserved words -#define SEMANTICS "semantics" -#define SENTENCE "sentence" -#define OUTPUT "output" -#define TRACE "trace" -#define ANCHOR "anchor" -#define SUBST "subst" -#define FOOT "foot" -#define LEX "lex" -#define TYPE "type" -#define ACONSTR_NOADJ "aconstr:noadj" -#define INITIAL "initial" -#define AUXILIARY "auxiliary" -#define IDXCONSTRAINTS "idxconstraints" -#define BEGIN "begin" -#define END "end" -\end{code} -\end{includecodeinmanual} - -\subsection{Lexer} - -For reference, we include the Parsec LanguageDef that we use to implement -the \geni format. - -\begin{includecodeinmanual} -\begin{code} -geniLanguageDef :: LanguageDef () -geniLanguageDef = emptyDef - { commentLine = "%" - , commentStart = "/*" - , commentEnd = "*/" - , opLetter = oneOf "" - , reservedOpNames = [""] - , reservedNames = - [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE - , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR_NOADJ - , INITIAL , AUXILIARY - , BEGIN , END ] - , identLetter = identStuff - , identStart = identStuff - } - where identStuff = alphaNum <|> oneOf "_'+-." -\end{code} -\end{includecodeinmanual} - -\section{The basics} - -\subsection{Variables and constants} - -Below are some examples of \geni variables and constants. Note that we support -atomic disjunction of constants, as in \verb!Foo|bar|baz!, but not variables. - -\begin{center} -\begin{tabular}{ll} -anonymous variable & \verb!?_! or \verb!_! \\ -variables & \verb!Foo!, \verb!?X! or \verb!?x! \\ -constants & \verb!Foo!, \verb!foo!, \verb!X!, \verb!x! or \verb!Foo|bar! \\ -\end{tabular} -\end{center} - -Here is an EBNF for GenI variables and constants - -\begin{SaveVerbatim}{KoweyTmp} - ::= | | - ::= "?" - ::= "?_" | "_" - ::= (| )* - ::= - ::= | "+" | "-" | "_" -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniValue :: Parser GeniVal -geniValue = ((try $ anonymous) "_ or ?_") - <|> (constants "a constant or atomic disjunction") - <|> (variable "a variable") - where - question = "?" - -- - constants :: Parser GeniVal - constants = - do c <- sepBy1 (looseIdentifier <|> stringLiteral) (symbol "|") - return (GConst c) - variable :: Parser GeniVal - variable = - do symbol question - v <- identifier - return (GVar v) - anonymous :: Parser GeniVal - anonymous = - do optional $ symbol question - symbol "_" - return GAnon -\end{code} - -\subsection{Feature structures} - -In addition to variables and constants, \geni also makes heavy use of flat -feature structures. They take the form \verb![foo:bar ping:?Pong]!, or more -formally, - -\begin{SaveVerbatim}{KoweyTmp} - ::= "[" * "]" - ::= ":" - ::= | -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniFeats :: Parser Flist -geniFeats = option [] $ squares $ many geniAttVal - -geniAttVal :: Parser AvPair -geniAttVal = do - att <- identifierR "an attribute"; colon - val <- geniValue "a GenI value" - return $ AvPair att val -\end{code} - -\subsection{Semantics} -\label{sec:geni-semantics} - -A \jargon{semantics} is basically a set of literals. Semantics are used in -to provide \geni input (section \ref{sec:geni-input-semantics}) and in the -definition of lexical entries (section \ref{sec:geni-lexicon}). - -Notice that this is a flat semantic representation! No literals within -literals, please. A literal can take one of two forms: -\begin{verbatim} - handle:predicate(arguments) - predicate(arguments) -\end{verbatim} - -The arguments are space-delimited. Not providing a handle is -equivalent to providing an anonymous one. - -\begin{SaveVerbatim}{KoweyTmp} - ::= "[" * "]" - ::= "(" * ")" -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniSemantics :: Parser Sem -geniSemantics = - do sem <- many (geniLiteral "a literal") - return (sortSem sem) - -geniLiteral :: Parser Pred -geniLiteral = - do handle <- option GAnon handleParser "a handle" - predicate <- geniValue "a predicate" - pars <- parens (many geniValue) "some parameters" - -- - return (handle, predicate, pars) - where handleParser = - try $ do { h <- geniValue ; char ':' ; return h } -\end{code} - -\section{Semantic inputs and test suites} -\label{sec:geni-input-semantics} - -\subsection{Semantic input} - -The semantic input can either be provided directly in the graphical interface -or as part of a test suite. - -The format for semantic inputs is actually a bit richer than the core -definition in section \ref{sec:geni-semantics}, but I have not yet written the -documentation for it. - -\textbf{TODO}: The semantics may contain literal based constraints as described -in section \ref{sec:fixme}. These constraints are just a space-delimited list -of String. When returning the results, we separate them out from the semantics -proper so that they can be treated separately. Index constraints are -represented as feature structures. - -\begin{code} -geniSemanticInput :: Parser (Sem,Flist,[LitConstr]) -geniSemanticInput = - do keywordSemantics - (sem,litC) <- liftM unzip $ squares $ many literalAndConstraint - idxC <- option [] geniIdxConstraints - -- - let sem2 = createHandles sem - semlitC2 = [ (s,c) | (s,c) <- zip sem2 litC, (not.null) c ] - return (createHandles sem, idxC, semlitC2) - where - -- set all anonymous handles to some unique value - -- this is to simplify checking if a result is - -- semantically complete - createHandles :: Sem -> Sem - createHandles = zipWith setHandle ([1..] :: [Int]) - -- - setHandle i (h, pred_, par) = - let h2 = if h /= GAnon then h - else GConst ["genihandle" ++ (show i)] - in (h2, pred_, par) - -- - literalAndConstraint :: Parser (Pred, [String]) - literalAndConstraint = - do l <- geniLiteral - t <- option [] $ squares $ many identifier - return (l,t) - --- | The original string representation of the semantics (for gui) -geniSemanticInputString :: Parser String -geniSemanticInputString = - do keywordSemantics - s <- squaresString - whiteSpace - optional geniIdxConstraints - return s - -geniIdxConstraints :: Parser Flist -geniIdxConstraints = keyword IDXCONSTRAINTS >> geniFeats - -squaresString :: Parser String -squaresString = - do char '[' - s <- liftM concat $ many $ (many1 $ noneOf "[]") <|> squaresString - char ']' - return $ "[" ++ s ++ "]" - --- the output end of things --- displaying preformatted semantic input - -data SemInputString = SemInputString String Flist - -instance GeniShow SemInputString where - geniShow (SemInputString semStr idxC) = - SEMANTICS ++ ":" ++ semStr ++ (if null idxC then "" else r) - where r = "\n" ++ IDXCONSTRAINTS ++ ": " ++ showFlist idxC - -toSemInputString :: SemInput -> String -> SemInputString -toSemInputString (_,lc,_) s = SemInputString s lc -\end{code} - -\subsection{Test suite} - -\geni accepts an entire test suite of semantic inputs that you can choose from. -The test suite entries can be named. In fact, it is probably a good idea to do -so, because the names are often shorter than the expected output, and easier to -read than the semantics. Note the expected output isn't used by \geni itself, -but external tools that ``test'' \geni. - -\begin{SaveVerbatim}{KoweyTmp} - ::= * - ::= * - ::= "[" * "]" -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniTestSuite :: Parser [TestCase] -geniTestSuite = - tillEof (many geniTestCase) - --- | Just the String representations of the semantics --- in the test suite -geniTestSuiteString :: Parser [String] -geniTestSuiteString = - tillEof (many geniTestCaseString) - --- | This is only used by the script genimakesuite -geniDerivations :: Parser [TestCaseOutput] -geniDerivations = tillEof $ many geniOutput - -geniTestCase :: Parser TestCase -geniTestCase = - do name <- option "" (identifier "a test case name") - seminput <- geniSemanticInput - sentences <- many geniSentence - outputs <- many geniOutput - return $ TestCase name "" seminput sentences outputs - --- note that the keyword is NOT optional -type TestCaseOutput = (String, Map.Map (String,String) [String]) -geniOutput :: Parser TestCaseOutput -geniOutput = - do ws <- keyword OUTPUT >> (squares geniWords) - ds <- Map.fromList `fmap` many geniTraces - return (ws, ds) - -geniTraces :: Parser ((String,String), [String]) -geniTraces = - do keyword TRACE - squares $ do - k1 <- withWhite geniWord - k2 <- withWhite geniWord - whiteSpace >> char '!' >> whiteSpace - traces <- sepEndBy1 geniWord whiteSpace - return ((k1,k2), traces) - -withWhite :: Parser a -> Parser a -withWhite p = p >>= (\a -> whiteSpace >> return a) - -geniSentence :: Parser String -geniSentence = optional (keyword SENTENCE) >> squares geniWords - -geniWords :: Parser String -geniWords = - unwords `fmap` (sepEndBy1 geniWord whiteSpace "a sentence") - -geniWord :: Parser String -geniWord = many1 (noneOf "[]\v\f\t\r\n ") - --- | The original string representation of a test case semantics --- (for gui) -geniTestCaseString :: Parser String -geniTestCaseString = - do option "" (identifier "a test case name") - s <- geniSemanticInputString - many geniSentence - many geniOutput - return s -\end{code} - -\section{Lexicon} -\label{sec:geni-lexicon} - -The lexicon associates semantic entries with lemmas and trees. - -\subsection{Lexicon examples} - -There are two ways to write the lexicon. We show the old (deprecated) -way first because most of the examples are still written in this style. - -\paragraph{Example 1 (deprecated)} - -\begin{verbatim} -le clitic (?I) -semantics:[] - -le Det (?I) -semantics:[def(?I)] - -livre nC (?I) -semantics:[book(?I)] - -persuader vArity3 (?E ?X ?Y ?Z) -semantics:[?E:convince(?X ?Y ?Z)] - -persuader v vArity3controlObj -semantics:[?E:convince(?X ?Y ?Z)] -\end{verbatim} - -\paragraph{Example 2 (preferred)} - -\begin{verbatim} -detester n0Vn1 -equations:[theta1:agent theta2:patient arg1:?X arg2:?Y evt:?L] -filters:[family:n0Vn1] -semantics:[?E:hate(?L) ?E:agent(?L ?X) ?E:patient(?L ?Y)] -\end{verbatim} - -\subsection{Notes about lexicons} - -\begin{itemize} -\item The semantics associated with a lexicali item may have more than one literal -\begin{verbatim} -cher adj (?E ?X ?Y) -semantics:[?E:cost(?X ?Y) ?E:high(?Y)] -\end{verbatim} - -\item A lemma may have more than one distinct semantics -\begin{verbatim} -bank n (?X) -semantics:[bank(?X)] - -bank v (?E ?X ?D) -semantics:[?E:lean(?X,?D)] -\end{verbatim} - -\item A semantics may be realised by more than one lexical entry (e.g. synonynms) -\begin{verbatim} -livre nC (?I) -semantics:[book(?I)] - -bouquin nC (?I) -semantics:[book(?I)] -\end{verbatim} -\end{itemize} - -\subsection{Lexicon EBNF} - -\begin{SaveVerbatim}{KoweyTmp} - ::= * - ::= - ::= - | - ::= "(" * ")" - ::= "!" * - ::= -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniLexicon :: Parser [ILexEntry] -geniLexicon = tillEof $ many1 geniLexicalEntry - -geniLexicalEntry :: Parser ILexEntry -geniLexicalEntry = - do lemma <- (looseIdentifier <|> stringLiteral) "a lemma" - family <- identifier "a tree family" - (pars, interface) <- option ([],[]) $ parens paramsParser - equations <- option [] $ do keyword "equations" - geniFeats "path equations" - filters <- option [] $ do keyword "filters" - geniFeats - keywordSemantics - (sem,pols) <- squares geniLexSemantics - -- - return emptyLE { iword = [lemma] - , ifamname = family - , iparams = pars - , iinterface = sortFlist interface - , iequations = equations - , ifilters = filters - , isemantics = sem - , isempols = pols } - where - paramsParser :: Parser ([GeniVal], Flist) - paramsParser = do - pars <- many geniValue "some parameters" - interface <- option [] $ do symbol "!" - many geniAttVal - return (pars, interface) - -geniLexSemantics :: Parser (Sem, [[Int]]) -geniLexSemantics = - do litpols <- many (geniLexLiteral "a literal") - return $ unzip litpols - -geniLexLiteral :: Parser (Pred, [Int]) -geniLexLiteral = - do (handle, hpol) <- option (GAnon,0) (handleParser "a handle") - predicate <- geniValue "a predicate" - paramsPols <- parens (many geniPolValue) "some parameters" - -- - let (pars, pols) = unzip paramsPols - literal = (handle, predicate, pars) - return (literal, hpol:pols) - where handleParser = - try $ do { h <- geniPolValue; colon; return h } - -geniPolValue :: Parser (GeniVal, Int) -geniPolValue = - do p <- geniPolarity - v <- geniValue - return (v,p) -\end{code} - -\section{Tree schemata} - -The tree schemata file (for historical reasons, this is also called the macros -file) contains a set of unlexicalised trees organised into families. Such -``macros'' consist of a - -\begin{enumerate} -\item a family name and (optionally) a macro name -\item a list of parameters -\item ''initial'' or ''auxiliary'' -\item a tree. -\end{enumerate} - -\subsection{Trees} - -\jargon{Trees} are recursively defined structure of form \verb!node{tree*}! -For example, in the table below, the structure on the left should produce the -tree on the right: - -\begin{SaveVerbatim}{KoweyTmp} -n1{ - n2 - n3{ - n4 - n5 - } - n6 -} -\end{SaveVerbatim} -\begin{tabular}{ll} -\BUseVerbatim{KoweyTmp} & \includegraphics[scale=0.50]{images/tree-format-example.png} \\ -\end{tabular} - -\subsection{Nodes} - -\jargon{Nodes} consist of -\begin{enumerate} -\item a name -\item a type (optional) -\item either a lexeme, or top and bottom feature structures. Here are examples of the five possible kinds of nodes: -\end{enumerate} - -\noindent -Here are some examples of nodes -\begin{verbatim} - n1 [cat:n idx:?I]![cat:n idx:?I] % basic - n3 type:subst [cat:n idx:?Y]![cat:n idx:?Y] % subst - n4 type:foot [cat:n idx:?Y]![cat:n idx:?Y] % foot - n5 type:lex "de" % coanchor - n2 anchor % anchor - n5 aconstr:noadj % node with a null-adjunction constraint (other than subst or foot) -\end{verbatim} - -\subsection{Example} - -\begin{verbatim} -adj:post(?I) auxiliary -n0[cat:n idx:?I det:_]![cat:n idx:?I det:minus ] -{ - n1 type:foot [cat:n idx:?I det:minus]![cat:n idx:?I det:minus] - n2[cat:a]![] - { - n3 anchor - } -} - -adj:pre(?I) auxiliary -n0[cat:n idx:?I det:_ qu:_]![cat:n idx:?I det:minus ] -{ - n1[cat:a]![] - { - n2 anchor - } - n3 type:foot [cat:n idx:?I det:minus]![cat:n idx:?I det:minus] -} - -vArity2:n0vn1(?E ?X ?Y) initial -n1[cat:p]![] -{ - n2 type:subst [cat:n idx:?X det:plus]![cat:n idx:?X] - n3[cat:v idx:?E]![] - { - n4 anchor - } - n5 type:subst [cat:n idx:?Y det:plus]![cat:n idx:?Y] -} -\end{verbatim} - -\subsection{EBNF} - -\begin{SaveVerbatim}{KoweyTmp} - ::= * - ::= - - - ::= "(" * ")" - ::= ! * - ::= - ::= "initial" | "auxiliary" - ::= "[" * "]" - - ::= | "{" * "}" - ::= - ::= - ::= | "anchor" - ::= "foot" | "subst" | "lex" - ::= | "!" -\end{SaveVerbatim} -\begin{center} -\fbox{\BUseVerbatim{KoweyTmp}} -\end{center} - -\begin{code} -geniMacros :: Parser [MTtree] -geniMacros = tillEof $ many geniTreeDef - -initType, auxType :: Parser Ptype -initType = do { reserved INITIAL ; return Initial } -auxType = do { reserved AUXILIARY ; return Auxiliar } - -geniTreeDef :: Parser MTtree -geniTreeDef = - do sourcePos <- getPosition - family <- identifier - tname <- option "" $ do { colon; identifier } - (pars,iface) <- geniParams - theTtype <- (initType <|> auxType) - theTree <- geniTree - -- sanity checks? - let treeFail x = - do setPosition sourcePos -- FIXME does not do what I expect - fail $ "In tree " ++ family ++ ":" ++ tname ++ " " ++ show sourcePos ++ ": " ++ x - let theNodes = T.flatten theTree - numFeet = length [ x | x <- theNodes, gtype x == Foot ] - numAnchors = length [ x | x <- theNodes, ganchor x ] - when (not $ any ganchor theNodes) $ - treeFail "At least one node in an LTAG tree must be an anchor" - when (numAnchors > 1) $ - treeFail "There can be no more than 1 anchor node in a tree" - when (numFeet > 1) $ - treeFail "There can be no more than 1 foot node in a tree" - when (theTtype == Initial && numFeet > 0) $ - treeFail "Initial trees may not have foot nodes" - -- - psem <- option Nothing $ do { keywordSemantics; liftM Just (squares geniSemantics) } - ptrc <- option [] $ do { keyword TRACE; squares (many identifier) } - -- - return TT{ params = pars - , pfamily = family - , pidname = tname - , pinterface = sortFlist iface - , ptype = theTtype - , tree = theTree - , ptrace = ptrc - , psemantics = psem - } - -geniTree :: Parser (T.Tree GNode) -geniTree = - do node <- geniNode - kids <- option [] (braces $ many geniTree) - "child nodes" - -- sanity checks - let noKidsAllowed t c = when (c node && (not.null $ kids)) $ - fail $ t ++ " nodes may *not* have any children" - noKidsAllowed "Anchor" $ ganchor - noKidsAllowed "Substitution" $ (== Subs) . gtype - noKidsAllowed "Foot" $ (== Foot) . gtype - -- - return (T.Node node kids) - -geniNode :: Parser GNode -geniNode = - do name <- identifier - nodeType <- option "" ( (keyword TYPE >> typeParser) - <|> - reserved ANCHOR) - lex_ <- if nodeType == LEX - then (sepBy (stringLiteral<|>identifier) (symbol "|") "some lexemes") - else return [] - constr <- case nodeType of - "" -> adjConstraintParser - ANCHOR -> adjConstraintParser - _ -> return True - (top_,bot_) <- -- features only obligatory for non-lex nodes - if nodeType == LEX - then option ([],[]) $ try topbotParser - else topbotParser - -- - let top = sort top_ - bot = sort bot_ - nodeType2 = case nodeType of - ANCHOR -> Lex - LEX -> Lex - FOOT -> Foot - SUBST -> Subs - "" -> Other - other -> error ("unknown node type: " ++ other) - return $ GN { gnname = name, gtype = nodeType2 - , gup = top, gdown = bot - , glexeme = lex_ - , ganchor = (nodeType == ANCHOR) - , gaconstr = constr - , gorigin = "" } - where - typeParser = choice $ map (try.symbol) [ ANCHOR, FOOT, SUBST, LEX ] - adjConstraintParser = option False $ reserved ACONSTR_NOADJ >> return True - topbotParser = - do top <- geniFeats "top features" - symbol "!" - bot <- geniFeats "bot features" - return (top,bot) - --- | This makes it possible to read anchored trees, which may be --- useful for debugging purposes. --- --- FIXME: note that this is very rudimentary; we do not set id numbers, --- parse polarities. You'll have to call --- some of our helper functions if you want that functionality. -geniTagElems :: Parser [TagElem] -geniTagElems = tillEof $ setTidnums `fmap` many geniTagElem - -geniTagElem :: Parser TagElem -geniTagElem = - do family <- identifier - tname <- option "" $ do { colon; identifier } - iface <- (snd `liftM` geniParams) <|> geniFeats - theType <- initType <|> auxType - theTree <- geniTree - sem <- do { keywordSemantics; squares geniSemantics } - -- - return $ emptyTE { idname = tname - , ttreename = family - , tinterface = iface - , ttype = theType - , ttree = theTree - , tsemantics = sem } - --- | 'geniParams' recognises a list of parameters optionally followed by a --- bang (\verb$!$) and a list of attribute-value pairs. This whole thing is --- to wrapped in the parens. --- --- TODO: deprecate -geniParams :: Parser ([GeniVal], Flist) -geniParams = parens $ do - pars <- many geniValue "some parameters" - interface <- option [] $ do { symbol "!"; many geniAttVal } - return (pars, interface) -\end{code} - -\section{Morphology} - -A morphinfo file associates predicates with morphological feature structures. -Each morphological entry consists of a predicate followed by a feature -structuer. For more information, see chapter \ref{cha:Morphology}. -(\textbf{TODO}: describe format) - -\begin{code} -geniMorphInfo :: Parser [(String,Flist)] -geniMorphInfo = tillEof $ many morphEntry - -morphEntry :: Parser (String,Flist) -morphEntry = - do pred_ <- identifier - feats <- geniFeats - return (pred_, feats) -\end{code} - -% ====================================================================== -% everything else -% ====================================================================== - -\begin{code} --- ---------------------------------------------------------------------- --- polarities --- ---------------------------------------------------------------------- -geniPolarities :: Parser (Map.Map PolarityKey Interval) -geniPolarities = tillEof $ toMap `fmap` many pol - where - toMap = Map.fromListWith (!+!) - pol = do p <- geniPolarity - i <- identifier - return (PolarityKey i,ival p) - --- | 'geniPolarity' associates a numerical value to a polarity symbol, --- that is, '+' or '-'. -geniPolarity :: Parser Int -geniPolarity = option 0 (plus <|> minus) - where - plus = do { char '+'; return 1 } - minus = do { char '-'; return (-1) } - --- ---------------------------------------------------------------------- --- keyword --- ---------------------------------------------------------------------- - -{-# INLINE keyword #-} -keyword :: String -> Parser String -keyword k = - do let helper = try $ do { reserved k; colon; return k } - helper k ++ ":" - -{-# INLINE keywordSemantics #-} -keywordSemantics :: Parser String -keywordSemantics = keyword SEMANTICS - --- ---------------------------------------------------------------------- --- language def helpers --- ---------------------------------------------------------------------- - -lexer :: TokenParser () -lexer = makeTokenParser geniLanguageDef - -whiteSpace :: CharParser () () -whiteSpace = P.whiteSpace lexer - -looseIdentifier, identifier, stringLiteral, colon :: CharParser () String -identifier = P.identifier lexer - --- stolen from Parsec code (ident) --- | Like 'identifier' but allows for reserved words too -looseIdentifier = - do { i <- ident ; whiteSpace; return i } - where - ident = - do { c <- identStart geniLanguageDef - ; cs <- many (identLetter geniLanguageDef) - ; return (c:cs) } "identifier" - -stringLiteral = P.stringLiteral lexer -colon = P.colon lexer - -squares, braces, parens :: CharParser () a -> CharParser () a -squares = P.squares lexer -braces = P.braces lexer -parens = P.parens lexer - -reserved, symbol :: String -> CharParser () String -reserved s = P.reserved lexer s >> return s -symbol = P.symbol lexer - --- ---------------------------------------------------------------------- --- parsec helpers --- ---------------------------------------------------------------------- - --- | identifier, permitting reserved words too -identifierR :: CharParser () String -identifierR - = do { c <- P.identStart geniLanguageDef - ; cs <- many (P.identLetter geniLanguageDef) - ; return (c:cs) - } - "identifier or reserved word" - -tillEof :: Parser a -> Parser a -tillEof p = - do whiteSpace - r <- p - eof - return r - --- stolen from Parsec and adapted to use UTF-8 input -parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a) -parseFromFile p fname - = do{ input <- UTF8.readFile fname - ; return (parse p fname input) - } -\end{code} diff --git a/src/NLP/GenI/GeniShow.hs b/src/NLP/GenI/GeniShow.hs --- a/src/NLP/GenI/GeniShow.hs +++ b/src/NLP/GenI/GeniShow.hs @@ -15,157 +15,55 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{- -We need to be able to dump some of GenI's data structures into a simple -text format we call GeniHand. - -There are at least two uses for this, one is that it allows us to -interrupt the debugging process, dump everything to file, muck around -with the trees and then pick up where we left off. - -The other use is to make large grammars faster to load. We don't actually do -this anymore, mind you, but it's nice to have the option. The idea is to take -a massive XML grammar, parse it to a set of TagElems and then write these back -in the lighter syntax. It's not that XML is inherently less efficient to parse -than the handwritten syntax, just that writing an efficient parser for XML -based format is more annoying, so I stuck with HaXml to make my life easy. -Unfortunately, HaXml seems to have some kind of space leak. --} - -- This module provides specialised functions for visualising tree data. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} module NLP.GenI.GeniShow where +import Data.Text ( Text ) import Data.Tree -import Data.List(intersperse, isPrefixOf) -import qualified Data.Map as Map - -import NLP.GenI.Tags - ( TagElem, idname, - tsemantics, ttree, tinterface, ttype, ttreename, - ) -import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), Ptype(..), - Ttree(params, pidname, pfamily, pinterface, ptype, tree, psemantics, ptrace), - GNode(..), GType(..), - SemInput, Pred, - TestCase(..), - ) +import qualified Data.Text as T +import NLP.GenI.Pretty +-- | GenI format; should round-trip with 'NLP.GenI.Parser' by rights +-- +-- Minimal definition, either one of 'geniShow' or 'geniShowText' class GeniShow a where - geniShow :: a -> String - -instance GeniShow Ptype where - geniShow Initial = "initial" - geniShow Auxiliar = "auxiliary" - geniShow _ = "" - -instance GeniShow AvPair where - geniShow (AvPair a v) = a ++ ":" ++ geniShow v - -instance GeniShow GeniVal where - geniShow (GConst xs) = concat $ intersperse "|" xs - geniShow x = show x - -instance GeniShow Pred where - geniShow (h, p, l) = - showh ++ geniShow p ++ "(" ++ unwords (map geniShow l) ++ ")" - where - hideh (GConst [x]) = "genihandle" `isPrefixOf` x - hideh _ = False - showh = if hideh h then "" else geniShow h ++ ":" - -instance GeniShow GNode where - geniShow x = - let gaconstrstr = case (gaconstr x, gtype x) of - (True, Other) -> "aconstr:noadj" - _ -> "" - gtypestr n = case (gtype n) of - Subs -> "type:subst" - Foot -> "type:foot" - Lex -> if ganchor n && (null.glexeme) n - then "type:anchor" else "type:lex" - _ -> "" - glexstr n = - if null ls then "" - else concat $ intersperse "|" $ map quote ls - where quote s = "\"" ++ s ++ "\"" - ls = glexeme n - tbFeats n = (geniShow $ gup n) ++ "!" ++ (geniShow $ gdown n) - in unwords $ filter (not.null) $ [ gnname x, gaconstrstr, gtypestr x, glexstr x, tbFeats x ] + geniShow :: a -> String + geniShow = T.unpack . geniShowText -instance (GeniShow a) => GeniShow [a] where - geniShow = squares . unwords . (map geniShow) + geniShowText :: a -> Text + geniShowText = T.pack . geniShow instance (GeniShow a) => GeniShow (Tree a) where - geniShow t = - let treestr i (Node a l) = - spaces i ++ geniShow a ++ - case (l,i) of - ([], 0) -> "{}" - ([], _) -> "" - (_, _) -> "{\n" ++ (unlines $ map next l) ++ spaces i ++ "}" - where next = treestr (i+1) - -- - spaces i = take i $ repeat ' ' - in treestr 0 t - -instance GeniShow TagElem where - geniShow te = - "\n% ------------------------- " ++ idname te - ++ "\n" ++ (ttreename te) ++ ":" ++ (idname te) - ++ " " ++ (geniShow.tinterface $ te) - ++ " " ++ (geniShow.ttype $ te) - ++ "\n" ++ (geniShow.ttree $ te) - ++ "\n" ++ geniShowKeyword "semantics" "" ++ (geniShow.tsemantics $ te) - -instance (GeniShow a) => GeniShow (Ttree a) where - geniShow tt = - "\n% ------------------------- " ++ pidname tt - ++ "\n" ++ (pfamily tt) ++ ":" ++ (pidname tt) - ++ " " ++ (parens $ (unwords $ map geniShow $ params tt) - ++ " ! " - ++ (unwords $ map geniShow $ pinterface tt)) - ++ " " ++ (geniShow.ptype $ tt) - ++ "\n" ++ (geniShow.tree $ tt) - ++ (case psemantics tt of - Nothing -> "" - Just psem -> "\n" ++ geniShowKeyword "semantics" (geniShow psem)) - ++ "\n" ++ geniShowKeyword "trace" (squares.unwords.ptrace $ tt) + geniShowText = geniShowTree 0 -instance GeniShow TestCase where - geniShow (TestCase { tcName = name - , tcExpected = sentences - , tcOutputs = outputs - , tcSemString = semStr - , tcSem = sem }) = - unlines $ [ name, semS ] - ++ map (geniShowKeyword "sentence" . squares) sentences - ++ (concat.prettify.map outStuff $ outputs) +geniShowTree :: GeniShow a => Int -> Tree a -> Text +geniShowTree i (Node a l) = + spaces <> geniShowText a <> rest where - semS = if null semStr then geniShowSemInput sem "" else semStr - prettify = if all (Map.null . snd) outputs then id else map ("":) - gshowTrace ((k1,k2),ts) = - geniShowKeyword "trace" . squares . showString (k1 ++ " " ++ k2 ++ " ! " ++ unwords ts) $ "" - outStuff (o,ds) = - [ geniShowKeyword "output" . squares $ o ] - ++ (map gshowTrace $ Map.toList ds) + rest = case (l,i) of + ([], 0) -> "{}" + ([], _) -> "" + (_, _) -> "{\n" <> T.unlines (map next l) + <> spaces + <> "}" + next = geniShowTree (i+1) + spaces = T.pack (replicate i ' ') +{- +geniShowSmallList :: GeniShow a => [a] -> String +geniShowSmallList = squares . unwords . (map geniShow) -parens, squares :: String -> String -parens s = "(" ++ s ++ ")" -squares s = "[" ++ s ++ "]" +instance GeniShow [Literal] where + geniShow = geniShowSmallList -geniShowKeyword :: String -> ShowS -geniShowKeyword k = showString k . showChar ':' +instance GeniShow (AvPair v) => GeniShow [AvPair v] where + geniShow = geniShowSmallList -geniShowSemInput :: SemInput -> ShowS -geniShowSemInput (sem,icons,lcons) = - let withConstraints lit = - case concat [ cs | (p,cs) <- lcons, p == lit ] of - [] -> geniShow lit - cs -> geniShow lit ++ (squares . unwords $ cs) - semStuff = geniShowKeyword "semantics" . squares - . (showString . unwords . map withConstraints $ sem) - idxStuff = geniShowKeyword "idxconstraints" - . (showString . geniShow $ icons) . squares - in semStuff . (if null icons then id else showChar '\n' . idxStuff) +-} + +geniKeyword :: Text -> Text -> Text +geniKeyword k t = k `T.append` ":" `T.append` t diff --git a/src/NLP/GenI/GeniVal.hs b/src/NLP/GenI/GeniVal.hs --- a/src/NLP/GenI/GeniVal.hs +++ b/src/NLP/GenI/GeniVal.hs @@ -16,294 +16,31 @@ -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -{-# LANGUAGE OverlappingInstances, FlexibleInstances, DeriveDataTypeable #-} -module NLP.GenI.GeniVal where - --- import Debug.Trace -- for test stuff -import Control.Arrow (first, (***)) -import Control.Monad (liftM) -import Data.List -import Data.Maybe (fromMaybe, isJust) -import Data.Generics (Data) -import Data.Typeable (Typeable) -import qualified Data.Map as Map - -import Test.HUnit -import Test.QuickCheck hiding (collect) -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck - -import Data.Generics.PlateDirect - -import Control.Parallel.Strategies - -import NLP.GenI.General (geniBug) - -data GeniVal = GConst [String] -- ^ atomic disjunction - constant x | y | z - | GVar String -- ^ variable - | GAnon -- ^ anonymous - deriving (Eq,Ord, Data, Typeable) - -instance Uniplate GeniVal where - uniplate x = (Zero, \Zero -> x) - -instance Show GeniVal where - show (GConst x) = concat $ intersperse "|" x - show (GVar x) = '?':x - show GAnon = "?_" - -isConst :: GeniVal -> Bool -isConst (GConst _) = True -isConst _ = False - -isVar :: GeniVal -> Bool -isVar (GVar _) = True -isVar _ = False - -isAnon :: GeniVal -> Bool -isAnon GAnon = True -isAnon _ = False - --- | (assumes that it's a GConst!) -fromGConst :: GeniVal -> [String] -fromGConst (GConst x) = x -fromGConst x = error ("fromGConst on " ++ show x) - --- | (assumes that it's a GVar!) -fromGVar :: GeniVal -> String -fromGVar (GVar x) = x -fromGVar x = error ("fromGVar on " ++ show x) - --- ---------------------------------------------------------------------- --- Helper types --- ---------------------------------------------------------------------- - -type Subst = Map.Map String GeniVal - --- ---------------------------------------------------------------------- --- Unification --- ---------------------------------------------------------------------- - --- | 'unify' performs unification on two lists of 'GeniVal'. If --- unification succeeds, it returns @Just (r,s)@ where \verb!r! is --- the result of unification and \verb!s! is a list of substitutions that --- this unification results in. -unify :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) -unify l1 l2 = repropagate `liftM` helper l1 l2 - where - repropagate (xs, sub) = (replace sub xs, sub) - helper [] l2 = return (l2, Map.empty) - helper l1 [] = return (l1, Map.empty) - helper (h1:t1) (h2:t2) = - case unifyOne h1 h2 of - Failure -> fail $ "unification failure between " ++ show h1 ++ " and " ++ show h2 - SuccessRep v g -> prepend `liftM` helper t1b t2b - where - s = (v,g) - t1b = replaceOne s t1 - t2b = replaceOne s t2 - prepend = (g:) *** prependToSubst s - SuccessSans g -> first (g:) `liftM` helper t1 t2 - --- | Note that the first Subst is assumed to come chronologically --- before the second one; so merging @{ X -> Y }@ and @{ Y -> 3 }@ --- should give us @{ X -> 3; Y -> 3 }@; --- --- See 'prependToSubst' for a warning! -mergeSubst :: Subst -> Subst -> Subst -mergeSubst sm1 sm2 = Map.foldWithKey (curry prependToSubst) sm2 sm1 - --- | Add to variable replacement to a 'Subst' that logical comes before --- the other stuff in it. So for example, if we have @Y -> foo@ --- and we want to insert @X -> Y@, we notice that, in fact, @Y@ has --- already been replaced by @foo@, so we add @X -> foo@ instead --- --- Note that it is undefined if you try to append something like --- @Y -> foo@ to @Y -> bar@, because that would mean that unification --- is broken -prependToSubst :: (String,GeniVal) -> Subst -> Subst -prependToSubst (v, gr@(GVar r)) sm = - case Map.lookup v sm of - Just v2 -> geniBug . unlines $ - [ "prependToSubst: GenI just tried to prepend the substitution" - , " " ++ show (GVar v) ++ " -> " ++ show gr - , "to one where where " - , " " ++ show (GVar v) ++ " -> " ++ show v2 - , "is slated to occur afterwards." - , "" - , "This could mean that either" - , " (a) the core unification algorithm is broken" - , " (b) we failed to propagate a value somewhere or" - , " (c) we are attempting unification without renaming." - ] - Nothing -> Map.insert v gr2 sm - where gr2 = fromMaybe gr $ Map.lookup r sm -prependToSubst (v, gr) sm = Map.insert v gr sm - --- ---------------------------------------------------------------------- --- Core unification --- TODO: would continuation passing style make this more efficient? --- ---------------------------------------------------------------------- - -data UnificationResult = SuccessSans GeniVal - | SuccessRep String GeniVal - | Failure - --- | See source code for details -unifyOne :: GeniVal -> GeniVal -> UnificationResult -unifyOne g GAnon = SuccessSans g -unifyOne GAnon g = SuccessSans g -unifyOne (GVar v) gc@(GConst _) = SuccessRep v gc -unifyOne gc@(GConst _) (GVar v) = SuccessRep v gc -unifyOne (GConst v1) (GConst v2) = - case v1 `intersect` v2 of - [] -> Failure - newV -> SuccessSans (GConst newV) -unifyOne x1@(GVar v1) (GVar v2) = - if v1 == v2 - then SuccessSans x1 - else SuccessRep v2 x1 - --- ---------------------------------------------------------------------- --- Variable substitution --- ---------------------------------------------------------------------- - -replace :: DescendGeniVal a => Subst -> a -> a -replace m | Map.null m = id -replace m = descendGeniVal (replaceMapG m) - -replaceOne :: DescendGeniVal a => (String, GeniVal) -> a -> a -replaceOne = descendGeniVal . replaceOneG - --- | Here it is safe to say (X -> Y; Y -> Z) because this would be crushed --- down into a final value of (X -> Z; Y -> Z) -replaceList :: DescendGeniVal a => [(String,GeniVal)] -> a -> a -replaceList = replace . foldl' update Map.empty - where - update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m - -replaceMapG :: Subst -> GeniVal -> GeniVal -replaceMapG m v@(GVar v_) = {-# SCC "replaceMapG" #-} Map.findWithDefault v v_ m -replaceMapG _ v = {-# SCC "replaceMapG" #-} v - -replaceOneG :: (String, GeniVal) -> GeniVal -> GeniVal -replaceOneG (s1, s2) (GVar v_) | v_ == s1 = {-# SCC "replaceOneG" #-} s2 -replaceOneG _ v = {-# SCC "replaceOneG" #-} v - --- ---------------------------------------------------------------------- --- Performance --- ---------------------------------------------------------------------- - -instance NFData GeniVal - where rnf (GConst x1) = rnf x1 - rnf (GVar x1) = rnf x1 - rnf (GAnon) = () - --- ---------------------------------------------------------------------- --- Genericity --- ---------------------------------------------------------------------- - -class DescendGeniVal a where - descendGeniVal :: (GeniVal -> GeniVal) -> a -> a - -instance DescendGeniVal GeniVal where - descendGeniVal f = f - -instance (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where - descendGeniVal = fmap . descendGeniVal - --- ---------------------------------------------------------------------- --- Testing --- ---------------------------------------------------------------------- - -testSuite = testGroup "unification" - [ testProperty "self" prop_unify_sym - , testProperty "anonymous variables" prop_unify_anon - , testProperty "symmetry" prop_unify_sym - , testBackPropagation - ] - --- | Unifying something with itself should always succeed -prop_unify_self :: [GeniVal] -> Property -prop_unify_self x = - (all qc_not_empty_GConst) x ==> - case unify x x of - Nothing -> False - Just unf -> fst unf == x - --- | Unifying something with only anonymous variables should succeed and return --- the same result. -prop_unify_anon :: [GeniVal] -> Bool -prop_unify_anon x = - case unify x y of - Nothing -> False - Just unf -> fst unf == x - where -- - y = replicate (length x) GAnon - --- | Unification should be symmetrical. We can't guarantee these if there --- are cases where there are variables in the same place on both sides, so we --- normalise the sides so that this doesn't happen. -prop_unify_sym :: [GeniVal] -> [GeniVal] -> Property -prop_unify_sym x y = - let u1 = (unify x y) :: Maybe ([GeniVal],Subst) - u2 = unify y x - -- - notOverlap (GVar _, GVar _) = False - notOverlap _ = True - in (all qc_not_empty_GConst) x && - (all qc_not_empty_GConst) y && - all (notOverlap) (zip x y) ==> u1 == u2 - -testBackPropagation = - testGroup "back propagation" - [ testCase "unify left/right" $ assertEqual "" expected $ unify left right - , testCase "unify right/left" $ assertEqual "" expected $ unify right left - ] - where - n = 3 - cx = GConst ["X"] - leftStrs = map show [1..n] - left = map GVar leftStrs - right = drop 1 left ++ [cx] - expected = Just (expectedResult, expectedSubst) - expectedResult = replicate n cx - expectedSubst = Map.fromList $ zip leftStrs (repeat cx) - --- ---------------------------------------------------------------------- --- Testing --- ---------------------------------------------------------------------- - --- Definition of Arbitrary GeniVal for QuickCheck -newtype GTestString = GTestString String -newtype GTestString2 = GTestString2 String - -fromGTestString :: GTestString -> String -fromGTestString (GTestString s) = s - -fromGTestString2 :: GTestString2 -> String -fromGTestString2 (GTestString2 s) = s - -instance Arbitrary GTestString where - arbitrary = - oneof $ map (return . GTestString) $ - [ "a", "apple" , "b", "banana", "c", "carrot", "d", "durian" - , "e", "eggplant", "f", "fennel" , "g", "grape" ] - coarbitrary = error "no implementation of coarbitrary for GTestString" - -instance Arbitrary GTestString2 where - arbitrary = - oneof $ map (return . GTestString2) $ - [ "X", "Y", "Z", "H", "I", "J", "P", "Q", "R", "S", "T", "U" ] - coarbitrary = error "no implementation of coarbitrary for GTestString2" +{-# LANGUAGE OverlappingInstances, FlexibleInstances, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +module NLP.GenI.GeniVal + ( -- * GeniVal + GeniVal, gLabel, gConstraints + , mkGConst, mkGConstNone, mkGVar, mkGVarNone, mkGAnon + -- ** queries and manipulation + , isVar, isAnon, isConst, singletonVal + , crushOne + -- * Unification and subsumption + -- + -- ** Finalisation + -- + -- Before you do any unification/subsumption, you should finalise all + -- the variables in all the objects (a one time alpha-conversion type + -- thing) + , finaliseVars, finaliseVarsById + -- ** Unification + , unify, UnificationResult(..), Subst, appendSubst + -- ** subsumption + , subsumeOne, allSubsume -instance Arbitrary GeniVal where - arbitrary = oneof [ return $ GAnon, - fmap (GVar . fromGTestString2) arbitrary, - fmap (GConst . nub . sort . map fromGTestString) arbitrary ] - coarbitrary = error "no implementation of coarbitrary for GeniVal" + -- * Traversing GeniVal containers + , DescendGeniVal(..), Collectable(..), Idable(..) + , replace, replaceList + ) where -qc_not_empty_GConst :: GeniVal -> Bool -qc_not_empty_GConst (GConst []) = False -qc_not_empty_GConst _ = True +import NLP.GenI.GeniVal.Internal diff --git a/src/NLP/GenI/GeniVal/Internal.hs b/src/NLP/GenI/GeniVal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/GeniVal/Internal.hs @@ -0,0 +1,428 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- Copyright (C) 2005 Carlos Areces +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE OverlappingInstances, FlexibleInstances, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.GeniVal.Internal where + +-- import Debug.Trace -- for test stuff +import Control.Arrow (first, (***)) +import Control.Monad (liftM) +import Data.Binary +import Data.List +import Data.Maybe (fromMaybe, isNothing, isJust) +import Data.Generics (Data) +import Data.Typeable (Typeable) +import qualified Data.Map as Map + +import Data.Text ( Text ) +import qualified Data.Text as T + +import Control.DeepSeq + +import Data.FullList ( FullList, fromFL, Listable(..), sortNub ) +import NLP.GenI.General (geniBug, quoteText, isGeniIdentLetter) +import NLP.GenI.GeniShow +import NLP.GenI.Pretty + +-- | constant : no label, just constraints +-- variable : label, with or without constraints +-- anonymous : no label, no constraints +data GeniVal = GeniVal { gLabel :: Maybe Text + , gConstraints :: Maybe (FullList Text) + } + deriving (Eq,Ord, Data, Typeable) + +-- | 'mkGConst' @x :! []@ creates a single constant. 'mkGConst' @x :! xs@ +-- creates an atomic disjunction. It makes no difference which of the values +-- you supply for @x@ and @xs@ as they will be sorted and nubed anyway. +mkGConst :: FullList Text -- ^ non-empty list + -> GeniVal +mkGConst cs_ = GeniVal Nothing (Just cs) + where + cs = sortNub cs_ + +mkGConstNone :: Text -> GeniVal +mkGConstNone x = mkGConst (x !: []) + +mkGVar :: Text -> Maybe (FullList Text) -> GeniVal +mkGVar x mxs = GeniVal (Just x) (sortNub `fmap` mxs) + +mkGVarNone :: Text -> GeniVal +mkGVarNone x = mkGVar x Nothing + +mkGAnon :: GeniVal +mkGAnon = GeniVal Nothing Nothing + +{- +instance Show GeniVal where + show = T.unpack . prettyGeniVal +-} + +instance Pretty GeniVal where + pretty = geniShowText + +instance GeniShow GeniVal where + geniShowText gv = + case gv of + GeniVal Nothing Nothing -> showLabel "_" + GeniVal Nothing (Just cs) -> showConstraints cs + GeniVal (Just l) Nothing -> showLabel l + GeniVal (Just l) (Just cs) -> + showLabel l `T.append` "/" `T.append` showConstraints cs + where + showLabel l = '?' `T.cons` l + showConstraints = T.intercalate "|" . map maybeQuote . fromFL -- FIXME push down + maybeQuote x | T.null x = quoteText "" + | "-" `T.isPrefixOf` x = quoteText x -- could be interpreted as + | "+" `T.isPrefixOf` x = quoteText x -- semantic polarities + | T.any naughty x = quoteText x + | otherwise = x + naughty x = not (isGeniIdentLetter x) || x `elem` "_?/" + +isConst :: GeniVal -> Bool +isConst = isNothing . gLabel + +singletonVal :: GeniVal -> Maybe Text +singletonVal v = + case fmap fromFL (gConstraints v) of + Just [o] -> Just o + _ -> Nothing + +isVar :: GeniVal -> Bool +isVar = isJust . gConstraints + +isAnon :: GeniVal -> Bool +isAnon (GeniVal Nothing Nothing) = True +isAnon _ = False + +-- ---------------------------------------------------------------------- +-- Helper types +-- ---------------------------------------------------------------------- + +type Subst = Map.Map Text GeniVal + +prettySubst :: Subst -> Text +prettySubst = + T.unwords . map sho . Map.toList + where + sho (v,s) = v `T.append` "<-" `T.append` pretty s + +-- ---------------------------------------------------------------------- +-- Unification and subsumption +-- ---------------------------------------------------------------------- + +-- | 'unify' performs unification on two lists of 'GeniVal'. If +-- unification succeeds, it returns @Just (r,s)@ where @r@ is +-- the result of unification and \verb!s! is a list of substitutions that +-- this unification results in. +unify :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) +unify = unifyHelper unifyOne + +-- | @l1 `allSubsume` l2@ returns the result of @l1 `unify` l2@ if +-- doing a simultaneous traversal of both lists, each item in +-- @l1@ subsumes the corresponding item in @l2@ +allSubsume :: Monad m => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst) +allSubsume = unifyHelper subsumeOne + +unifyHelper :: Monad m + => (GeniVal -> GeniVal -> UnificationResult) + -> [GeniVal] + -> [GeniVal] + -> m ([GeniVal], Subst) +unifyHelper f ll1 ll2 = repropagate `liftM` helper ll1 ll2 + where + repropagate (xs, sub) = (replace sub xs, sub) + helper [] l2 = return (l2, Map.empty) + helper l1 [] = return (l1, Map.empty) + helper (h1:t1) (h2:t2) = + case f h1 h2 of + Failure -> fail . T.unpack . T.unwords $ + [ "unification failure between" + , pretty h1, "and" + , pretty h2 + ] + SuccessRep v g -> prepend `liftM` helper t1b t2b + where + s = (v,g) + t1b = replaceOne s t1 + t2b = replaceOne s t2 + prepend = (g:) *** prependToSubst s + SuccessRep2 v1 v2 g -> prepend `liftM` helper t1b t2b + where + s1 = (v1,g) + s2 = (v2,g) + t1b = replaceOne s2 . replaceOne s1 $ t1 + t2b = replaceOne s2 . replaceOne s1 $ t2 + prepend = (g:) *** (prependToSubst s1 . prependToSubst s2) + SuccessSans g -> first (g:) `liftM` helper t1 t2 + +-- | Note that the first Subst is assumed to come chronologically +-- before the second one; so merging @{ X -> Y }@ and @{ Y -> 3 }@ +-- should give us @{ X -> 3; Y -> 3 }@; +-- +-- See 'prependToSubst' for a warning! +appendSubst :: Subst -> Subst -> Subst +appendSubst sm1 sm2 = Map.foldrWithKey (curry prependToSubst) sm2 sm1 + +-- | Add to variable replacement to a 'Subst' that logical comes before +-- the other stuff in it. So for example, if we have @Y -> foo@ +-- and we want to insert @X -> Y@, we notice that, in fact, @Y@ has +-- already been replaced by @foo@, so we add @X -> foo@ instead +-- +-- Note that it is undefined if you try to append something like +-- @Y -> foo@ to @Y -> bar@, because that would mean that unification +-- is broken +prependToSubst :: (Text,GeniVal) -> Subst -> Subst +prependToSubst (v, gr@(GeniVal (Just r) _)) sm = + case Map.lookup v sm of + Just v2 -> geniBug . unlines $ + [ "prependToSubst: GenI just tried to prepend the substitution" + , " " ++ prettyStr (mkGVar v Nothing) ++ " -> " ++ prettyStr gr + , "to one where where " + , " " ++ prettyStr (mkGVar v Nothing) ++ " -> " ++ prettyStr v2 + , "is slated to occur afterwards." + , "" + , "This could mean that either" + , " (a) the core unification algorithm is broken" + , " (b) we failed to propagate a value somewhere or" + , " (c) we are attempting unification without renaming." + ] + Nothing -> Map.insert v gr2 sm + where gr2 = fromMaybe gr $ Map.lookup r sm +prependToSubst (v, gr) sm = Map.insert v gr sm + +-- ---------------------------------------------------------------------- +-- Core unification +-- TODO: would continuation passing style make this more efficient? +-- ---------------------------------------------------------------------- + +data UnificationResult = SuccessSans GeniVal + | SuccessRep Text GeniVal + | SuccessRep2 Text Text GeniVal + | Failure + +-- | See source code for details +-- +-- Note that we assume that it's acceptable to generate new +-- variable names by appending an 'x' to them; this assumption +-- is only safe if the variables have gone through the function +-- 'finaliseVarsById' or have been pre-processed and rewritten +-- with some kind of common suffix to avoid an accidental match +unifyOne :: GeniVal -> GeniVal -> UnificationResult +unifyOne (GeniVal Nothing Nothing) g = SuccessSans g +unifyOne g (GeniVal Nothing Nothing) = SuccessSans g +unifyOne g1 g2 = + maybe Failure constrSuccess (intersectConstraints gc1 gc2) + where + gc1 = gConstraints g1 + gc2 = gConstraints g2 + constrSuccess cs = + case (gLabel g1, gLabel g2) of + (Nothing, Nothing) -> SuccessSans (GeniVal Nothing cs) + (Nothing, Just v) -> SuccessRep v (GeniVal Nothing cs) + (Just v, Nothing) -> SuccessRep v (GeniVal Nothing cs) + (Just v1, Just v2) -> bothLabeled cs v1 v2 + bothLabeled cs v1 v2 + | v1 == v2 && gc1 /= gc2 = geniBug constraintBug + | v1 == v2 = SuccessSans g1 + | gc1 == gc2 = successSameConstraints cs v1 v2 + | otherwise = successDiffConstraints cs v1 v2 + successSameConstraints cs v1 v2 = + SuccessRep (min v1 v2) $ GeniVal (Just (max v1 v2)) cs + successDiffConstraints cs v1 v2 = + -- min/max stuff for symmetry + SuccessRep2 (min v1 v2) (max v1 v2) $ + GeniVal (Just (max v1 v2 `T.append` "-g")) cs + constraintBug = unwords + [ "I just tried to unify variable with itself," + , "but it has mismatching constraints:" + , prettyStr g1, "vs." + , prettyStr g2 + ] + +intersectConstraints :: Eq a => Maybe (FullList a) -> Maybe (FullList a) -> Maybe (Maybe (FullList a)) +intersectConstraints Nothing cs = Just cs +intersectConstraints cs Nothing = Just cs +intersectConstraints (Just v1) (Just v2) = + case fromFL v1 `intersect` fromFL v2 of + [] -> Nothing + (x:xs) -> Just (Just (x !: xs)) + +-- ---------------------------------------------------------------------- +-- Core subsumption +-- ---------------------------------------------------------------------- + +-- | 'subsumeOne' @x y@ returns the same result as @unifyOne x y@ if @x@ +-- subsumes @y@ or 'Failure' otherwise +subsumeOne :: GeniVal -> GeniVal -> UnificationResult +subsumeOne g1@(GeniVal _ (Just cs1)) g2@ (GeniVal _ (Just cs2)) = + if fromFL cs1 `subset` fromFL cs2 then unifyOne g1 g2 else Failure + where + subset x y = all (`elem` y) x +subsumeOne (GeniVal _ (Just _)) (GeniVal _ Nothing) = Failure +subsumeOne g1@(GeniVal _ Nothing) g2 = unifyOne g1 g2 + +-- ---------------------------------------------------------------------- +-- Variable substitution +-- ---------------------------------------------------------------------- + +replace :: DescendGeniVal a => Subst -> a -> a +replace m | Map.null m = id +replace m = descendGeniVal (replaceMapG m) + +replaceOne :: DescendGeniVal a => (Text, GeniVal) -> a -> a +replaceOne = descendGeniVal . replaceOneG + +-- | Here it is safe to say (X -> Y; Y -> Z) because this would be crushed +-- down into a final value of (X -> Z; Y -> Z) +replaceList :: DescendGeniVal a => [(Text,GeniVal)] -> a -> a +replaceList = replace . foldl' update Map.empty + where + update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m + +replaceMapG :: Subst -> GeniVal -> GeniVal +replaceMapG m v@(GeniVal (Just v_) _) = Map.findWithDefault v v_ m +replaceMapG _ v = v + +replaceOneG :: (Text, GeniVal) -> GeniVal -> GeniVal +replaceOneG (s1, s2) (GeniVal (Just v_) _) | v_ == s1 = s2 +replaceOneG _ v = v + +-- ---------------------------------------------------------------------- +-- Variable collection and renaming +-- ---------------------------------------------------------------------- + +type CollectedVar = (Text, Maybe (FullList Text)) + +-- | A 'Collectable' is something which can return its variables as a +-- map from the variable to the number of times that variable occurs +-- in it. +-- +-- Important invariant: if the variable does not occur, then it does +-- not appear in the map (ie. all counts must be >= 1 or the item +-- does not occur at all) +-- +-- By variables, what I most had in mind was the GVar values in a +-- GeniVal. This notion is probably not very useful outside the context of +-- alpha-conversion task, but it seems general enough that I'll keep it +-- around for a good bit, until either some use for it creeps up, or I find +-- a more general notion that I can transform this into. +class Collectable a where + collect :: a -> Map.Map CollectedVar Int -> Map.Map CollectedVar Int + +instance Collectable a => Collectable (Maybe a) where + collect Nothing s = s + collect (Just x) s = collect x s + +instance (Collectable a => Collectable [a]) where + collect l s = foldr collect s l + +instance Collectable GeniVal where + collect (GeniVal (Just v) cs) s = Map.insertWith' (+) (v,cs) 1 s + collect (GeniVal Nothing _) s = s + +-- | An Idable is something that can be mapped to a unique id. +-- You might consider using this to implement Ord, but I won't. +-- Note that the only use I have for this so far (20 dec 2005) +-- is in alpha-conversion. +class Idable a where + idOf :: a -> Integer + +-- | Anonymise any variable that occurs only once in the object +anonymiseSingletons :: (Collectable a, DescendGeniVal a) => a -> a +anonymiseSingletons x = + replace subst x + where + subst = Map.map (const mkGAnon) . Map.filter (== 1) + -- merge counts for same var, different constraints + . Map.fromListWith (+) . map (first fst) . Map.toList + $ collect x Map.empty + +-- 'finaliseVarsById' appends a unique suffix to all variables in +-- an object. This avoids us having to alpha convert all the time +-- and relies on the assumption finding that a unique suffix is +-- possible. +finaliseVarsById :: (Collectable a, DescendGeniVal a, Idable a) => a -> a +finaliseVarsById x = finaliseVars ('-' `T.cons` (T.pack . show $ idOf x)) x + +-- | 'finaliseVars' does the following: +-- +-- * (if suffix is non-null) appends a suffix to all variable names +-- to ensure global uniqueness +-- +-- * anonymises any singleton variables +--- +--- * intersects constraints for for all variables within the same +--- object +finaliseVars :: (Collectable a, DescendGeniVal a) => Text -> a -> a +finaliseVars suffix x = {-# SCC "finaliseVars" #-} + replace subst (anonymiseSingletons x) + where + subst :: Subst + subst = Map.mapWithKey convert vars + vars = Map.fromListWithKey isect $ Map.keys (collect x Map.empty) + -- TODO: ugh: this is maybe not ideal: if a variable has impossible + -- constraints (eg. ?X/cat cannot unify with ?X/dog, but it can + -- unify with ?X/cat vs ?X/dog|cat => ?X/cat), we hardcode it to a + -- value that should not be able to unify with anything + isect k xi yi = + fromMaybe (Just (impossibleC k)) $ intersectConstraints xi yi + convert v = GeniVal (Just (v `T.append` suffix)) + impossibleC v = ("ERROR_impossible_constraints_" `T.append` v `T.append` suffix) + !: [] + +-- ---------------------------------------------------------------------- +-- Fancy disjunction +-- ---------------------------------------------------------------------- + +crushOne :: [GeniVal] -> Maybe GeniVal +crushOne [] = Nothing +crushOne [gs] = Just gs +crushOne gs = + if any isNothing gcs + then Nothing + else case concat [ fromFL c | Just c <- gcs ] of + [] -> Nothing + (c:cs) -> Just (mkGConst (c !: cs)) + where + gcs = map gConstraints gs + +crushList :: [[GeniVal]] -> Maybe [GeniVal] +crushList = mapM crushOne + +-- ---------------------------------------------------------------------- +-- Genericity +-- ---------------------------------------------------------------------- + +class DescendGeniVal a where + descendGeniVal :: (GeniVal -> GeniVal) -> a -> a + +instance DescendGeniVal GeniVal where + descendGeniVal f = f + +instance (Functor f, DescendGeniVal a) => DescendGeniVal (f a) where + descendGeniVal = fmap . descendGeniVal + +instance NFData GeniVal where + rnf (GeniVal x y) = rnf x `seq` rnf y + +instance Binary GeniVal where + put (GeniVal a b) = put a >> put b + get = get >>= \a -> get >>= \b -> return (GeniVal a b) diff --git a/src/NLP/GenI/Graphviz.hs b/src/NLP/GenI/Graphviz.hs deleted file mode 100644 --- a/src/NLP/GenI/Graphviz.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} - -{- - GenI surface realiser - Copyright (C) 2005 Carlos Areces and Eric Kow - - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU General Public License - as published by the Free Software Foundation; either version 2 - of the License, or (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --} - -{- | Graphviz is an open source tool which converts an abstract - representation of a graph (node foo is connected to node bar, etc.) - into a nicely laid out graphic. This module contains methods - to invoke graphviz and to convert graphs and trees to its input format. - - You can download this (open source) tool at - --} - -module NLP.GenI.Graphviz -where - -import Control.Monad(when) -import Data.List(intersperse) -import Data.Tree -import System.IO ( hClose ) -import System.IO.UTF8 -import Prelude hiding ( writeFile ) -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=utf-8", - "-Tpng", "-o" ++ outputFile ] - dotArgs = dotArgs' ++ (if (null dotFile) then [] else [dotFile]) - -- putStrLn ("sending to graphviz:\n" ++ dot) - when (not $ null dotFile) $ writeFile dotFile dot - (_, toGV, _, pid) <- runInteractiveProcess "dot" dotArgs Nothing Nothing - when (null dotFile) $ do - hPutStrLn toGV dot - hClose toGV - waitForProcess pid diff --git a/src/NLP/GenI/GraphvizShow.hs b/src/NLP/GenI/GraphvizShow.hs deleted file mode 100644 --- a/src/NLP/GenI/GraphvizShow.hs +++ /dev/null @@ -1,199 +0,0 @@ --- GenI surface realiser --- Copyright (C) 2009 Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | Outputting core GenI data to graphviz. -module NLP.GenI.GraphvizShow -where - -import Data.List(intersperse,nub) -import Data.List.Split (wordsBy) -import Data.Maybe(listToMaybe) - -import NLP.GenI.Tags - ( TagElem, TagDerivation, idname, - tsemantics, ttree, - DerivationStep(..), - ) -import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), - GNode(..), GType(..), Flist, - isConst, - showSem, - ) -import NLP.GenI.Graphviz - ( gvUnlines, gvNewline - , GraphvizShow(graphvizShowAsSubgraph, graphvizLabel, graphvizParams) - , GraphvizShowNode(graphvizShowNode) - , GraphvizShowString(graphvizShow) - , gvNode, gvEdge, gvShowTree - ) - --- ---------------------------------------------------------------------- --- For GraphViz --- ---------------------------------------------------------------------- - -type GvHighlighter a = a -> (a, Maybe String) - -nullHighlighter :: GvHighlighter GNode -nullHighlighter a = (a,Nothing) - -instance GraphvizShow Bool TagElem where - graphvizShowAsSubgraph sf = graphvizShowAsSubgraph (sf, nullHighlighter) - graphvizLabel sf = graphvizLabel (sf, nullHighlighter ) - graphvizParams sf = graphvizParams (sf, nullHighlighter) - - -instance GraphvizShow (Bool, GvHighlighter GNode) TagElem where - graphvizShowAsSubgraph (sf,hfn) prefix te = - (gvShowTree (\_->[]) sf (prefix ++ "DerivedTree0") $ - fmap hfn $ ttree te) - - graphvizLabel _ te = - -- we display the tree semantics as the graph label - let treename = "name: " ++ (idname te) - semlist = "semantics: " ++ (showSem $ tsemantics te) - in gvUnlines [ treename, semlist ] - - graphvizParams _ _ = - [ "fontsize = 10", "ranksep = 0.3" - , "node [fontsize=10]" - , "edge [fontsize=10 arrowhead=none]" ] - --- ---------------------------------------------------------------------- --- Helper functions for the TagElem GraphvizShow instance --- ---------------------------------------------------------------------- - -instance GraphvizShowNode (Bool) (GNode, Maybe String) where - -- compact -> (node, mcolour) -> String - graphvizShowNode detailed prefix (gn, mcolour) = - let -- attributes - filledParam = ("style", "filled") - fillcolorParam = ("fillcolor", "lemonchiffon") - shapeRecordParam = ("shape", "record") - shapePlaintextParam = ("shape", "plaintext") - -- - colorParams = case mcolour of - Nothing -> [] - Just c -> [ ("fontcolor", c) ] - shapeParams = if detailed - then [ shapeRecordParam, filledParam, fillcolorParam ] - else [ shapePlaintextParam ] - -- content - stub = showGnStub gn - extra = showGnDecorations gn - summary = if null extra then stub - else "{" ++ stub ++ "|" ++ extra ++ "}" - -- - body = if not detailed then graphvizShow_ gn - else "{" ++ summary - ++ (barAnd.showFs $ gup gn) - ++ (maybeShow (barAnd.showFs) $ gdown gn) - ++ "}" - where barAnd x = "|" ++ x - showFs = gvUnlines . (map graphvizShow_) - in gvNode prefix body (shapeParams ++ colorParams) - -instance GraphvizShowString () GNode where - graphvizShow () gn = - let stub = showGnStub gn - extra = showGnDecorations gn - in stub ++ extra - -instance GraphvizShowString () AvPair where - graphvizShow () (AvPair a v) = a ++ ":" ++ graphvizShow_ v - -instance GraphvizShowString () GeniVal where - graphvizShow () (GConst x) = concat $ intersperse " ! " x - graphvizShow () x = show x - -showGnDecorations :: GNode -> String -showGnDecorations gn = - case gtype gn of - Subs -> "↓" - Foot -> "*" - _ -> if gaconstr gn then "ᴺᴬ" else "" - -showGnStub :: GNode -> String -showGnStub gn = - let cat = case getGnVal gup "cat" gn of - Nothing -> "" - Just v -> graphvizShow_ v - -- - getIdx f = - case getGnVal f "idx" gn of - Nothing -> "" - Just v -> if isConst v then graphvizShow_ v else "" - idxT = getIdx gup - idxB = getIdx gdown - idx = idxT ++ (maybeShow_ "." idxB) - -- - lexeme = concat $ intersperse "!" $ glexeme gn - in concat $ intersperse ":" $ filter (not.null) [ cat, idx, lexeme ] - -getGnVal :: (GNode -> Flist) -> String -> GNode -> Maybe GeniVal -getGnVal getFeat attr gn = - listToMaybe [ v | AvPair a v <- getFeat gn, a == attr ] - --- | Apply fn to s if s is not null -maybeShow :: ([a] -> String) -> [a] -> String -maybeShow fn s = if null s then "" else fn s --- | Prefix a string if it is not null -maybeShow_ :: String -> String -> String -maybeShow_ prefix s = maybeShow (prefix++) s - -graphvizShow_ :: (GraphvizShowString () a) => a -> String -graphvizShow_ = graphvizShow () - --- ---------------------------------------------------------------------- --- Derivation tree --- ---------------------------------------------------------------------- - -graphvizShowDerivation :: TagDerivation -> String -graphvizShowDerivation deriv = - if (null histNodes) - then "" - else " node [ shape = plaintext ];\n" - ++ (concatMap showHistNode histNodes) - ++ (concatMap graphvizShowDerivation' deriv) - where showHistNode n = gvNode (gvDerivationLab n) (label n) [] - label n = case wordsBy (== ':') n of - name:fam:tree:_ -> name ++ ":" ++ fam ++ gvNewline ++ tree - _ -> n ++ " (geni/gv ERROR)" - histNodes = reverse $ nub $ concatMap (\ (DerivationStep _ c p _) -> [c,p]) deriv - -graphvizShowDerivation' :: DerivationStep -> String -graphvizShowDerivation' (DerivationStep substadj child parent _) = - gvEdge (gvDerivationLab parent) (gvDerivationLab child) "" p - where p = if substadj == 'a' then [("style","dashed")] else [] - - -gvDerivationLab :: String -> String -gvDerivationLab xs = "Derivation" ++ gvMunge xs - -newlineToSlashN :: Char -> String -newlineToSlashN '\n' = gvNewline -newlineToSlashN x = [x] - --- | Node names can't have hyphens in them and newlines within the node --- labels should be represented literally as @\\n@. -gvMunge :: String -> String -gvMunge = map dot2x . filter (/= ':') . filter (/= '-') - -dot2x :: Char -> Char -dot2x '.' = 'x' -dot2x c = c diff --git a/src/NLP/GenI/GraphvizShowPolarity.lhs b/src/NLP/GenI/GraphvizShowPolarity.lhs deleted file mode 100644 --- a/src/NLP/GenI/GraphvizShowPolarity.lhs +++ /dev/null @@ -1,130 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\begin{code} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.GraphvizShowPolarity -where - -import Data.List (intersperse) -import qualified Data.Map as Map - -import NLP.GenI.Btypes(showSem) -import NLP.GenI.General(showInterval, isEmptyIntersect) -import NLP.GenI.Polarity(PolAut, PolState(PolSt), NFA(states, transitions), finalSt) -import NLP.GenI.Graphviz(GraphvizShow(..), gvUnlines, gvNewline, gvNode, gvEdge) -import NLP.GenI.Tags(idname) -\end{code} - -\begin{code} -instance GraphvizShow () PolAut where - -- we want a directed graph (arrows) - graphvizShowGraph f aut = - "digraph aut {\n" - ++ "rankdir=LR\n" - ++ "ranksep = 0.02\n" - ++ "pack=1\n" - ++ "edge [ fontsize=10 ]\n" - ++ "node [ fontsize=10 ]\n" - ++ graphvizShowAsSubgraph f "aut" aut - ++ "}" - - -- - graphvizShowAsSubgraph _ prefix aut = - let st = (concat.states) aut - ids = map (\x -> prefix ++ show x) ([0..] :: [Int]) - -- map which permits us to assign an id to a state - stmap = Map.fromList $ zip st ids - in -- - gvShowFinal aut stmap - -- any other state should be an ellipse - ++ "node [ shape = ellipse, peripheries = 1 ]\n" - -- draw the states and transitions - ++ (concat $ zipWith gvShowState ids st) - ++ (concat $ zipWith (gvShowTrans aut stmap) ids st ) -\end{code} - -\begin{code} -gvShowState :: String -> PolState -> String -gvShowState stId st = - -- note that we pass the label param explicitly to allow for null label - gvNode stId "" [ ("label", showSt st) ] - where showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po - showPr _ = "" -- (_,pr,_) = pr ++ gvNewline - showPo po = concat $ intersperse "," $ map showInterval po - showEx ex = if null ex then "" else showSem ex ++ gvNewline -\end{code} - -Specify that the final states are drawn with a double circle - -\begin{code} -gvShowFinal :: PolAut -> Map.Map PolState String -> String -gvShowFinal aut stmap = - if isEmptyIntersect (concat $ states aut) fin - then "" - else "node [ peripheries = 2 ]; " - ++ concatMap (\x -> " " ++ lookupId x) fin - ++ "\n" - where fin = finalSt aut - lookupId x = Map.findWithDefault "error_final" x stmap -\end{code} - -Each transition is displayed with the name of the tree. If there is more -than one transition to the same state, they are displayed on a single -label. - -\begin{code} -gvShowTrans :: PolAut -> Map.Map PolState String - -> String -> PolState -> String -gvShowTrans aut stmap idFrom st = - let -- outgoing transition labels from st - trans = Map.findWithDefault Map.empty st $ transitions aut - -- returns the graphviz dot command to draw a labeled transition - drawTrans (stTo,x) = case Map.lookup stTo stmap of - Nothing -> drawTrans' ("id_error_" ++ (sem_ stTo)) x - Just idTo -> drawTrans' idTo x - where sem_ (PolSt i _ _) = show i - --showSem (PolSt (_,pred,_) _ _) = pred - drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) [] - drawLabel labels = gvUnlines labs - where - lablen = length labels - maxlabs = 6 - excess = "...and " ++ (show $ lablen - maxlabs) ++ " more" - -- - labstrs = map fn labels - fn Nothing = "EMPTY" - fn (Just x) = idname x - -- - labs = if lablen > maxlabs - then take maxlabs labstrs ++ [ excess ] - else labstrs - in unlines $ map drawTrans $ Map.toList trans -\end{code} - -%gvShowTransPred te = -% let p = tpredictors te -% charge fv = case () of _ | c == -1 -> "-" -% | c == 1 -> "+" -% | c > 0 -> "+" ++ (show c) -% | otherwise -> (show c) -% where c = lookupWithDefaultFM p 0 fv -% showfv (f,v) = charge (f,v) ++ f -% ++ (if (null v) then "" else ":" ++ v) -% in map showfv $ Map.keys p - diff --git a/src/NLP/GenI/Gui.lhs b/src/NLP/GenI/Gui.lhs deleted file mode 100644 --- a/src/NLP/GenI/Gui.lhs +++ /dev/null @@ -1,778 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Graphical User Interface} - -\begin{code} -{-# LANGUAGE FlexibleContexts #-} -module NLP.GenI.Gui(guiGeni) where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX - -import qualified Control.Monad as Monad -import qualified Data.Map as Map - -import Data.IORef -import Data.List (isPrefixOf, nub, delete, findIndex) -import Data.Maybe ( fromMaybe ) -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 - , lemmaSentenceString, GeniResult(..), prettyResult - , loadEverything, loadTestSuite, loadTargetSemStr - , showRealisations ) -import NLP.GenI.General (boundsCheck, geniBug, trim, fst3) -import NLP.GenI.Btypes (TestCase(..), showFlist,) -import NLP.GenI.Tags (idname, tpolarities, TagElem) -import NLP.GenI.GeniShow (geniShow) -import NLP.GenI.Configuration - ( Params(..), Instruction, hasOpt - , hasFlagP, deleteFlagP, setFlagP, getFlagP, getListFlagP - , parseFlagWithParsec - -- - , ExtraPolaritiesFlg(..) - , LexiconFlg(..) - , MacrosFlg(..) - , MorphCmdFlg(..) - , MorphInfoFlg(..) - , OptimisationsFlg(..) - , RankingConstraintsFlg(..) - , RootFeatureFlg(..) - , TestSuiteFlg(..) - , TestInstructionsFlg(..) - , ViewCmdFlg(..) - -- - , Optimisation(..) - , BuilderType(..), mainBuilderTypes ) -import NLP.GenI.GeniParsers hiding ( choice, label, tab ) -import NLP.GenI.GuiHelper - -import NLP.GenI.Polarity -import NLP.GenI.Simple.SimpleGui -import NLP.GenI.Statistics (Statistics, showFinalStats) -\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: - -\begin{center} -\includegraphics[width=0.47\textwidth]{hcar/GenI-main-screenshot.jpg} -\end{center} - -It allows you to type in an input semantics (or to modify the one that was -automatically loaded up), select some optimisations and run the realiser. You -can also opt to run the debugger instead of the realiser (section -\ref{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 - -- Target Semantics - testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ] - tsTextBox <- textCtrl f [ wrap := WrapWord - , clientSize := sz 400 80 - , enabled := hasSem - , text := "" ] - 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 - 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" - ] - earlyNaChk <- optCheckBox EarlyNa pstRef f - [ text := "NA detection" - , tooltip := "Early detection of nodes that cannot be adjoined to" - ] - 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" - ] - 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 earlyNaChk - , 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 - ] - --- 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. -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)}) - --- -------------------------------------------------------------------- --- Loading files --- -------------------------------------------------------------------- - --- | 'readConfig' is used to update the graphical interface after --- you run the 'configGui'. --- It is also called when you first launch the GUI -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 (loadTestSuite pstRef >> return ()) - `catch` \e -> errorDialog f ("Error reading test suite " ++ suitePath) (show e) - pst <- readIORef pstRef - let suite = tsuite pst - theCase = tcase pst - suiteCases = case filter (\c -> tcName c `elem` cs) suite of - [] -> suite - res -> res - where cs = fromMaybe [] mcs - 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 - caseSel <- if null theCase - then return 0 - else case findIndex (== theCase) suiteCaseNames of - Nothing -> do errorDialog f "" ("No such test case: " ++ theCase) - return 0 - Just i -> return i - ---------------------------------------------------- - -- 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 tcaseLabels ++ "\n" - ---------------------------------------------------- - set caseChoice [ items := tcaseLabels - , selection := caseSel - , on select := onTestCaseChoice ] - when (not $ null suite) onTestCaseChoice -- run this once -\end{code} - -% -------------------------------------------------------------------- -\section{Configuration} -% -------------------------------------------------------------------- - -The configuration GUI aims to a provide a graphical substitute for the command -line switches. Note you cannot yet select optimisations and test cases from -this window; use the main window instead. Note also that changes to GenI tend -to start from the command line switches and only percolate to the GUI when time -permits. For full control of GenI, see \verb!geni --help!. - -\begin{center} -\emph{TODO: screenshot wanted} -\end{center} - -\begin{code} --- | 'configGui' @pstRef loadFn@ provides the configuration GUI. The continuation --- @loadFn@ tells us what to do when the user closes this window. -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 - -- ----------------------------------------------------------------- - -- basic options tab - -- ----------------------------------------------------------------- - 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 - -- ----------------------------------------------------------------- - -- advanced options tab - -- ----------------------------------------------------------------- - 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 ] ] - -- put the whole darn thing together - let layAdvanced = hfloatLeft $ container padv $ column 10 - $ [ layXMG, layPolarities, layMorph] - -- ----------------------------------------------------------------- - -- browse button action - -- - -- 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. - -- ----------------------------------------------------------------- - -- 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 - -- ----------------------------------------------------------------- - -- config GUI layout - -- ----------------------------------------------------------------- - 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 - -- - let maybeSet fl fn x = - if null x then deleteFlagP fl else setFlagP fl (fn x) - maybeSetStr fl x = maybeSet fl id x - let setConfig = id - . (maybeSetStr MacrosFlg macrosVal) - . (maybeSetStr LexiconFlg lexconVal) - . (maybeSetStr TestSuiteFlg tsVal) - . (maybeSetStr TestInstructionsFlg [(tsVal,Nothing)]) - . (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{Generation} -% -------------------------------------------------------------------- - -\begin{code} --- | 'doGenerate' parses the target semantics, then calls the generator and --- displays the result in a results gui (below). -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 - -- - 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} - -When surface realisation is complete, we display a results window with various -tabs for intermediary results in lexical selection, derived trees, derivation -trees and generation statistics. - -\begin{center} -\emph{TODO: screenshot wanted} -\end{center} - -\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 - -- summary tab - let sentences = concatMap grRealisations results - summTab <- statsGui nb sentences stats - -- ranking tab - pst <- readIORef pstRef - let useRanking = hasFlagP RankingConstraintsFlg (pa pst) - rankTab <- messageGui nb . unlines . map (prettyResult pst) $ results - -- tabs - let myTabs = [ tab "summary" summTab - , tab "realisations" resTab - ] ++ - (if useRanking then [ tab "ranking" rankTab ] else []) - -- pack it all together - set f [ layout := container p $ column 0 [ tabs nb myTabs ] - , clientSize := sz 700 600 ] - return () - --- | 'statsGui' displays the generation statistics and provides a --- handy button for saving results to a text file. -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} - -% -------------------------------------------------------------------- -\section{Debugging} -\label{sec:gui:debugger} -% -------------------------------------------------------------------- - -Instead of going directly to the results window, you could instead use the -interactive debugger which GenI provides. The debugger shows a separate tab -for each phase in surface realisation (lexical selection, filtering, building). - -\begin{center} -\includegraphics[width=0.47\textwidth]{hcar/GenI-debugger-screenshot.jpg} -\end{center} - -\begin{code} --- | We provide here a universal debugging interface, which makes use of some --- parameterisable bits as defined in the BuilderGui module. -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 (cand,_) = unzip $ B.inCands 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 - (canPnl,_,_) <- if pauseOnLex - then pauseOnLexGui pst nb cand step2 - else candidateGui pst nb cand - -- 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} - -\subsection{Stepping through the debugger} - -The interactive debugger can have a diffrent GUI for each realisation algorithm. -Here we will discuss the interface for the Simple 2-Phase algorithm which \geni -uses by default. The interfaces for other algorithms are likely to very similar. - -\begin{center} -\includegraphics[width=0.47\textwidth]{images/debugger-features.png} -\end{center} - -The debugger allows you to step through chart generation. Using the 'Step by' -button, you can walk through an arbitrary number of steps, where each step -consists in pulling one item of the agenda, combining it with the chart and -putting some of the results back on to the agenda (or the trash, or results -pile as the case may be). New chart items produced on each step typically have -one of their nodes highlighted in red. This indicates that the node was the -site of the most recent ``event''. For example in the substitution phase, the -red node indicates where the substitution operation was performed; whereas in -the adjunction phase, it could either indicate where adjunction was performed -or where a null-adjunction constraint was applied. - -If you select the ``show features'' checkbox, all nodes in the chart item will -be expanded to reveal the underlying feature structures. The components of this -expanded representation are segmented into the following boxes: - -\vspace{1em} -\begin{tabular}{ll} -\begin{minipage}{0.10\textwidth} -\includegraphics[width=\textwidth]{images/debugger-features-focus.png} -\end{minipage} & -\begin{minipage}{0.70\textwidth} -\begin{enumerate} -\item Summary: here, \verb!n:j.m! indicates that the category is \verb!n!, - that the top \verb!idx! feature is associated with \verb'j' and the - bottom one with \verb!m!. -\item Decorations: here, $\downarrow$ indicates that this is a TAG substitution - node, following the usual conventions in the literature. -\item The top feature structure -\item The bottom feature structure -\end{enumerate} -\end{minipage} \\ -\end{tabular} - -% -------------------------------------------------------------------- -\section{Tree browser} -\label{sec:treebrowser_gui} -% -------------------------------------------------------------------- - -The GenI tree browser displays all the TAG trees in the grammar grouped -according to the semantics with which they are associated. - -\begin{code} --- 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. -treeBrowserGui :: ProgStateRef -> IO () -treeBrowserGui pstRef = do - pst <- readIORef pstRef - -- ALL THE TREES in the grammar... muahahaha! - let semmap = combine (gr pst) (le pst) - -- browser window - f <- frame [ text := "Tree Browser" - , fullRepaintOnResize := False - ] - -- the heavy GUI artillery - let sem = Map.keys semmap - -- - lookupTr k = Map.findWithDefault [] k semmap - treesfor k = Nothing : (map Just $ lookupTr k) - labsfor k = ("___" ++ k ++ "___") : (map fn $ lookupTr k) - where fn t = idname t ++ polfn (tpolarities t) - polfn p = if Map.null p - then "" - else " (" ++ showLitePm p ++ ")" - -- - trees = concatMap treesfor sem - itNlabl = zip trees (concatMap labsfor sem) - (browser,_,_) <- tagViewerGui pst f "tree browser" "grambrowser" itNlabl - -- the button panel - let count = length trees - length sem - quitBt <- button f [ text := "Close", on command := close f ] - -- pack it all together - set f [ layout := column 5 [ browser, - row 5 [ label ("number of trees: " ++ show count) - , hfloatRight $ widget quitBt ] ] - , clientSize := sz 700 600 ] - return () -\end{code} diff --git a/src/NLP/GenI/GuiHelper.hs b/src/NLP/GenI/GuiHelper.hs deleted file mode 100644 --- a/src/NLP/GenI/GuiHelper.hs +++ /dev/null @@ -1,750 +0,0 @@ --- GenI surface realiser --- Copyright (C) 2005 Carlos Areces and Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -{-# LANGUAGE FlexibleContexts #-} -module NLP.GenI.GuiHelper where - -import Graphics.UI.WX --- import Graphics.UI.WXCore - -import Control.Arrow ( (&&&), (***) ) -import qualified Control.Monad as Monad -import Control.Monad.State.Strict ( execStateT, runState ) -import qualified Data.Map as Map - -import Data.IORef -import System.Directory -import System.FilePath ((<.>),(),dropExtensions) -import System.Process (runProcess) -import Text.ParserCombinators.Parsec (parseFromFile) - -import NLP.GenI.Graphviz -import NLP.GenI.Automaton (numStates, numTransitions) - -import NLP.GenI.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(..) ) -import NLP.GenI.GeniParsers ( geniTagElems ) -import NLP.GenI.General - (geniBug, boundsCheck, dropTillIncluding, ePutStrLn) -import NLP.GenI.Btypes - ( showAv, showPred, showLexeme, ) -import NLP.GenI.PolarityTypes ( PolarityKey(..) ) -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 () - --- ---------------------------------------------------------------------- --- Types --- ---------------------------------------------------------------------- - -data GraphvizStatus = GvError String - | GvNoSuchItem Int - | GvCached - | GvCreated FilePath - deriving Show - --- ---------------------------------------------------------------------- --- Lexically selected items --- ---------------------------------------------------------------------- - --- | 'candidateGui' displays the lexically selected items, grouped by the --- semantics they subsume. -candidateGui :: ProgState - -> Window a - -> [TagElem] - -> GvIO () Bool (Maybe TagElem) -candidateGui pst f xs = do - p <- panel f [] - (tb,gvRef,updater) <- tagViewerGui pst p "lexically selected item" "candidates" - $ sectionsBySem xs - let polFeats = "Polarity attributes detected: " ++ (unwords.detectPolFeatures) xs - warning = unlines $ filter (not.null) (polFeats : warnings pst) - -- 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 - --- ---------------------------------------------------------------------- --- Polarity Automata --- ---------------------------------------------------------------------- - --- | A browser to see the automata constructed during the polarity optimisation --- step. -polarityGui :: (Window a) -> [(PolarityKey,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 (PolarityKey fv,a1,a2) = [ fv ++ stats a1, fv ++ " pruned" ++ stats a2] - finalAutLab = ( final, "final" ++ stats final ) - autslabs = concatBoth (map (aut2 &&& autLabel) xs) ++ [ finalAutLab ] - gvRef <- newGvRef () () "automata" - setGvDrawables gvRef autslabs - graphvizGui f "polarity" gvRef - -concatBoth :: [ ([a],[b]) ] -> [ (a,b) ] -concatBoth = uncurry zip . (concat *** concat) . unzip -- is there a simpler way? - --- ---------------------------------------------------------------------- --- Helpers --- ---------------------------------------------------------------------- - --- | 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] - --- | '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. -toSentence :: TagElem -> String -toSentence = unwords . map squishLeaf . tagLeaves - -squishLeaf :: (a,([String], b)) -> String -squishLeaf = showLexeme.fst.snd - --- ---------------------------------------------------------------------- --- TAG viewer --- ---------------------------------------------------------------------- - --- | Variant of 'graphvizGui' with a toggle to view feature structures -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 [] - gvRef <- newGvRef () False tip - setGvDrawables gvRef itNlab - (lay,ref,onUpdate) <- 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 - onUpdate - 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,onUpdate) - --- ---------------------------------------------------------------------- --- XMG Metagrammar stuff. --- See --- ---------------------------------------------------------------------- - --- | Calls Yannick Parmentier's handy visualisation tool ViewTAG. -viewTagWidgets :: (GraphvizShow Bool t, TagItem t, XMGDerivation t) - => Window a -> GraphvizGuiRef st (Maybe t) Bool -> Params - -> IO Layout -viewTagWidgets p gvRef config = - do viewTagBtn <- button p [ text := "ViewTAG" ] - viewTagCom <- choice p [ tooltip := "derivation tree" ] - -- handlers - let onViewTag = readIORef gvRef >>= - gvOnSelect (return ()) - (\t -> do let derv = getSourceTrees t - ds <- get viewTagCom selection - if boundsCheck ds derv - then runViewTag config (derv !! ds) - else geniBug $ "Gui: bounds check in onViewTag" - ) - set viewTagBtn [ on command := onViewTag ] - -- when the user selects a tree, we want to update the list of derivations - let updateDerivationList = gvOnSelect - (set viewTagCom [ enabled := False ]) - (\s -> set viewTagCom [ enabled := True - , items := getSourceTrees s - , selection := 0] ) - addGvHandler gvRef updateDerivationList - updateDerivationList =<< readIORef gvRef - -- - return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ] - -runViewTag :: Params -> String -> IO () -runViewTag params drName = - case getFlagP MacrosFlg params of - Nothing -> ePutStrLn "Warning: No macros files specified (runViewTag)" - Just f -> do - -- figure out what grammar file to use - let gramfile = dropExtensions f <.> "rec" - treenameOnly = takeWhile (/= ':') . dropTillIncluding ':' . dropTillIncluding ':' - -- run the viewer - case getFlagP ViewCmdFlg params of - Nothing -> ePutStrLn "Warning: No viewcmd specified (runViewTag)" - Just c -> do -- run the viewer - runProcess c [gramfile, treenameOnly drName] - Nothing Nothing Nothing Nothing Nothing - return () - --- -------------------------------------------------------------------- --- Graphical debugger (helper functions) --- -------------------------------------------------------------------- - --- | 'pauseOnLexGui' allows the user to see lexical selection only and either --- dump it to file or read replace it by the contents of some other file -pauseOnLexGui :: ProgState -> (Window a) -> [TagElem] - -> ([TagElem] -> IO ()) -- ^ continuation - -> GvIO () Bool (Maybe TagElem) -pauseOnLexGui pst f xs job = do - p <- panel f [] - candV <- varCreate xs - (tb, ref, updater) <- candidateGui pst p xs - -- 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 - setGvDrawables ref (sectionsBySem c) - updater - -- - saveBt <- button p [ text := "Save to file", on command := saveCmd ] - loadBt <- button p [ text := "Load from file", on command := loadCmd ] - nextBt <- button p [ text := "Begin" ] - let disableW w = set w [ enabled := False ] - set nextBt [ on command := do mapM disableW [ saveBt, loadBt, nextBt ] - varGet candV >>= job ] - -- - let lay = fill $ container p $ column 5 - [ fill tb, hfill (vrule 1) - , row 0 [ row 5 [ widget saveBt, widget loadBt ] - , hfloatRight $ widget nextBt ] ] - return (lay, ref, updater) - -type DebuggerItemBar st flg itm - = Panel () -- ^ parent panel - -> GraphvizGuiRef st (Maybe itm) flg -- ^ gv ref to use - -> GvUpdater -- ^ onUpdate - -> IO (Layout, GvUpdater) - --- | A generic graphical debugger widget for GenI, including --- --- * item viewer which allows the user to select one of the items in the --- builder state. --- --- * 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. --- --- * A dashboard which lets the user do things like ``go ahead 6 steps''. --- --- 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 st 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 - p <- panel f [] - -- --------------------------------------------------------- - -- item viewer: select and display an item - -- --------------------------------------------------------- - gvRef <- newGvRef initS gvInitial "debugger session" - setGvDrawables gvRef (stateToGv initS) - (layItemViewer,_,onUpdateMain) <- graphvizGui p cachedir gvRef - -- ---------------------------------------------------------- - -- item bar: controls for how an individual item is displayed - -- ---------------------------------------------------------- - (layItemBar,onUpdateItemBar) <- itemBar p gvRef onUpdateMain - -- ------------------------------------------- - -- dashboard: controls for the debugger itself - -- ------------------------------------------- - let onUpdate = onUpdateMain >> onUpdateItemBar - db <- panel p [] - restartBt <- button db [text := "Start over"] - nextBt <- button db [text := "Step by..."] - leapVal <- entry db [ text := "1", clientSize := sz 30 25 ] - finishBt <- button db [text := "Leap to end"] - statsTxt <- staticText db [] - -- dashboard commands - let showQuery c gs = case queryCounter c gs of - Nothing -> "???" - Just q -> show q - updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ] - txtStats gs = unwords [ "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] - modifyIORef gvRef $ \g -> g { gvcore = s2 } - setGvDrawables gvRef (stateToGv s2) - setGvSel gvRef 1 - onUpdate - updateStatsTxt stats2 - set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ] - let showLast = - do -- redo generation from scratch - let (s2, stats2) = runState (execStateT allSteps initS) initStats - setGvDrawables gvRef (stateToGv s2) - onUpdate - updateStatsTxt stats2 - let showReset = - do set nextBt [ on command := showNext (initS, initStats) ] - updateStatsTxt initStats - setGvDrawables gvRef (stateToGv initS) - setGvSel gvRef 1 - onUpdate - -- 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 ] - --- -------------------------------------------------------------------- --- Graphviz GUI --- -------------------------------------------------------------------- - - -data GraphvizOrder = GvoParams | GvoItems | GvoSel - deriving Eq - -data GraphvizGuiSt st a b = - GvSt { gvcore :: st, - 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 st a b -> IO ()), - gvsel :: Int, - gvorders :: [GraphvizOrder] } - --- | This provides a mechanism for communicating with the GUI. The basic idea: --- --- 1. you create a GvRef with newGvRef --- --- 2. you call 'graphvizGui' and get back an updater function --- --- 3. whenever you want to modify something, you use setGvWhatever and call --- the updater function --- --- 4. if you want to react to the selection being changed, you should set --- gvhandler -type GraphvizGuiRef st a b = IORef (GraphvizGuiSt st a b) - -newGvRef :: st -> b -> String -> IO (GraphvizGuiRef st a b) -newGvRef initSt p t = - let st = GvSt { gvcore = initSt, - gvparams = p, - gvitems = Map.empty, - gvlabels = [], - gvhandler = Nothing, - gvtip = t, - gvsel = 0, - gvorders = [] } - in newIORef st - -setGvSel :: GraphvizGuiRef st a b -> Int -> IO () -setGvSel gvref s = - do let fn x = x { gvsel = s, - gvorders = GvoSel : (gvorders x) } - modifyIORef gvref fn - -setGvParams :: GraphvizGuiRef st a b -> b -> IO () -setGvParams gvref c = - do let fn x = x { gvparams = c, - gvorders = GvoParams : (gvorders x) } - modifyIORef gvref fn - -modifyGvParams :: GraphvizGuiRef st a b -> (b -> b) -> IO () -modifyGvParams gvref fn = - do gvSt <- readIORef gvref - setGvParams gvref (fn $ gvparams gvSt) - -setGvDrawables :: GraphvizGuiRef st a b -> [(a,String)] -> IO () -setGvDrawables gvref itlb = - do let (it,lb) = unzip itlb - fn x = x { gvitems = Map.fromList $ zip [0..] it - , gvlabels = lb - , gvorders = GvoItems : (gvorders x) - } - modifyIORef gvref fn - --- | 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 st (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 :: GraphvizGuiRef st a b -> Maybe (GraphvizGuiSt st 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 :: GraphvizGuiRef st a b -> (GraphvizGuiSt st 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 - -type GvIO st f d = IO (Layout, GraphvizGuiRef st d f, GvUpdater) -type GvUpdater = IO () - --- |'graphvizGui' @f glab cachedir gvRef@ is 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. --- --- This returns a layout (wxhaskell container) and a function that you're --- expected to call whever something changes that would require the GUI to --- refresh itself (for example, you create a new chart 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. --- * @glab@ - (gui labels) a tuple of strings (tooltip, next button text) --- * @cachedir@ - the cache subdirectory. We intialise this by creating a cache --- directory for images which will be generated from the results --- * @gvRef@ - see above -graphvizGui :: (GraphvizShow f d) => (Window a) -> String -> GraphvizGuiRef st d f -> GvIO st f d -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 ] - ------------------------------------------------ - -- create an updater function - ------------------------------------------------ - let withoutSelector job = - bracket ( swap rchoice (on select) (return ()) ) - ( \fn -> set rchoice [ on select := fn ] ) - ( const job ) - -- the selector calls onUpdate which calls the selector - -- indirectly by setting the selection - let onUpdate = withoutSelector $ do - gvSt <- readIORef gvRef - let orders = gvorders gvSt - initCacheDir cachedir - Monad.when (GvoItems `elem` orders) $ - set rchoice [ items := gvlabels gvSt ] - Monad.when (GvoSel `elem` orders) $ - set rchoice [ selection := gvsel gvSt ] - modifyIORef gvRef (\x -> x { gvorders = []}) - createAndOpenImage cachedir p gvRef openFn - ------------------------------------------------ - -- 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 - onUpdate - ------------------------------------------------ - set rchoice [ on select := selectAndShow ] - -- call the updater function for the first time - setGvSel gvRef 1 - onUpdate - -- 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, onUpdate) - --- ---------------------------------------------------------------------- --- Bitmap stuff --- ---------------------------------------------------------------------- - --- | Bitmap with a scrollbar -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) - -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 [] - --- | '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. -createAndOpenImage :: (GraphvizShow f b) => - FilePath -> Window a -> GraphvizGuiRef st b f -> OpenImageFn -> IO () -createAndOpenImage cachedir f gvref openFn = do - let errormsg g = "The file " ++ g ++ " was not created!\n" - ++ "Is graphviz installed?" - gvStatus <- createImage cachedir f gvref - case gvStatus of - GvCreated graphic -> - do exists <- doesFileExist graphic - if exists - then openFn graphic - else errorDialog f "" (errormsg graphic) - GvError err -> errorDialog f "" err - GvNoSuchItem _ -> return () - GvCached -> return () - --- | Creates a graphical visualisation for anything which can be displayed --- by graphviz. -createImage :: (GraphvizShow f b) - => FilePath -- ^ cache directory - -> Window a -- ^ parent window - -> GraphvizGuiRef st b f -- ^ stuff to display - -> IO GraphvizStatus -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 . GvCreated $ graphicFile - handler err = do errorDialog f "Error calling graphviz" (show err) - return . GvError . show $ err - exists <- doesFileExist graphicFile - -- we only call graphviz if the image is not in the cache - if exists - then return (GvCreated graphicFile) - else case Map.lookup sel drawables of - Nothing -> return . GvNoSuchItem $ sel - Just it -> create it `catch` handler - --- | Directory to dump image files in so that we can avoid regenerating them. --- If the directory already exists, we can just delete all the files in it. -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 - --- ---------------------------------------------------------------------- --- Miscellaneous --- ---------------------------------------------------------------------- - --- | 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 ]) - -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" diff --git a/src/NLP/GenI/LexicalSelection.hs b/src/NLP/GenI/LexicalSelection.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/LexicalSelection.hs @@ -0,0 +1,425 @@ +-- GenI surface realiser +-- Copyright (C) 2005 Carlos Areces and Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +-- | This module performs the core of lexical selection and anchoring. +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.LexicalSelection +where + +import Control.Applicative ( (<$>) ) +import Control.Arrow ((***)) +import Control.Monad.Maybe +import Control.Monad.Writer +import Data.Function ( on ) +import Data.List +import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing) +import Data.Tree (Tree(Node)) +import qualified Data.Text as T +import Data.Text ( Text ) + +import Data.FullList hiding ( head, tail, (++) ) +import qualified Data.FullList as FL + +import NLP.GenI.FeatureStructure (Flist, AvPair(..), unifyFeat) +import NLP.GenI.General + ( filterTree, repAllNode, histogram, geniBug, repNodeByNode, + ) +import NLP.GenI.GeniVal( unify, GeniVal(gConstraints), isConst, Subst, replace, finaliseVars ) +import NLP.GenI.LexicalSelection.Types +import NLP.GenI.Lexicon ( LexEntry(..), Lexicon, ) +import NLP.GenI.Semantics ( subsumeSem, unifySem, Sem ) +import NLP.GenI.Tag ( TagElem(..), idname ) +import NLP.GenI.TreeSchema ( Ttree(..), SchemaTree, SchemaNode, Macros + , crushTreeGNode + , setAnchor, setLexeme, tree + , GNode(..), GType(..) + ) +import NLP.GenI.Warning + +-- ---------------------------------------------------------------------- +-- * Lexical selection algorithms +-- ---------------------------------------------------------------------- + +-- | See 'NLP.GenI.Configuration' if you want to use GenI with a custom +-- lexical selection function. +type LexicalSelector = Macros -> Lexicon -> Sem -> IO LexicalSelection + +-- | The result of the lexical selection process +data LexicalSelection = LexicalSelection + { -- | the main result: a set of elementary trees (ie. anchored trees) + lsAnchored :: [TagElem] + -- | if available, lexical entries that were used to produce anchored + -- trees (useful for identifying anchoring failure) + , lsLexEntries :: [LexEntry] + -- | HINT: use 'Data.Monoid.mempty' to initialise to empty + , lsWarnings :: GeniWarnings + } + +-- | Performs standard GenI lexical selection as described in +-- +-- +-- This is just 'defaultLexicalSelection' lifted into IO +defaultLexicalSelector :: Macros -> Lexicon -> Sem -> IO LexicalSelection +defaultLexicalSelector g l t = return (defaultLexicalSelection g l t) + +-- | Helper for 'defaultLexicalSelector' +-- (Standard GenI lexical selection is actually pure) +-- +-- This is just 'defaultLexicalChoice' and 'defaultAnchoring' +defaultLexicalSelection :: Macros -> Lexicon -> Sem -> LexicalSelection +defaultLexicalSelection grammar lexicon tsem = + defaultAnchoring grammar (defaultLexicalChoice lexicon tsem) tsem + +-- | @missingLexEntries ts lexs@ returns any of the lexical candidates +-- @lexs@ that were apparently not anchored succesfully. +-- +-- TODO: it does this by (wrongly) checking for each lexical item +-- to see if any of the anchored trees in @ts@ have identical +-- semantics to that lexical item. The better way to do this would +-- be to throw a subsumption check on top of items reported missing, +-- because it's possible for the trees to add semantics through +-- unification. +missingLexEntries :: [TagElem] -> [LexEntry] -> [LexEntry] +missingLexEntries cands = filter treeless + where + treeless l = isNothing $ find (\t -> tsemantics t == isemantics l) cands + +-- ---------------------------------------------------------------------- +-- * Selecting candidate lemmas +-- ---------------------------------------------------------------------- + +-- | Select and returns the set of entries from the lexicon whose semantics +-- subsumes the input semantics. +defaultLexicalChoice :: Lexicon -> Sem -> [LexEntry] +defaultLexicalChoice slex tsem = chooseCandI tsem slex + +-- | 'chooseCandI' @sem l@ attempts to unify the semantics of @l@ with @sem@ +-- If this succeeds, we use return the result(s); if it fails, we reject +-- @l@ as a lexical selection candidate. +chooseCandI :: Sem -> [LexEntry] -> [LexEntry] +chooseCandI tsem cand = + let replaceLex i (sem,sub) = + (replace sub i) { isemantics = sem } + -- + helper :: LexEntry -> [LexEntry] + helper l = if null sem then [l] + else map (replaceLex l) psubsem + where psubsem = sem `subsumeSem` tsem + sem = isemantics l + -- + in nub $ concatMap helper cand + +-- | `mergeSynonyms' is a factorisation technique that uses +-- atomic disjunction to merge all synonyms into a single lexical +-- entry. Two lexical entries are considered synonyms if their +-- semantics match and they point to the same tree families. +-- +-- FIXME: 2006-10-11 - note that this is no longer being used, +-- because it breaks the case where two lexical entries differ +-- only by their use of path equations. Perhaps it's worthwhile +-- just to add a check that the path equations match exactly. +mergeSynonyms :: [LexEntry] -> [LexEntry] +mergeSynonyms lexEntry = + let mergeFn l1 l2 = l1 { iword = (FL.++) (iword l1) (iword l2) } + keyFn l = (ifamname l, isemantics l) + synMap = foldr helper Map.empty lexEntry + where helper x acc = Map.insertWith mergeFn (keyFn x) x acc + in Map.elems synMap + +-- -------------------------------------------------------------------- +-- * Anchoring +-- -------------------------------------------------------------------- + +-- | The 'LexCombine' monad supports warnings during lexical selection +-- and also failure via Maybe +type LexCombine a = MaybeT (Writer [LexCombineError]) a + +-- | Note an anchoring error +lexTell :: LexCombineError -> LexCombine () +lexTell x = lift (tell [x]) + +-- | @defaultAnchoring schemata lex sem@ implements the later half of lexical +-- selection (tree anchoring and enrichement). It assumes that @lex@ consists +-- just of the lexical items that have been selected, and tries to combine them +-- with the tree schemata. +-- +-- This function may be useful if you are implementing your own lexical selection +-- functions, and you want GenI to take over after you've given it a @[LexEntry]@ +defaultAnchoring :: Macros -> [LexEntry] -> Sem -> LexicalSelection +defaultAnchoring grammar lexCands tsem = + LexicalSelection { lsAnchored = cands + , lsLexEntries = lexCands + , lsWarnings = mconcat [ lexWarnings, coanchorWarnings, errs ] + } + where + combinations = map (combineList tsem grammar) lexCands + cands = concatMap snd combinations + errs = mkGeniWarnings . concat $ zipWith mkWarnings lexCands (map fst combinations) + mkWarnings l = map (LexWarning [l] . LexCombineOneSchemaFailed) + coanchorWarnings = mkGeniWarnings $ do -- list monad + l <- lexCands + let xs = filter (\p -> pfamily p == ifamname l) grammar + (c,n) <- Map.toList . histogram $ concatMap (missingCoanchors l) xs + return (LexWarning [l] (MissingCoanchors c n)) + lexWarnings = mkGeniWarnings $ case missingLexEntries cands lexCands of + [] -> [] + xs -> [LexWarning xs LexCombineAllSchemataFailed] + + +-- ---------------------------------------------------------------------- +-- ** Combination +-- ---------------------------------------------------------------------- + +-- | Given a lexical item, looks up the tree families for that item, and +-- anchor the item to the trees. +combineList :: Sem -> Macros -> LexEntry + -> ([LexCombineError],[TagElem]) -- ^ any warnings, plus the results +combineList tsem gram lexitem = + case [ t | t <- gram, pfamily t == tn ] of + [] -> ([FamilyNotFoundError tn],[]) + macs -> squish . swap . unzip $ map (\m -> runWriter . runMaybeT $ combineOne tsem lexitem m) macs + where + tn = ifamname lexitem + swap (x,y) = (y,x) + squish = (compressLexCombineErrors . concat) *** (concat . catMaybes) + +-- | Combine a single tree with its lexical item to form a bonafide TagElem. +-- This process can fail, however, because of filtering or enrichement +combineOne :: Sem -> LexEntry -> SchemaTree -> LexCombine [TagElem] +combineOne tsem lexRaw eRaw = -- Maybe monad + -- trace ("\n" ++ (show wt)) $ + do let l1 = finaliseVars "-l" lexRaw + e1 = finaliseVars "-t" eRaw + (l,e) <- unifyParamsWithWarning (l1,e1) + >>= unifyInterfaceUsing iinterface + >>= unifyInterfaceUsing ifilters -- filtering + >>= enrichWithWarning -- enrichment + tree2 <- case crushTreeGNode (tree e) of + Nothing -> do lexTell (SchemaError [pidname e] + (StringError "Could not flatten disjunction")) + fail "" + Just x -> return x + let name = T.intercalate ":" $ filter (not . T.null) + [ FL.head (iword l) , pfamily e , pidname e ] + template = TE + { idname = name + , ttreename = pfamily e + , tidnum = -1 -- provisional id + , ttype = ptype e + , ttree = setOrigin name . setLemAnchors . setAnchor (iword l) $ tree2 + , tsemantics = [] + , tsempols = isempols l + , tpolarities = Map.empty + , tinterface = pinterface e + , ttrace = ptrace e + } + semUnifications <- case unifySem (isemantics l) (fromMaybe [] $ psemantics e) of + [] -> do lexTell (SchemaError [pidname e] (StringError "could not unify lemma and schema semantics")) + fail "" + xs -> return xs + return $ concatMap (finaliseSemantics template) semUnifications + where + croak t msg = do + lexTell (SchemaError [pidname t] (StringError msg)) + fail "" + finaliseSemantics template (sem,sub) = + do (sem2,sub2) <- sem `subsumeSem` replace sub tsem + return $ replace sub2 $ template { tsemantics = sem2 } + unifyParamsWithWarning (l,t) = + -- trace ("unify params " ++ wt) $ + let lp = iparams l + tp = params t + in if length lp /= length tp + then croak t "Parameter length mismatch" + else case unify lp tp of + Nothing -> croak t "Parameter unification error" + Just (ps2, subst) -> return (replace subst l, t2) + where t2 = (replace subst t) { params = ps2 } + unifyInterfaceUsing ifn (l,e) = + -- trace ("unify interface" ++ wt) $ + case unifyFeat (ifn l) (pinterface e) of + Nothing -> croak e "Interface unification error" + Just (int2, fsubst) -> return (replace fsubst l, e2) + where e2 = (replace fsubst e) { pinterface = int2 } + -- + enrichWithWarning (l,e) = + -- trace ("enrich" ++ wt) $ + do e2 <- enrich l e + return (l,e2) + +-- ---------------------------------------------------------------------- +-- ** Enrichment +-- ---------------------------------------------------------------------- + +-- | See +-- on enrichement +enrich :: LexEntry -> SchemaTree -> LexCombine SchemaTree +enrich l t = + do -- separate into interface/anchor/named + (intE, namedE) <- lift $ lexEquations l + -- enrich the interface and everything else + t2 <- foldM enrichInterface t intE + -- enrich everything else + foldM enrichBy t2 namedE + where + enrichInterface tx en = + case unifyFeat [en] (pinterface tx) of + Nothing -> lexTell (ifaceEnrichErr en) >> fail "" + Just (i2, isubs) -> return $ (replace isubs tx) { pinterface = i2 } + ifaceEnrichErr (AvPair loc _) = + SchemaError [pidname t] (EnrichError (PeqInterface loc)) + +-- *** 'enrich' helpers + +-- | Helper for 'enrich' (enrich by single path equation) +enrichBy :: SchemaTree + -> PathEqPair + -> LexCombine SchemaTree +enrichBy t eq@(eqLhs, _) = + case maybeEnrichBy t eq of + Nothing -> lexTell enrichErr >> return t + Just (t2,_) -> return t2 + where + enrichErr = SchemaError [pidname t] (EnrichError (PeqJust eqLhs)) + +-- | Helper for 'enrichBy' +maybeEnrichBy :: SchemaTree + -> PathEqPair + -> Maybe (SchemaTree, Subst) +maybeEnrichBy t (eqLhs, eqVal) = do + node <- seekCoanchor eqLhs t + case eqLhs of + PeqFeat _ eqTop eqAtt -> do + let (get, set) = case eqTop of + Top -> (gup, \n x -> n { gup = x }) + Bottom -> (gdown, \n x -> n { gdown = x}) + (fs, sub) <- enrichFeat (AvPair eqAtt eqVal) (get node) + let t2 = fixNode (set node fs) (replace sub t) + return (t2, sub) + PeqLex _ -> do + vs <- gConstraints eqVal + let node2 = node { glexeme = FL.fromFL vs } + t2 = fixNode node2 t + return (t2, Map.empty) + where + fixNode n mt = mt { tree = repNodeByNode (matchNodeName eqLhs) n (tree mt) } + +-- | @enrichFeat av fs@ attempts to unify @av@ with @fs@ +-- +-- Note here that @fs@ is an @Flist [GeniVal]@ rather than the usual +-- @Flist GeniVal@ you may expect. This is because it comes from +-- 'SchemaTree' which allows non-atomic disjunctions of @GeniVal@ +-- which have to be flatten down to at most atomic disjunctions once +-- lexical selection is complete. +enrichFeat :: AvPair GeniVal -> Flist [GeniVal] -> Maybe (Flist [GeniVal], Subst) +enrichFeat (AvPair a v) fs = + case span (\x -> avAtt x < a) fs of + (before,here:after) | avMatch here -> + do let (AvPair _ fv) = here + (v2,sub) <- unify fv (replicate (length fv) v) + let av2 = AvPair a v2 + fs2 = replace sub before ++ (av2 : replace sub after) + return (fs2, sub) + (before,after) -> + let av2 = AvPair a [v] + fs2 = before ++ (av2 : after) in Just (fs2, Map.empty) + where + avMatch (AvPair fa _) = fa == a + +-- | @missingCoanchors l t@ returns the list of coanchor node names from @l@ +-- that were not found in @t@ +missingCoanchors :: LexEntry -> SchemaTree -> [Text] +missingCoanchors lexEntry t = + [ name eqLhs | eqLhs <- nubBy ((==) `on` name) equations, missing eqLhs ] + where + equations = map fst . snd . fst . runWriter $ lexEquations lexEntry + name (PeqFeat n _ _) = n + name (PeqLex n) = n + missing eqLhs = isNothing (seekCoanchor eqLhs t) + +-- | Split a lex entry's path equations into interface enrichement equations +-- or (co-)anchor modifiers +lexEquations :: LexEntry -> Writer [LexCombineError] ([AvPair GeniVal],[PathEqPair]) +lexEquations = + fmap myPartition . mapM parseAv . iequations + where + myPartition xs = ( [ AvPair a v | (PeqInterface a, v) <- xs ] + , [ (n,v) | (PeqJust n, v) <- xs ] ) + parseAv (AvPair a v) = fmap (\a2 -> (a2,v)) (parsePathEq a) + +-- | @seekCoanchor lhs t@ returns @Just node@ if @t@ contains exactly one +-- node that can be identified by @lhs@, @Nothing@ if it contains none. +-- +-- It crashes if there is more than one such node, because this should +-- have been caught earlier by GenI. +seekCoanchor :: NodePathEqLhs -> SchemaTree -> Maybe SchemaNode +seekCoanchor eqLhs t = + case filterTree (matchNodeName eqLhs) (tree t) of + [a] -> Just a + [] -> Nothing + _ -> geniBug . T.unpack . T.intercalate "\n" $ + [ "NLP.GenI.LexicalSelection.seekCoanchor:" + , "Did not expect to see a tree with multiple matches in enrichBy." + , "Tree: " `T.append` pidname t + , "Family: " `T.append` pfamily t + , "Matching on: " `T.append` showPathEqLhs (PeqJust eqLhs) + ] + +-- | @matchNodeName lhs n@ is @True@ if the @lhs@ refers to the node @n@ +matchNodeName :: NodePathEqLhs -> SchemaNode -> Bool +matchNodeName (PeqFeat n _ _) = matchNodeNameHelper n +matchNodeName (PeqLex n) = matchNodeNameHelper n + +-- | @matchNodeNameHelper@ recognises “anchor“ by convention; otherwise, +-- it does a name match +matchNodeNameHelper :: Text -> SchemaNode -> Bool +matchNodeNameHelper "anchor" = ganchor +matchNodeNameHelper n = (== n) . gnname + +-- ---------------------------------------------------------------------- +-- ** Lemanchor mechanism +-- ---------------------------------------------------------------------- + +-- | The lemanchor mechanism is described in +-- +setLemAnchors :: Tree (GNode GeniVal) -> Tree (GNode GeniVal) +setLemAnchors t = + repAllNode fn filt t + where + filt (Node a []) = gtype a == Subs && (isJust. lemAnchor) a + filt _ = False + fn (Node x k) = setLexeme (lemAnchorMaybeFake x) $ + Node (x { gtype = Other, gaconstr = False }) k + -- + lemAnchorMaybeFake :: GNode GeniVal -> [Text] + lemAnchorMaybeFake n = + fromMaybe ["ERR_UNSET_LEMMANCHOR"] (lemAnchor n) + lemAnchor :: GNode GeniVal -> Maybe [Text] + lemAnchor n = + case [ v | AvPair a v <- gup n, a == _lemanchor ] of + [l] | isConst l -> fromFL <$> gConstraints l + _ -> Nothing + +-- | The name of the lemanchor attribute (by convention; see source) +_lemanchor :: Text +_lemanchor = "lemanchor" + +-- | @setOrigin n t@ marks the nodes in @t@ as having come from +-- a tree named @n@ +setOrigin :: Text -> Tree (GNode v) -> Tree (GNode v) +setOrigin t = fmap (\g -> g { gorigin = t }) diff --git a/src/NLP/GenI/LexicalSelection/Types.hs b/src/NLP/GenI/LexicalSelection/Types.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/LexicalSelection/Types.hs @@ -0,0 +1,149 @@ +-- GenI surface realiser +-- Copyright (C) 2012 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.LexicalSelection.Types where + +import Control.Monad.Writer +import Data.List +import Data.Poset +import Data.Text ( Text ) +import qualified Data.Map as Map +import qualified Data.Text as T + +import NLP.GenI.GeniVal +import NLP.GenI.Pretty + +-- | Left hand side of a path equation +data PathEqLhs = PeqInterface Text + | PeqJust NodePathEqLhs + | PeqUnknown Text + deriving (Eq, Ord) + +-- ---------------------------------------------------------------------- +-- * Path equations +-- ---------------------------------------------------------------------- + +-- | Path equations can either hit a feature or a node's lexeme attribute +data NodePathEqLhs = PeqFeat Text TopBottom Text + | PeqLex Text + deriving (Eq, Ord) + +data TopBottom = Top | Bottom + deriving (Eq, Ord) + +type PathEqPair = (NodePathEqLhs, GeniVal) + +-- | Parse a path equation using the GenI conventions +-- This always succeeds, but can return @Just warning@ +-- if anything anomalous comes up +-- FIXME : make more efficient +parsePathEq :: Text -> Writer [LexCombineError] PathEqLhs +parsePathEq e = + case T.splitOn "." e of + (n:"top":r) -> return (node n Top r) + (n:"bot":r) -> return (node n Bottom r) + [n,"lex"] -> return (PeqJust (PeqLex n)) + ("top":r) -> return (node "anchor" Top r) + ("bot":r) -> return (node "anchor" Bottom r) + ("anchor":r) -> return (node "anchor" Bottom r) + ("interface":r) -> return (PeqInterface (rejoin r)) + ("anc":r) -> parsePathEq $ rejoin ("anchor":r) + (n:r@(_:_)) -> tell [BoringError (tMsg n)] >> return (node n Top r) + _ -> tell [BoringError iMsg ] >> return (PeqUnknown e) + where + node n tb r = PeqJust $ PeqFeat n tb (rejoin r) + rejoin = T.intercalate "." + tMsg n = T.unwords + [ "Interpreting path equation" + , e + , "as applying to top of" + , n `T.snoc` '.' + ] + iMsg = "Could not interpret path equation" <+> e + +showPathEqLhs :: PathEqLhs -> Text +showPathEqLhs p = + case p of + PeqJust (PeqFeat n tb att) -> squish [ n, fromTb tb, att ] + PeqJust (PeqLex n) -> squish [ n, "lex" ] + PeqInterface att -> squish [ "interface", att ] + PeqUnknown e -> e + where + fromTb Top = "top" + fromTb Bottom = "bot" + squish = T.intercalate "." + +-- ---------------------------------------------------------------------- +-- * Warnings +-- ---------------------------------------------------------------------- + +data LexCombineError = + BoringError Text + | FamilyNotFoundError Text + | SchemaError [Text] LexCombineError2 + deriving Eq + +data LexCombineError2 = EnrichError PathEqLhs + | StringError Text + deriving (Eq, Ord) + +instance Poset LexCombineError where + leq (BoringError _) _ = True + leq (SchemaError _ e1) (SchemaError _ e2) = leq e1 e2 + leq (FamilyNotFoundError x1) (FamilyNotFoundError x2) = leq x1 x2 + leq (FamilyNotFoundError _) (SchemaError _ _) = True + leq _ _ = False + +instance Poset LexCombineError2 where + leq (EnrichError e1) (EnrichError e2) = leq e1 e2 + leq (EnrichError _ ) (StringError _ ) = True + leq (StringError s1) (StringError s2) = leq s1 s2 + leq _ _ = False + +instance Poset PathEqLhs where + leq l1 l2 = leq (showPathEqLhs l1) (showPathEqLhs l2) + +instance Poset Text where + leq l1 l2 = leq (T.unpack l1) (T.unpack l2) + +instance Pretty LexCombineError where + pretty e = + body <+> suffix + where + (body, suffix) = showLexCombineError e + +showLexCombineError :: LexCombineError -> (Text, Text) +showLexCombineError (SchemaError xs x) = (pretty x, prettyCount (const "") "trees" ((), length xs)) +showLexCombineError (BoringError s) = (s, "") +showLexCombineError (FamilyNotFoundError f) = ("Family" <+> f <+> "not found in tree schema file", "") + +instance Pretty LexCombineError2 where + pretty (EnrichError p) = + "Some trees discarded due to enrichment error on" <+> showPathEqLhs p + pretty (StringError s) = s + +compressLexCombineErrors :: [LexCombineError] -> [LexCombineError] +compressLexCombineErrors errs = schema2 ++ normal + where + isSchema (SchemaError _ _) = True + isSchema _ = False + (schema, normal) = partition isSchema errs + schema2 = map (uncurry (flip SchemaError)) + . Map.toList + $ Map.fromListWith (++) [ (l,ts) | SchemaError ts l <- schema ] diff --git a/src/NLP/GenI/Lexicon.hs b/src/NLP/GenI/Lexicon.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Lexicon.hs @@ -0,0 +1,27 @@ +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +module NLP.GenI.Lexicon ( + Lexicon, + -- anything but the constructor + LexEntry, mkLexEntry, mkFullLexEntry, + iword , ifamname, iparams, iinterface , ifilters, iequations, isemantics, isempols, + -- * Converting between lexical/normal semantics + PolValue, fromLexSem, fromLexLiteral, +) where + +import NLP.GenI.Lexicon.Internal diff --git a/src/NLP/GenI/Lexicon/Internal.hs b/src/NLP/GenI/Lexicon/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Lexicon/Internal.hs @@ -0,0 +1,203 @@ +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Lexicon.Internal where + +-- import Debug.Trace -- for test stuff +import Data.Binary +import Data.FullList +import Data.Function +import Data.List ( sortBy ) +import Data.Generics (Data) +import Data.Text ( Text ) +import Data.Typeable (Typeable) +import qualified Data.Text as T + +import NLP.GenI.FeatureStructure +import NLP.GenI.GeniShow +import NLP.GenI.GeniVal +import NLP.GenI.Pretty +import NLP.GenI.Semantics +import NLP.GenI.Polarity.Types (SemPols) + +import Control.DeepSeq + +--instance Show (IO()) where +-- show _ = "" + +type Lexicon = [LexEntry] +data LexEntry = LexEntry + { -- normally just a singleton, useful for merging synonyms + iword :: FullList Text + , ifamname :: Text + , iparams :: [GeniVal] + , iinterface :: Flist GeniVal + , ifilters :: Flist GeniVal + , iequations :: Flist GeniVal + , isemantics :: Sem + , isempols :: [SemPols] } + deriving (Eq, Data, Typeable) + +-- | See also 'mkFullLexEntry' +-- This version comes with some sensible defaults. +mkLexEntry :: FullList Text -- ^ word + -> Text -- ^ family name + -> [GeniVal] -- ^ parameters list (deprecated) + -> Flist GeniVal -- ^ interface (use instead of params) + -> Flist GeniVal -- ^ filters + -> Flist GeniVal -- ^ equations + -> Sem -- ^ semantics + -> LexEntry +mkLexEntry word famname params interface filters equations sem = + mkFullLexEntry word famname params interface filters equations + sem (map noSemPols sem) + where + noSemPols l = replicate (length (lArgs l)) 0 + +-- | Variant of 'mkLexEntry' but with more control +mkFullLexEntry :: FullList Text -- ^ word + -> Text -- ^ family name + -> [GeniVal] -- ^ parameters list (deprecated) + -> Flist GeniVal -- ^ interface (use instead of params) + -> Flist GeniVal -- ^ filters + -> Flist GeniVal -- ^ equations + -> Sem -- ^ semantics + -> [SemPols] -- ^ semantic polarities + -> LexEntry +mkFullLexEntry word famname params interface filters equations sem sempols = + LexEntry + (sortNub word) + famname + params + (sortFlist interface) + (sortFlist filters) + (sortFlist equations) + sem2 + sempols2 + where + (sem2, sempols2) = unzip $ sortBy (compareOnLiteral `on` fst) (zip sem sempols) + +instance DescendGeniVal LexEntry where + descendGeniVal s i = + i { iinterface = descendGeniVal s (iinterface i) + , iequations = descendGeniVal s (iequations i) + , isemantics = descendGeniVal s (isemantics i) + , iparams = descendGeniVal s (iparams i) } + +instance Collectable LexEntry where + collect l = (collect $ iinterface l) . (collect $ iparams l) . + (collect $ ifilters l) . (collect $ iequations l) . + (collect $ isemantics l) + +-- ---------------------------------------------------------------------- +-- lexicon semantics +-- ---------------------------------------------------------------------- + +-- | An annotated GeniVal. This is for a rather old, obscure +-- variant on the polarity filtering optimisation. To account +-- for zero literal semantics, we annotate each value in the +-- semantics with a positive/negative marker. These markers +-- are then counted up to determine with we need to insert +-- more literals into the semantics or not. See the manual +-- on polarity filtering for more details +type PolValue = (GeniVal, Int) + +fromLexSem :: [Literal PolValue] -> (Sem, [SemPols]) +fromLexSem = unzip . map fromLexLiteral + +-- | Note that by convention we ignore the polarity associated +-- with the predicate itself +fromLexLiteral :: Literal PolValue -> (Literal GeniVal, SemPols) +fromLexLiteral (Literal h pr vs) = + (lit, pols) + where + lit = Literal (fst h) (fst pr) (map fst vs) + pols = snd h : map snd vs + +-- ---------------------------------------------------------------------- +-- converting to text +-- ---------------------------------------------------------------------- + +-- TODO: does not support semantic polarities yet +instance GeniShow LexEntry where + geniShowText l = T.intercalate "\n" + [ T.unwords + [ geniShowText . mkGConst $ iword l + , ifamname l + , paramT + ] + , geniKeyword "equations" $ geniShowText (iequations l) + , geniKeyword "filters" $ geniShowText (ifilters l) + , geniKeyword "semantics" $ geniShowText (isemantics l) + ] + where + paramT = parens . T.unwords . concat $ + [ map geniShowText (iparams l) + , ["!"] + , map geniShowText (iinterface l) + ] + +instance GeniShow [LexEntry] where + geniShowText = T.intercalate "\n\n" . map geniShowText + +instance Pretty LexEntry where + pretty = geniShowText + +-- ---------------------------------------------------------------------- +-- +-- ---------------------------------------------------------------------- + +{-! +deriving instance Binary LexEntry +deriving instance NFData LexEntry +!-} + +-- GENERATED START + + +instance Binary LexEntry where + put (LexEntry x1 x2 x3 x4 x5 x6 x7 x8) + = do put x1 + put x2 + put x3 + put x4 + put x5 + put x6 + put x7 + put x8 + get + = do x1 <- get + x2 <- get + x3 <- get + x4 <- get + x5 <- get + x6 <- get + x7 <- get + x8 <- get + return (LexEntry x1 x2 x3 x4 x5 x6 x7 x8) + + +instance NFData LexEntry where + rnf (LexEntry x1 x2 x3 x4 x5 x6 x7 x8) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/Main.hs b/src/NLP/GenI/Main.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Main.hs @@ -0,0 +1,58 @@ +-- 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. + +{-# LANGUAGE CPP #-} +module NLP.GenI.Main where + +import Control.Applicative ((<$>)) +import Data.IORef(newIORef) +import Data.Typeable( Typeable ) +import Data.Version ( showVersion ) +import System.Environment(getArgs, getProgName) + +import Paths_GenI ( version ) + +import NLP.GenI.Console(consoleGeni) +import NLP.GenI.Configuration (treatArgs, optionsForStandardGenI, processInstructions, + usage, optionsSections, Params, + hasFlagP, DisableGuiFlg(..), + HelpFlg(..), VersionFlg(..), + readGlobalConfig, setLoggers + ) +import NLP.GenI.Configuration(setFlagP) +import NLP.GenI ( ProgState(..), emptyProgState ) + +main :: IO () +main = do + args <- getArgs + confArgs <- forceGuiFlag <$> (processInstructions =<< treatArgs optionsForStandardGenI args) + mainWithState (emptyProgState confArgs) + +mainWithState :: ProgState -> IO () +mainWithState pst = do + pname <- getProgName + maybe (return ()) setLoggers =<< readGlobalConfig + pstRef <- newIORef pst + let has :: (Typeable f, Typeable x) => (x -> f) -> Bool + has = flip hasFlagP (pa pst) + case () of + _ | has HelpFlg -> putStrLn (usage optionsSections pname) + | has VersionFlg -> putStrLn (pname ++ " " ++ showVersion version) + | otherwise -> consoleGeni pstRef + +forceGuiFlag :: Params -> Params +forceGuiFlag = setFlagP DisableGuiFlg () diff --git a/src/NLP/GenI/Morphology.hs b/src/NLP/GenI/Morphology.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Morphology.hs @@ -0,0 +1,218 @@ +-- GenI surface realiser +-- Copyright (C) 2005 Carlos Areces and Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-| +This module handles mostly everything to do with morphology in Geni. +There are two basic tasks: morphological input and output. +GenI farms out morphology to whatever third party program you +specify on the command line. Note that a simple and stupid +``sillymorph'' realiser is provided either in the GenI repository +or on hackage. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +module NLP.GenI.Morphology + ( + module NLP.GenI.Morphology.Types + -- * Morphological predicates + , readMorph, stripMorphSem, attachMorph, setMorphAnchor + -- * Morphological realisation + , inflectSentencesUsingCmd, sansMorph + ) where + +import Control.Concurrent (forkIO) +import Control.Exception (catch, bracket, evaluate, IOException) +import Data.Maybe (isNothing) +import Data.Text ( Text ) +import Data.Tree +import Data.Typeable +import System.Exit +import System.IO +import System.Process +import Prelude hiding (catch) +import qualified Data.Map as Map +import qualified Data.Text as T + +import System.Log.Logger +import Text.JSON +import Text.JSON.Pretty + +import NLP.GenI.FeatureStructure +import NLP.GenI.GeniVal ( mkGAnon, GeniVal, replace ) +import NLP.GenI.General +import NLP.GenI.Morphology.Types +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( Literal(..), Sem ) +import NLP.GenI.Tag +import NLP.GenI.TreeSchema ( GNode(..), GType(..) ) + +-- ---------------------------------------------------------------------- +-- Morphological input +-- ---------------------------------------------------------------------- + +-- | Converts information from a morphological information file into GenI's +-- internal format. +readMorph :: [(Text,[AvPair GeniVal])] -> MorphInputFn +readMorph minfo lit = + Map.lookup key fm + where + fm = Map.fromList minfo + key = pretty (lPredicate lit) + +-- | Filters away from an input semantics any literals whose realisation is +-- strictly morphological. The first argument tells us helps identify the +-- morphological literals -- it associates literals with morphological stuff; +-- if it returns 'Nothing', then it is non-morphological +stripMorphSem :: MorphInputFn -> Sem -> Sem +stripMorphSem morphfn tsem = + [ l | l <- tsem, (isNothing.morphfn) l ] + +-- | 'attachMorph' @morphfn sem cands@ does the bulk of the morphological +-- input processing. We use @morphfn@ to determine which literals in +-- @sem@ contain morphological information and what information they contain. +-- Then we attach this morphological information to the relevant trees in +-- @cand@. A tree is considered relevant w.r.t to a morphological +-- literal if its semantics contains at least one literal whose first index +-- is the same as the first index of the morphological literal. +attachMorph :: MorphInputFn -> Sem -> [TagElem] -> [TagElem] +attachMorph morphfn sem cands = + let -- relevance of a tree wrt to an index + relTree i = not.null.relfilt.tsemantics + where relfilt = filter (relLit i) + relLit i l = case lArgs l of + [] -> False + (x:_) -> x == i + -- perform the attachment for a tree if it is relevant + attachHelper :: GeniVal -> Flist GeniVal -> TagElem -> TagElem + attachHelper i mfs t = + if relTree i t then attachMorphHelper mfs t else t + -- perform all attachments for a literal + attach :: Literal GeniVal -> [TagElem] -> [TagElem] + attach l cs = + case morphfn l of + Nothing -> cs + Just mfs -> map (attachHelper i mfs) cs + where i = case lArgs l of + [] -> mkGAnon + (x:_) -> x + in foldr attach cands sem + +-- | Actually unify the morphological features into the anchor node +-- +-- FIXME: we'll need to make sure this still works as promised +-- when we implement co-anchors. +attachMorphHelper :: Flist GeniVal -> TagElem -> TagElem +attachMorphHelper mfs te = + let -- unification with anchor + tt = ttree te + anchor = head $ filterTree fn tt + where fn a = (ganchor a && gtype a == Lex) + in case unifyFeat mfs (gup anchor) of + Nothing -> error ("Morphological unification failure on " ++ T.unpack (idname te)) + Just (unf,subst) -> + let -- perform replacements + te2 = replace subst te + tt2 = ttree te2 + -- replace the anchor with the unification results + newgdown = replace subst (gdown anchor) + newa = anchor { gup = unf, gdown = newgdown } + in te2 { ttree = setMorphAnchor newa tt2 } + +setMorphAnchor :: GNode GeniVal -> Tree (GNode GeniVal) -> Tree (GNode GeniVal) +setMorphAnchor n t = + let filt (Node a _) = (gtype a == Lex && ganchor a) + fn (Node _ l) = Node n l + in (head.fst) $ listRepNode fn filt [t] + +-- ---------------------------------------------------------------------- +-- Morphological realisation +-- ---------------------------------------------------------------------- + +-- | Extracts the lemmas from a list of uninflected sentences. This is used +-- when the morphological generator is unavailable, doesn't work, etc. +sansMorph :: LemmaPlusSentence -> MorphOutput +sansMorph = + MorphOutput [] . singleton . T.unwords . map lem + where + lem (LemmaPlus l _) = l + +-- | Converts a list of uninflected sentences into inflected ones by calling +--- the third party software. +-- FIXME: this doesn't actually support lists-of-results per input +-- will need to work it out +-- HUH? What makes me say that? +inflectSentencesUsingCmd :: String -> [LemmaPlusSentence] -> IO [(LemmaPlusSentence,MorphOutput)] +inflectSentencesUsingCmd morphcmd sentences = + doit `catch` \e -> let _ = e :: IOException in (fallback (show e)) + where + hCloseSloppy h = hClose h `catch` \err -> let _ = err :: IOException in warningM logname (show err) + doit = bracket + (do debugM logname $ "Starting morph generator: " ++ morphcmd + runInteractiveCommand morphcmd) + (\(inh,outh,errh,_) -> do + debugM logname $ "Closing output handles from morph generator" + mapM hCloseSloppy [inh, outh, errh]) + $ \(toP,fromP,errP,pid) -> do + debugM logname $ "Sending " ++ show (length sentences) ++ " sentences to morph generator" + hPutStrLn toP . render . pp_value . showJSON $ sentences + + debugM logname $ "Closing input handle to morph generator" + hClose toP + -- see http://www.haskell.org/pipermail/haskell-cafe/2008-May/042994.html + -- fork off a thread to pull on the stderr + -- so if the process writes to stderr we do not block. + -- NB. do the hGetContents synchronously, otherwise the outer + -- bracket can exit before this thread has run, and hGetContents + -- will fail. + err <- hGetContents errP + _ <- forkIO (evaluate (length err) >> warningM logname err) + + -- wait for all the output + output <- hGetContents fromP + _ <- evaluate (length output) + + -- wait for the program to terminate + exitcode <- waitForProcess pid + debugM logname $ "Morph command exited" + -- on failure, throw the exit code as an exception + if exitcode == ExitSuccess + then case resultToEither (decode output) of + Left jerr -> fallback $ "Could not parse morphological generator output: " ++ jerr + Right res -> do let lenResults = length res + lenSentences = length sentences + if lenResults == lenSentences + then return $ zip sentences res + else fallback $ "Morphological generator returned " + ++ show lenResults ++ " results for " + ++ show lenSentences ++ " inputs" + `catch` \e -> let _ = e :: IOException + in fallback ("Error calling morphological generator:\n" ++ show e) + else fallback "Morph generator failed" + fallback err = do + errorM logname err + return $ map (\x -> (x, sansMorph x)) sentences + +-- ---------------------------------------------------------------------- +-- odds and ends +-- ---------------------------------------------------------------------- + +singleton :: a -> [a] +singleton x = [x] + +data MNAME = MNAME deriving Typeable +logname :: String +logname = mkLogname MNAME diff --git a/src/NLP/GenI/Morphology.lhs b/src/NLP/GenI/Morphology.lhs deleted file mode 100644 --- a/src/NLP/GenI/Morphology.lhs +++ /dev/null @@ -1,233 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Morphology} -\label{cha:Morphology} - -This module handles mostly everything to do with morphology in Geni. -There are two basic tasks: morphological input and output. -GenI farms out morphology to whatever third party program you -specify on the command line. Note that a simple and stupid -``sillymorph'' realiser is provided either in the GenI repository -or on hackage. - -\begin{code} -module NLP.GenI.Morphology - ( - MorphFn - -- re-export - , LemmaPlus(..), LemmaPlusSentence - -- * Morphological predicates - , readMorph, stripMorphSem, attachMorph, setMorphAnchor - -- * Morphological realisation - , inflectSentencesUsingCmd, sansMorph - ) where -\end{code} - -\ignore{ -\begin{code} -import Data.Maybe (isNothing) -import Data.Tree -import qualified Data.Map as Map -import System.IO -import System.Process -import Text.JSON -import Text.JSON.Pretty - -import NLP.GenI.Btypes -import NLP.GenI.General -import NLP.GenI.Tags -import NLP.GenI.Builder -\end{code} -} - -\begin{code} -type MorphFn = Pred -> Maybe Flist -\end{code} - -\section{Morphological input} - -Morphological input means attaching morphological features on trees. The -user specifies morphological input through the input semantics. Our job -is to identify morphological predicates like \semexpr{plural(x)} and -apply features like \fs{\it num:pl} on the relevant trees. - -\begin{code} --- | Converts information from a morphological information file into GenI's --- internal format. -readMorph :: [(String,[AvPair])] -> MorphFn -readMorph minfo pred_ = Map.lookup key fm - where fm = Map.fromList minfo - key = show $ snd3 pred_ - --- | Filters away from an input semantics any literals whose realisation is --- strictly morphological. The first argument tells us helps identify the --- morphological literals -- it associates literals with morphological stuff; --- if it returns 'Nothing', then it is non-morphological -stripMorphSem :: MorphFn -> Sem -> Sem -stripMorphSem morphfn tsem = - [ l | l <- tsem, (isNothing.morphfn) l ] - --- | 'attachMorph' @morphfn sem cands@ does the bulk of the morphological --- input processing. We use @morphfn@ to determine which literals in --- @sem@ contain morphological information and what information they contain. --- Then we attach this morphological information to the relevant trees in --- @cand@. A tree is considered relevant w.r.t to a morphological --- literal if its semantics contains at least one literal whose first index --- is the same as the first index of the morphological literal. -attachMorph :: MorphFn -> Sem -> [TagElem] -> [TagElem] -attachMorph morphfn sem cands = - let -- relevance of a tree wrt to an index - relTree i = not.null.relfilt.tsemantics - where relfilt = filter (relLit i) - relLit i l = if null args then False else (head args == i) - where args = thd3 l - -- perform the attachment for a tree if it is relevant - attachHelper :: GeniVal -> Flist -> TagElem -> TagElem - attachHelper i mfs t = - if relTree i t then attachMorphHelper mfs t else t - -- perform all attachments for a literal - attach :: Pred -> [TagElem] -> [TagElem] - attach l cs = - case morphfn l of - Nothing -> cs - Just mfs -> map (attachHelper i mfs) cs - where i = if null args then GAnon else head args - args = thd3 l - in foldr attach cands sem - --- | Actually unify the morphological features into the anchor node --- --- FIXME: we'll need to make sure this still works as promised --- when we implement co-anchors. -attachMorphHelper :: Flist -> TagElem -> TagElem -attachMorphHelper mfs te = - let -- unification with anchor - tt = ttree te - anchor = head $ filterTree fn tt - where fn a = (ganchor a && gtype a == Lex) - in case unifyFeat mfs (gup anchor) of - Nothing -> error ("Morphological unification failure on " ++ idname te) - Just (unf,subst) -> - let -- perform replacements - te2 = replace subst te - tt2 = ttree te2 - -- replace the anchor with the unification results - newgdown = replace subst (gdown anchor) - newa = anchor { gup = unf, gdown = newgdown } - in te2 { ttree = setMorphAnchor newa tt2 } - -setMorphAnchor :: GNode -> Tree GNode -> Tree GNode -setMorphAnchor n t = - let filt (Node a _) = (gtype a == Lex && ganchor a) - fn (Node _ l) = Node n l - in (head.fst) $ listRepNode fn filt [t] -\end{code} - -\section{Morphological realisation} - -\jargon{Morphological realisation} refers to the actual process -of converting lemmas and morphological information into inflected forms. -We do this by calling some third party software specified by the user. - -The morphological software must accept a JSON list of \jargon{lemma sentences} -where each lemma sentence is itself a list of objects containing a lemma and -a feature structure. - -\begin{verbatim} -[ - [{"lemma": "le", "lemma-features": "[num:sg gen:f]"}, - {"lemma": "fille", "lemma-features": "[num:sg]"}, - {"lemma": "detester", "lemma-features": "[num:sg tense:past]"}, - {"lemma": "le", "lemma-features": "[num:pl gen:m]"}, - {"lemma": "garcon", "lemma-features": "[num:pl]"} - ], - - [{"lemma": "ce", "lemma-features": "[]"}, - {"lemma": "etre", "lemma-features": "[]"}, - {"lemma": "le", "lemma-features": "[]"}, - {"lemma": "garcon", "lemma-features": "[]"}, - {"lemma": "que", "lemma-features": "[]"}, - {"lemma": "le", "lemma-features": "[num:sg gen:f]"}, - {"lemma": "fille", "lemma-features": "[num:sg]"}, - {"lemma": "detester", "lemma-features": "[num:sg tense:past]"} - ] -] -\end{verbatim} - -NB: I recommend using a JSON library instead of parsing and writing this by -hand. - -The morphological realiser may return more than one output per sentence. -Indeed, we expect a JSON-formatted list (a) of lists (b), where each (b) -provides a number of candidate morphological realisations for a sentence in -(a). The list (a) must have the same length as the input because each item in -(a) is expected to correspond to a sentence from the input. - -Notice that the morphological generator can choose to delete spaces or do other -orthographical tricks in between words: - -\begin{verbatim} -[ - ["la fille detestait les garcons"], - - ["c'est le garcon que la fille detestait" - ,"c'est les garcons que la fille detestait"] -] -\end{verbatim} - -If your morphological software does not do this, you could wrap it with a -simple script. - -\begin{code} --- | Extracts the lemmas from a list of uninflected sentences. This is used --- when the morphological generator is unavailable, doesn't work, etc. -sansMorph :: LemmaPlusSentence -> [String] -sansMorph = singleton . unwords . map lem - where - lem (LemmaPlus l _) = l - --- | Converts a list of uninflected sentences into inflected ones by calling ---- the third party software. --- FIXME: this doesn't actually support lists-of-results per input --- will need to work it out -inflectSentencesUsingCmd :: String -> [LemmaPlusSentence] -> IO [(LemmaPlusSentence,[String])] -inflectSentencesUsingCmd morphcmd sentences = - do -- run the inflector - (toP, fromP, _, _) <- runInteractiveCommand morphcmd - hPutStrLn toP . render . pp_value . showJSON $ sentences - hClose toP - -- read the inflector output back as a list of strings - mResults <- (resultToEither . decode) `fmap` hGetContents fromP - case mResults of - Left err -> fallback $ "Could not parse morphological generator output: " ++ err - Right res -> do let lenResults = length res - lenSentences = length sentences - if lenResults == lenSentences - then return $ zip sentences res - else fallback $ "Morphological generator returned " - ++ show lenResults ++ " results for " - ++ show lenSentences ++ " inputs" - `catch` \e -> fallback $ "Error calling morphological generator:\n" ++ show e - where - fallback err = - do ePutStrLn err - return $ map (\x -> (x, sansMorph x)) sentences - -singleton :: a -> [a] -singleton x = [x] -\end{code} diff --git a/src/NLP/GenI/Morphology/Types.hs b/src/NLP/GenI/Morphology/Types.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Morphology/Types.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- 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. + +module NLP.GenI.Morphology.Types where + +import Control.Applicative ((<$>),(<*>)) +import Control.DeepSeq +import Data.Text ( Text ) + +import NLP.GenI.GeniVal ( GeniVal ) +import NLP.GenI.FeatureStructure ( Flist ) +import NLP.GenI.Parser ( geniFeats, Parser, runParser ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics +import Text.JSON + +-- ---------------------------------------------------------------------- +-- morph input +-- ---------------------------------------------------------------------- + +type MorphInputFn = Literal GeniVal -> Maybe (Flist GeniVal) + +-- ---------------------------------------------------------------------- +-- morph output +-- ---------------------------------------------------------------------- + +type MorphRealiser = [LemmaPlusSentence] -> [MorphOutput] + +data MorphOutput = MorphOutput { moWarnings :: [Text] + , moRealisations :: [Text] + } + deriving (Ord, Eq) + +instance JSON MorphOutput where + readJSON j = + case fromJSObject `fmap` readJSON j of + Error _ -> MorphOutput [] <$> readJSON j + Ok jo -> do + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + warnings = maybe (return []) readJSON (lookup "warnings" jo) + MorphOutput <$> warnings + <*> field "realisations" + showJSON _ = error "Don't know how to render MorphOutput" + +-- | A lemma plus its morphological features +data LemmaPlus = LemmaPlus + { lpLemma :: Text + , lpFeats :: Flist GeniVal + } + deriving (Eq, Ord) + +-- | A sentence composed of 'LemmaPlus' instead of plain old words +type LemmaPlusSentence = [LemmaPlus] + +instance JSON LemmaPlus where + readJSON j = + do jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + LemmaPlus <$> field "lemma" + <*> (parsecToJSON "lemma-features" geniFeats =<< field "lemma-features") + showJSON (LemmaPlus l fs) = + JSObject . toJSObject $ [ ("lemma", showJSON l) + , ("lemma-features", showJSON $ prettyStr fs) + ] + +parsecToJSON :: Monad m => String -> Parser b -> String -> m b +parsecToJSON description p str = + case runParser p () "" str of + Left err -> fail $ "Couldn't parse " ++ description ++ " because " ++ show err + Right res -> return res + +{-! +deriving instance NFData MorphOutput +deriving instance NFData LemmaPlus +!-} + +-- GENERATED START + + +instance NFData MorphOutput where + rnf (MorphOutput x1 x2) = rnf x1 `seq` rnf x2 `seq` () + + +instance NFData LemmaPlus where + rnf (LemmaPlus x1 x2) = rnf x1 `seq` rnf x2 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/OptimalityTheory.hs b/src/NLP/GenI/OptimalityTheory.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/OptimalityTheory.hs @@ -0,0 +1,343 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.OptimalityTheory + ( -- * Input + OtConstraint(..), OtRanking, + -- * Output + GetTraces, OtResult, OtViolation, RankedOtConstraint(..), + rankResults, otWarnings, + -- * Display + prettyViolations,prettyRank + ) + where + +import Control.Applicative ( (<$>), (<*>) ) +import Control.Arrow ( first ) +import Data.Function (on) +import Data.Char ( isSpace ) +import Data.List (nub, partition, sort, sortBy, groupBy, (\\), unfoldr ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Text.JSON + +import NLP.GenI.Pretty +import NLP.GenI.TreeSchema ( Macros, ptrace ) +import qualified NLP.GenI.Builder as B + +import Control.DeepSeq + +data OtConstraint = PositiveC Text -- ^ the trace must appear + | NegativeC Text -- ^ the trace must NOT appear + | NegativeConjC [Text] -- ^ these traces must not appear AT THE SAME TIME + deriving (Show, Eq) + +data RankedOtConstraint = RankedOtConstraint Int OtConstraint + deriving (Show, Eq) + +instance Ord RankedOtConstraint where + compare (RankedOtConstraint r1 _) (RankedOtConstraint r2 _) = compare r1 r2 + +-- | Same as 'RankedOtConstraint' with the sorting inverted +newtype RankedOtConstraint2 = RankedOtConstraint2 RankedOtConstraint deriving Eq + +instance Ord RankedOtConstraint2 where + compare (RankedOtConstraint2 x) (RankedOtConstraint2 y) = compare y x + + +type OtRanking = [[OtConstraint]] + +data OtViolation = OtViolation { otLexName :: Text -- ^ empty for global + , otConstraintViolated :: RankedOtConstraint } + deriving (Show, Eq, Ord) + +data LexItem = LexItem + { lLexname :: Text + , lTraces :: [Text] + } + deriving (Ord, Eq, Show) + +type GetTraces = Text -> [Text] +type OtResult x = (Int,x,[OtViolation]) + +instance JSON OtConstraint where + readJSON j = + do jv <- fromJSObject `fmap` readJSON j + case lookup "pos-constraint" jv of + Just v -> PositiveC `fmap` readJSON v + Nothing -> case lookup "neg-constraint" jv of + Just v -> NegativeC `fmap` readJSON v + Nothing -> case lookup "neg-conj-constraint" jv of + Just v -> NegativeConjC `fmap` readJSONs v + Nothing -> fail $ "Could not read OtConstraint" + showJSON (PositiveC c) = + JSObject . toJSObject $ [ ("pos-constraint", showJSON c ) ] + showJSON (NegativeC c) = + JSObject . toJSObject $ [ ("neg-constraint", showJSON c ) ] + showJSON (NegativeConjC cs) = + JSObject . toJSObject $ [ ("neg-conj-constraint", showJSONs cs ) ] + +-- --------------------------------------------------------------------- +-- top level stuff +-- --------------------------------------------------------------------- +otWarnings :: Macros -> OtRanking -> [OtViolation] -> [Text] +otWarnings gram ranking blocks = + addWarning neTraces neTracesW + . addWarning nvConstraints nvConstraintsW + $ [] + where + addWarning xs w = if null xs then id else (w xs :) + neTracesW xs = "these traces never appear in the grammar: " `T.append` T.unwords xs + neTraces = nonExistentTraces gram ranking + nvConstraintsW xs = "these constraints are never violated: " + `T.append` T.unwords (map pretty xs) + nvConstraints = neverViolated blocks ranking + +rankResults :: GetTraces -> (a -> B.TagDerivation) -> OtRanking -> [a] -> [OtResult a] --changed type Derivation +rankResults getTraces getDerivation r = squish . sortResults . map addViolations + where + addViolations x = (x, getViolations x) + getViolations = violations (concatRank r) . lexTraces getTraces . getDerivation + squish = concat . zipWith applyRank [1..] + applyRank i = map (\(x,vs) -> (i,x,vs)) + +-- --------------------------------------------------------------------- +-- detecting violations +-- --------------------------------------------------------------------- + +violations :: [RankedOtConstraint] -> [LexItem] -> [OtViolation] +violations cs ls = posVs ls ++ negVs ls + where + negVs = concatMap (\l -> negViolations cs (lLexname l) (lTraces l)) + posVs = posViolations cs . concatMap lTraces + +-- | A positive constraint is violated when a trace is NOT present +posViolations :: [RankedOtConstraint] -> [Text] -> [OtViolation] +posViolations cs ss = + [ OtViolation "" c | c@(RankedOtConstraint _ (PositiveC s)) <- cs, not (s `elem` ss) ] + +-- | A negative constraint is violated when a trace is present +-- +-- Note that we will not notice if a constraint is violated more +-- than once. If you want to count multiple violations, you'll +-- either need to partition the input strings and map this function +-- on each sublist or rewrite this code. +negViolations :: [RankedOtConstraint] + -> Text -- ^ lex name + -> [Text] -- ^ traces + -> [OtViolation] +negViolations cs l ss = + [ OtViolation l c | c@(RankedOtConstraint _ (NegativeC s)) <- cs, s `elem` ss ] ++ + [ OtViolation l c | c@(RankedOtConstraint _ (NegativeConjC xs)) <- cs, all (`elem` ss) xs ] + +-- | Violations sorted so that the highest ranking constraint +-- (smallest number) goes first +sortedViolations :: (a, [OtViolation]) -> [RankedOtConstraint2] +sortedViolations = map (RankedOtConstraint2 . otConstraintViolated) . sort . snd + +-- | Sort the sentences so that the ones with the *lowest* +-- ranking violations (biggest number) go first. +-- Note that we return in groups for the sake of ties. +sortResults :: [(a, [OtViolation])] -> [[(a, [OtViolation])]] +sortResults = sortAndGroupByDecoration compare sortedViolations + +lexTraces :: GetTraces -> B.TagDerivation -> [LexItem] --changed type Derivation +lexTraces getTraces = map (toLexItem getTraces) . B.lexicalSelection + +toLexItem :: GetTraces -> Text -> LexItem +toLexItem getTraces t = + LexItem { lLexname = t + , lTraces = getTraces t + } + +-- ---------------------------------------------------------------------- +-- Output format +-- ---------------------------------------------------------------------- + +instance JSON RankedOtConstraint where + readJSON j = + do jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + RankedOtConstraint <$> field "rank" + <*> field "violation" + showJSON = JSObject . toJSObject . rankedOtConstraintToPairs + +rankedOtConstraintToPairs :: RankedOtConstraint -> [ (String, JSValue) ] +rankedOtConstraintToPairs (RankedOtConstraint r c) = + [ ("rank", showJSON r), ("violation", showJSON c) ] + +instance JSON OtViolation where + readJSON j = + do jo <- fromJSObject `fmap` readJSON j + case lookup "lex-item" jo of + Nothing -> OtViolation "" <$> readJSON j + Just l -> OtViolation <$> readJSON l + <*> readJSON j + + showJSON ov = JSObject . toJSObject $ pairs + where + pairs = case otLexName ov of + "" -> basicPairs + l -> ("lex-item", showJSON l) : basicPairs + basicPairs = rankedOtConstraintToPairs (otConstraintViolated ov) + +-- --------------------------------------------------------------------- +-- pretty printing +-- --------------------------------------------------------------------- + +-- TODO: Return as a pretty Doc +prettyViolations :: GetTraces -> Bool -> [OtViolation] -> Text +prettyViolations getTraces noisy vs = + T.unlines $ + [ indented 1 75 (showPosVs posVs) | not (null posVs) ] + ++ map showLexVs negBuckets + where + (posVs, negVs) = partition (T.null . otLexName) vs + negBuckets = buckets otLexName negVs + -- + showPosVs = T.unwords . map prettyV + showLexVs (l,lvs) = + (indented 2 75 . T.unwords $ parens l : map prettyV lvs) `T.append` + (if noisy then "\n" `T.append` allTraces l else "") + where + allTraces = indented 4 75 . T.unwords . getTraces + prettyV = pretty . otConstraintViolated + +instance Pretty RankedOtConstraint where + pretty (RankedOtConstraint r c) = pretty c <+> prettyRank r + +instance Pretty OtConstraint where + pretty (PositiveC str) = '+' `T.cons` str + pretty (NegativeC str) = '*' `T.cons` str + pretty (NegativeConjC strs) = + '*' `T.cons` (parens . T.intercalate " & " $ strs) + +prettyRank :: Int -> Text +prettyRank r = parens $ 'r' `T.cons` T.pack (show r) + +-- --------------------------------------------------------------------- +-- detecting impossible constraints or other potential errors +-- --------------------------------------------------------------------- + +neverViolated :: [OtViolation] -> [[OtConstraint]] -> [OtConstraint] +neverViolated vs ranking = concat ranking \\ cs_used + where + cs_used = nub . map (noRank . otConstraintViolated) $ vs + +nonExistentTraces :: Macros -> [[OtConstraint]] -> [Text] +nonExistentTraces ms vs = r_traces \\ m_traces + where + m_traces = nub $ concatMap ptrace ms + r_traces = nub $ concatMap cTraces $ concat vs + +cTraces :: OtConstraint -> [Text] +cTraces (PositiveC c) = [c] +cTraces (NegativeConjC cs) = cs +cTraces (NegativeC c) = [c] + +-- ---------------------------------------------------------------------- +-- helpers +-- ---------------------------------------------------------------------- + +concatRank :: [[OtConstraint]] -> [RankedOtConstraint] +concatRank = concat . zipWith rank [1..] + where + rank x ys = map (RankedOtConstraint x) ys + +noRank :: RankedOtConstraint -> OtConstraint +noRank (RankedOtConstraint _ c) = c + +-- ---------------------------------------------------------------------- +-- odds and ends +-- ---------------------------------------------------------------------- + +buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ] +buckets f = map (first head . unzip) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\x -> (f x, x)) + +-- | Results are grouped so that ties can be noticed +sortAndGroupByDecoration :: Eq b => (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]] +sortAndGroupByDecoration cmp f = map (map snd) + . groupBy ((==) `on` fst) + . sortBy (cmp `on` fst) + . map (\x -> (f x, x)) + +indented :: Int -> Int -> Text -> Text +indented x len = T.intercalate "\n" + . map (\s -> spaces x `T.append` s) + . wordWrap len + +spaces :: Int -> Text +spaces n = T.pack (replicate n ' ') + +-- | Whitespace-sensitive wrapping +-- +-- Properties: +-- +-- * Only splits at whitespace +-- +-- * Lines at most @len@ characters long, whitespace permitting +wordWrap :: Int -- ^ wrap after these many characters + -> Text + -> [Text] +wordWrap len = + unfoldr f + where + f t = if T.null t then Nothing else Just (splitAtBefore len t) + +splitAtBefore :: Int -- ^ wrap after these many characters + -> Text + -> (Text, Text) +splitAtBefore len xs + | T.length xs < len = (xs, "") + | T.any isSpace xs = (begin, end) + | otherwise = (xs, "") + where + begin = + if T.length upToSpace > len + then upToSpace -- ugh! that's one massive line + else T.stripEnd . T.dropWhileEnd isNotSpace . T.take len $ xs + end = T.stripStart $ T.drop (T.length begin) xs + upToSpace = T.stripStart xs + isNotSpace = not . isSpace + +{-! +deriving instance NFData OtViolation +deriving instance NFData RankedOtConstraint +deriving instance NFData OtConstraint +!-} + +-- GENERATED START + + +instance NFData OtViolation where + rnf (OtViolation x1 x2) = rnf x1 `seq` rnf x2 `seq` () + + +instance NFData RankedOtConstraint where + rnf (RankedOtConstraint x1 x2) = rnf x1 `seq` rnf x2 `seq` () + + +instance NFData OtConstraint where + rnf (PositiveC x1) = rnf x1 `seq` () + rnf (NegativeC x1) = rnf x1 `seq` () + rnf (NegativeConjC x1) = rnf x1 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/OptimalityTheory.lhs b/src/NLP/GenI/OptimalityTheory.lhs deleted file mode 100644 --- a/src/NLP/GenI/OptimalityTheory.lhs +++ /dev/null @@ -1,390 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2009 Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Ranking output} -\label{cha:ranking} - -\begin{code} -module NLP.GenI.OptimalityTheory - ( -- * Input - OtConstraint(..), OtRanking, - -- * Output - GetTraces, OtResult, OtViolation, RankedOtConstraint(..), - rankResults, otWarnings, - -- * Display - prettyViolations,prettyRank - ) - where - -import Control.Applicative ( (<$>), (<*>) ) -import Control.Arrow ( first ) -import Data.Function (on) -import Data.Char ( isSpace ) -import Data.List (nub, partition, sort, sortBy, groupBy, intersperse, (\\), unfoldr ) -import Text.JSON - -import NLP.GenI.Btypes ( Macros, ptrace ) -import qualified NLP.GenI.Builder as B -\end{code} - -If your tree schemata are annotated with traces (TODO link to traces and -metagrammars), you can re-use them as a basis for ranking the output produced -by GenI. The basic idea is to supply a list of either positive, negative or -negative conjunction constraints. - -For users familiar with Haskell, the constraints are described with the -following type: -\begin{includecodeinmanual} -\begin{code} -data OtConstraint = PositiveC String -- ^ the trace must appear - | NegativeC String -- ^ the trace must NOT appear - | NegativeConjC [String] -- ^ these traces must not appear AT THE SAME TIME - deriving (Show, Eq) -\end{code} -\end{includecodeinmanual} - -Roughly speaking the more highly ranked the constraint, the greater the impact -of a violation of that constraint will be. See section -\ref{sec:ranking-procedure} for more details on the ranking procedure. - -\begin{code} -data RankedOtConstraint = RankedOtConstraint Int OtConstraint - deriving (Show, Eq) - -instance Ord RankedOtConstraint where - compare (RankedOtConstraint r1 _) (RankedOtConstraint r2 _) = compare r1 r2 - --- | Same as 'RankedOtConstraint' with the sorting inverted -newtype RankedOtConstraint2 = RankedOtConstraint2 RankedOtConstraint deriving Eq - -instance Ord RankedOtConstraint2 where - compare (RankedOtConstraint2 x) (RankedOtConstraint2 y) = compare y x - - -type OtRanking = [[OtConstraint]] - -data OtViolation = OtViolation { otLexName :: String -- ^ empty for global - , otConstraintViolated :: RankedOtConstraint } - deriving (Show, Eq, Ord) - -data LexItem = LexItem - { lLexname :: String - , lTraces :: [String] - } deriving (Ord, Eq, Show) - -type GetTraces = String -> [String] -type OtResult x = (Int,x,[OtViolation]) -\end{code} - -\section{Input format} - -Constraints are expressed in JSON as a list of \jargon{ranking levels}. A -ranking level is a list of constraints that should be assigned the same rank. -In lieu of a formal description, we provide an example below: -\small{NB: Either the JSON format or the JSON parser used by GenI is strict -enough to refuse initial whitespace in this file.} - -\begin{verbatim} -[ - [{"neg-constraint": "dian0Vn1dePassive"}, - {"pos-constraint": "CanonicalSubject"}], - - [{"neg-conj-constraint": ["InvertedNominalSubject", - "CanonicalSententialObjectFinite"]}], - - [{"neg-conj-constraint": ["InvertedNominalSubject", - "UnboundedCleft"]}, - {"neg-constraint": "CleftSubject"}] -] -\end{verbatim} - -This example constraints file has three ranking levels. These levels contain -following constraints: - -\begin{enumerate} -\item A negative constraint saying that \verb!dian0Vn1dePassive! should - not appear, and a positive one saying that \verb!CanonicalSubject! - \emph{should} appear. These constraints appear together only because - the author of the example thinks they should have the same rank, - not because there is neccesarily any inherent relationship between - them. -\item A single negative conjunction constraint saying that - \verb!InvertedNominalSubject! and - \verb!CanonicalSententialObjectFinite! - should not appear together. -\item A negative conjunction constraint saying tat - \verb!InvertedNominalSubject! and \verb!UnboundedCleft! should not - appear together; and also a negative constraints saying that - \verb!CleftSubject! should not appear. As with the first ranking - level, there is no relationship between these two constraints. We - just put them on the same level to give them the same rank -\end{enumerate} - -\begin{code} -instance JSON OtConstraint where - readJSON j = - do jv <- fromJSObject `fmap` readJSON j - case lookup "pos-constraint" jv of - Just v -> PositiveC `fmap` readJSON v - Nothing -> case lookup "neg-constraint" jv of - Just v -> NegativeC `fmap` readJSON v - Nothing -> case lookup "neg-conj-constraint" jv of - Just v -> NegativeConjC `fmap` readJSONs v - Nothing -> fail $ "Could not read OtConstraint" - showJSON (PositiveC c) = - JSObject . toJSObject $ [ ("pos-constraint", showJSON c ) ] - showJSON (NegativeC c) = - JSObject . toJSObject $ [ ("neg-constraint", showJSON c ) ] - showJSON (NegativeConjC cs) = - JSObject . toJSObject $ [ ("neg-conj-constraint", showJSONs cs ) ] -\end{code} - -\begin{code} --- --------------------------------------------------------------------- --- top level stuff --- --------------------------------------------------------------------- -otWarnings :: Macros -> OtRanking -> [OtViolation] -> [String] -otWarnings gram ranking blocks = - addWarning neTraces neTracesW - . addWarning nvConstraints nvConstraintsW - $ [] - where - addWarning xs w = if null xs then id else (w xs :) - neTracesW xs = "these traces never appear in the grammar: " ++ unwords xs - neTraces = nonExistentTraces gram ranking - nvConstraintsW xs = "these constraints are never violated: " ++ unwords (map prettyConstraint xs) - nvConstraints = neverViolated blocks ranking - -rankResults :: GetTraces -> (a -> B.Derivation) -> OtRanking -> [a] -> [OtResult a] -rankResults getTraces getDerivation r = squish . sortResults . map addViolations - where - addViolations x = (x, getViolations x) - getViolations = violations (concatRank r) . lexTraces getTraces . getDerivation - squish = concat . zipWith applyRank [1..] - applyRank i = map (\(x,vs) -> (i,x,vs)) -\end{code} - - -\begin{code} --- --------------------------------------------------------------------- --- detecting violations --- --------------------------------------------------------------------- - -violations :: [RankedOtConstraint] -> [LexItem] -> [OtViolation] -violations cs ls = posVs ls ++ negVs ls - where - negVs = concatMap (\l -> negViolations cs (lLexname l) (lTraces l)) - posVs = posViolations cs . concatMap lTraces - --- | A positive constraint is violated when a trace is NOT present -posViolations :: [RankedOtConstraint] -> [String] -> [OtViolation] -posViolations cs ss = - [ OtViolation "" c | c@(RankedOtConstraint _ (PositiveC s)) <- cs, not (s `elem` ss) ] - --- | A negative constraint is violated when a trace is present --- --- Note that we will not notice if a constraint is violated more --- than once. If you want to count multiple violations, you'll --- either need to partition the input strings and map this function --- on each sublist or rewrite this code. -negViolations :: [RankedOtConstraint] - -> String -- ^ lex name - -> [String] -- ^ traces - -> [OtViolation] -negViolations cs l ss = - [ OtViolation l c | c@(RankedOtConstraint _ (NegativeC s)) <- cs, s `elem` ss ] ++ - [ OtViolation l c | c@(RankedOtConstraint _ (NegativeConjC xs)) <- cs, all (`elem` ss) xs ] -\end{code} - -\section{Ranking procedure} -\label{sec:ranking-procedure} - -Generation results are sorted according to their highest-ranking constraint -violation (moving on to the next-highest ranking violation and so forth in case -of a tie). The best result appears first. - -\begin{code} --- | Violations sorted so that the highest ranking constraint --- (smallest number) goes first -sortedViolations :: (a, [OtViolation]) -> [RankedOtConstraint2] -sortedViolations = map (RankedOtConstraint2 . otConstraintViolated) . sort . snd - --- | Sort the sentences so that the ones with the *lowest* --- ranking violations (biggest number) go first. --- Note that we return in groups for the sake of ties. -sortResults :: [(a, [OtViolation])] -> [[(a, [OtViolation])]] -sortResults = sortAndGroupByDecoration compare sortedViolations - -lexTraces :: GetTraces -> B.Derivation -> [LexItem] -lexTraces getTraces = map (toLexItem getTraces) . B.lexicalSelection - -toLexItem :: GetTraces -> String -> LexItem -toLexItem getTraces t = - LexItem { lLexname = t - , lTraces = getTraces t } -\end{code} - -\section{Output format} - -Constraint violations can be outputted as JSON objects as the following example -shows - -\begin{verbatim} - { "lex-item": "discuter:n0Vn1pn2:Tn0Vn1pn2-5830:22", - , "rank": 6, - , "violation": {"neg-constraint": "passiveVerbMorphology"} - } -\end{verbatim} - -Positive constraint violations are not associated with any lexical items -so the lex-item field is omitted for them. - -\begin{code} --- --------------------------------------------------------------------- --- output --- --------------------------------------------------------------------- -instance JSON RankedOtConstraint where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - let field x = maybe (fail $ "Could not find: " ++ x) readJSON - $ lookup x jo - RankedOtConstraint <$> field "rank" - <*> field "violation" - showJSON = JSObject . toJSObject . rankedOtConstraintToPairs - -rankedOtConstraintToPairs :: RankedOtConstraint -> [ (String, JSValue) ] -rankedOtConstraintToPairs (RankedOtConstraint r c) = - [ ("rank", showJSON r), ("violation", showJSON c) ] - -instance JSON OtViolation where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - case lookup "lex-item" jo of - Nothing -> OtViolation "" <$> readJSON j - Just l -> OtViolation <$> readJSON l - <*> readJSON j - - showJSON ov = JSObject . toJSObject $ pairs - where - pairs = case otLexName ov of - "" -> basicPairs - l -> ("lex-item", showJSON l) : basicPairs - basicPairs = rankedOtConstraintToPairs (otConstraintViolated ov) - --- --------------------------------------------------------------------- --- pretty printing --- --------------------------------------------------------------------- - --- TODO: Return as a pretty Doc -prettyViolations :: GetTraces -> Bool -> [OtViolation] -> String -prettyViolations getTraces noisy vs = - unlines $ (if null posVs then [] else [ indented 1 75 . showPosVs $ posVs ]) - ++ map showLexVs negBuckets - where - (posVs, negVs) = partition (null . otLexName) vs - negBuckets = buckets otLexName negVs - -- - showPosVs = unwords . map (prettyRankedConstraint . otConstraintViolated) - showLexVs (l,lvs) = - let itmName = "(" ++ l ++ ")" - constraints = map otConstraintViolated lvs - allTraces = indented 4 75 . unwords . getTraces $ l - in (indented 2 75 . unwords $ itmName : map prettyRankedConstraint constraints) - ++ (if noisy then "\n" ++ allTraces else "") - -prettyRankedConstraint :: RankedOtConstraint -> String -prettyRankedConstraint (RankedOtConstraint r c) = prettyConstraint c ++ " " ++ prettyRank r - -prettyConstraint :: OtConstraint -> String -prettyConstraint (PositiveC str) = '+' : str -prettyConstraint (NegativeC str) = '*' : str -prettyConstraint (NegativeConjC strs) = "*(" ++ (concat $ intersperse " & " strs) ++ ")" - -prettyRank :: Int -> String -prettyRank r = "(r" ++ show r ++ ")" - --- --------------------------------------------------------------------- --- detecting impossible constraints or other potential errors --- --------------------------------------------------------------------- - -neverViolated :: [OtViolation] -> [[OtConstraint]] -> [OtConstraint] -neverViolated vs ranking = concat ranking \\ cs_used - where - cs_used = nub . map (noRank . otConstraintViolated) $ vs - -nonExistentTraces :: Macros -> [[OtConstraint]] -> [String] -nonExistentTraces ms vs = r_traces \\ m_traces - where - m_traces = nub $ concatMap ptrace ms - r_traces = nub $ concatMap cTraces $ concat vs - -cTraces :: OtConstraint -> [String] -cTraces (PositiveC c) = [c] -cTraces (NegativeConjC cs) = cs -cTraces (NegativeC c) = [c] - --- ---------------------------------------------------------------------- --- helpers --- ---------------------------------------------------------------------- - -concatRank :: [[OtConstraint]] -> [RankedOtConstraint] -concatRank = concat . zipWith rank [1..] - where - rank x ys = map (RankedOtConstraint x) ys - -noRank :: RankedOtConstraint -> OtConstraint -noRank (RankedOtConstraint _ c) = c - --- ---------------------------------------------------------------------- --- odds and ends --- ---------------------------------------------------------------------- - -buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ] -buckets f = map (first head . unzip) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . map (\x -> (f x, x)) - --- | Results are grouped so that ties can be noticed -sortAndGroupByDecoration :: Eq b => (b -> b -> Ordering) -> (a -> b) -> [a] -> [[a]] -sortAndGroupByDecoration cmp f = map (map snd) - . groupBy ((==) `on` fst) - . sortBy (cmp `on` fst) - . map (\x -> (f x, x)) - -indented :: Int -> Int -> String -> String -indented x len = concat . intersperse "\n" . map (\s -> spaces x ++ s) . unfoldr f - where - f "" = Nothing - f str = Just $ splitAtBefore len str - -spaces :: Int -> String -spaces n = replicate n ' ' - -splitAtBefore :: Int -> String -> (String, String) -splitAtBefore len xs - | length xs < len = (xs, "") - | any isSpace xs = (begin, trim $ drop (length begin) xs) - | otherwise = (xs, "") - where - begin - | length upToSpace > len = upToSpace - | otherwise = reverse . trim . dropWhile isNotSpace . reverse . take len $ xs - upToSpace = takeWhile isNotSpace xs - isNotSpace = not . isSpace - trim = drop 1 -\end{code} diff --git a/src/NLP/GenI/Parser.hs b/src/NLP/GenI/Parser.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Parser.hs @@ -0,0 +1,633 @@ +-- 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. + +{-# LANGUAGE CPP, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module NLP.GenI.Parser ( + -- * Test suites + geniTestSuite, geniSemanticInput, geniTestSuiteString, + geniDerivations, + toSemInputString, + -- * Trees + geniMacros, geniTagElems, + -- * Lexicon and morph + geniLexicon, geniMorphInfo, + -- * Basics + geniFeats, geniSemantics, geniValue, geniWords, + -- * Helpers + geniWord, geniLanguageDef, tillEof, + -- + parseFromFile, -- UTF-8 version + module Text.Parsec, + module Text.Parsec.String, +) where + + +import Control.Applicative ( (<*>), (<$>), (*>), (<*) ) +import Control.Monad (liftM, when) +import Data.Text ( Text ) +import Text.Parsec +import Text.Parsec.String hiding ( parseFromFile ) -- TODO: replace with Text.Parsec.Text +import Text.Parsec.Language (emptyDef) +import Text.Parsec.Token (TokenParser, + LanguageDef, + commentLine, commentStart, commentEnd, opLetter, + reservedOpNames, reservedNames, identLetter, identStart, + makeTokenParser) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Tree as T +import qualified System.IO.UTF8 as UTF8 +--import qualified Text.Parsec.Expr as P +import qualified Text.Parsec.Token as P + +import NLP.GenI.FeatureStructure ( Flist, AvPair(..), sortFlist ) +import NLP.GenI.General (isGeniIdentLetter) +import NLP.GenI.GeniShow ( GeniShow(..), geniKeyword ) +import NLP.GenI.GeniVal ( GeniVal, mkGConst, mkGConstNone, mkGVar, mkGAnon, isAnon ) +import NLP.GenI.Lexicon ( fromLexSem, mkFullLexEntry, LexEntry(..) ) +import NLP.GenI.Pretty ( above ) +import NLP.GenI.Semantics ( Literal(..), Sem, sortSem, LitConstr, SemInput ) +import NLP.GenI.Tag (TagElem(..), setTidnums) +import NLP.GenI.TestSuite ( TestCase(..) ) +import NLP.GenI.TreeSchema (SchemaTree, Ttree(..), Ptype(..), GNode(..), GType(..) ) + +-- import BoolExp +import Data.FullList ( FullList, Listable(..) ) + + +-- General notes + +-- reserved words +#define SEMANTICS "semantics" +#define SENTENCE "sentence" +#define OUTPUT "output" +#define TRACE "trace" +#define ANCHOR "anchor" +#define SUBST "subst" +#define FOOT "foot" +#define LEX "lex" +#define TYPE "type" +#define ACONSTR "aconstr" +#define INITIAL "initial" +#define AUXILIARY "auxiliary" +#define IDXCONSTRAINTS "idxconstraints" +#define BEGIN "begin" +#define END "end" + +-- Lexer + +geniLanguageDef :: LanguageDef () +geniLanguageDef = emptyDef + { commentLine = "%" + , commentStart = "/*" + , commentEnd = "*/" + , opLetter = oneOf "" + , reservedOpNames = [""] + , reservedNames = + [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE + , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR + , INITIAL , AUXILIARY + , BEGIN , END ] + , identLetter = identStuff + , identStart = identStuff + } + where identStuff = satisfy isGeniIdentLetter + +geniValue :: Parser GeniVal +geniValue = ((try $ anonymous) "_ or ?_") + <|> (constants "a constant or atomic disjunction") + <|> (variable "a variable") + where + question = "?" + disjunction = geniAtomicDisjunction + constants :: Parser GeniVal + constants = mkGConst <$> disjunction + variable :: Parser GeniVal + variable = + do symbol question + v <- identifier + mcs <- option Nothing $ (symbol "/" >> Just `liftM` disjunction) + return (mkGVar v mcs) + anonymous :: Parser GeniVal + anonymous = + do optional $ symbol question + symbol "_" + return mkGAnon + +geniAtomicDisjunction :: Parser (FullList Text) +geniAtomicDisjunction = do + (x:xs) <- atom `sepBy1` (symbol "|") + return (x !: xs) + where + atom = looseIdentifier <|> stringLiteral + +geniFancyDisjunction :: Parser [GeniVal] +geniFancyDisjunction = geniValue `sepBy1` symbol ";" + +class GeniValLike v where + geniValueLike :: Parser v + +instance GeniValLike GeniVal where + geniValueLike = geniValue + +instance GeniValLike [GeniVal] where + geniValueLike = geniFancyDisjunction + +-- We make no attempt to check for / guarantee uniqueness here +-- because the same sort of format is used for things which are +-- not strictly speaking feature structures +geniFeats :: GeniValLike v => Parser (Flist v) +geniFeats = option [] $ squares $ many geniAttVal + +geniAttVal :: GeniValLike v => Parser (AvPair v) +geniAttVal = do + att <- identifierR "an attribute"; colon + val <- geniValueLike "a GenI value" + return $ AvPair att val + +geniSemantics :: Parser Sem +geniSemantics = + do sem <- many (geniLiteral "a literal") + return (sortSem sem) + +geniLiteral :: Parser (Literal GeniVal) +geniLiteral = geniLiteral_ mkGAnon geniValue + +geniLiteral_ :: a -> Parser a -> Parser (Literal a) +geniLiteral_ zero gv = + Literal <$> (option zero handleParser "a handle") + <*> (gv "a predicate") + <*> (parens (many gv) "some parameters") + where + handleParser = try $ gv <* char ':' + +geniSemanticInput :: Parser (Sem,Flist GeniVal,[LitConstr]) +geniSemanticInput = + do keywordSemantics + (sem,litC) <- liftM unzip $ squares $ many literalAndConstraint + idxC <- option [] geniIdxConstraints + -- + let sem2 = createHandles sem + semlitC2 = [ (s,c) | (s,c) <- zip sem2 litC, (not.null) c ] + return (createHandles sem, idxC, semlitC2) + where + -- set all anonymous handles to some unique value + -- this is to simplify checking if a result is + -- semantically complete + createHandles :: Sem -> Sem + createHandles = zipWith setHandle ([1..] :: [Int]) + -- + setHandle i (Literal h pred_ par) = + let h2 = if isAnon h + then mkGConstNone ("genihandle" `T.append` T.pack (show i)) + else h + in Literal h2 pred_ par + -- + literalAndConstraint :: Parser LitConstr + literalAndConstraint = + do l <- geniLiteral + t <- option [] $ squares $ many identifier + return (l,t) + +-- | The original string representation of the semantics (for gui) +geniSemanticInputString :: Parser Text +geniSemanticInputString = do + keywordSemantics + s <- squaresString + whiteSpace + optional geniIdxConstraints + return s + +geniIdxConstraints :: Parser (Flist GeniVal) +geniIdxConstraints = keyword IDXCONSTRAINTS >> geniFeats + +{- +geniLitConstraints :: Parser (BoolExp T.Text) +geniLitConstraints = + P.buildExpressionParser table piece + where + piece = (Cond <$> identifier) + <|> do { string "~"; Not `liftM` geniLitConstraints } + <|> parens geniLitConstraints + table = [ [ op "&" And P.AssocLeft ] + , [ op "|" Or P.AssocLeft ] + ] + op s f assoc = P.Infix (do { string s ; return f }) assoc +-} + +squaresString :: Parser Text +squaresString = do + char '[' + s <- (T.concat <$> many inSq) <|> squaresString + char ']' + return $ "[" `T.append` s `T.append` "]" + where + inSq :: Parser Text + inSq = T.pack <$> many1 (noneOf "[]") + +-- the output end of things +-- displaying preformatted semantic input + +data SemInputString = SemInputString Text (Flist GeniVal) + +instance GeniShow SemInputString where + geniShowText (SemInputString semStr idxC) = + geniKeyword SEMANTICS semStr `above` r + where + r | null idxC = "" + | otherwise = geniKeyword IDXCONSTRAINTS (geniShowText idxC) + +toSemInputString :: SemInput -> Text -> SemInputString +toSemInputString (_,lc,_) s = SemInputString s lc + +geniTestSuite :: Parser [TestCase] +geniTestSuite = + tillEof (many geniTestCase) + +-- | Just the String representations of the semantics +-- in the test suite +geniTestSuiteString :: Parser [Text] +geniTestSuiteString = + tillEof (many geniTestCaseString) + +-- | This is only used by the script genimakesuite +geniDerivations :: Parser [TestCaseOutput] +geniDerivations = tillEof $ many geniOutput + +geniTestCase :: Parser TestCase +geniTestCase = + TestCase <$> (option "" (identifier "a test case name")) + <*> lookAhead geniSemanticInputString + <*> geniSemanticInput + <*> many geniSentence + +-- note that the keyword is NOT optional +type TestCaseOutput = (Text, Map.Map (Text,Text) [Text]) +geniOutput :: Parser TestCaseOutput +geniOutput = do + ws <- keyword OUTPUT >> squares geniWords + ds <- Map.fromList <$> many geniTraces + return (ws, ds) + +geniTraces :: Parser ((Text,Text), [Text]) +geniTraces = do + keyword TRACE + squares $ do + k1 <- withWhite geniWord + k2 <- withWhite geniWord + whiteSpace >> char '!' >> whiteSpace + traces <- geniWord `sepEndBy1` whiteSpace + return ((k1,k2), traces) + +withWhite :: Parser a -> Parser a +withWhite p = p >>= (\a -> whiteSpace >> return a) + +geniSentence :: Parser Text +geniSentence = optional (keyword SENTENCE) >> squares geniWords + +geniWords :: Parser Text +geniWords = + T.unwords <$> (sepEndBy1 geniWord whiteSpace "a sentence") + +geniWord :: Parser Text +geniWord = T.pack <$> many1 (noneOf "[]\v\f\t\r\n ") + +-- | The original string representation of a test case semantics +-- (for gui) +geniTestCaseString :: Parser Text +geniTestCaseString = do + option "" (identifier "a test case name") + geniSemanticInputString <* (many geniSentence >> many geniOutput) + +-- ---------------------------------------------------------------------- +-- Lexicon +-- ---------------------------------------------------------------------- + +geniLexicon :: Parser [LexEntry] +geniLexicon = tillEof $ many1 geniLexicalEntry + +geniLexicalEntry :: Parser LexEntry +geniLexicalEntry = + do lemmas <- geniAtomicDisjunction "a lemma (or disjunction thereof)" + family <- identifier "a tree family" + (pars, interface) <- option ([],[]) $ parens paramsParser + equations <- option [] $ do keyword "equations" + geniFeats "path equations" + filters <- option [] $ do keyword "filters" + geniFeats + keywordSemantics + (sem, pols) <- fromLexSem <$> squares geniLexSemantics + -- + return (mkFullLexEntry lemmas family pars interface filters equations sem pols) + where + paramsParser :: Parser ([GeniVal], Flist GeniVal) + paramsParser = do + pars <- many geniValue "some parameters" + interface <- option [] $ do symbol "!" + many geniAttVal + return (pars, interface) + +geniLexSemantics :: Parser [Literal PolValue] +geniLexSemantics = sortSem <$> many (geniLexLiteral "a literal") + +type PolValue = (GeniVal, Int) + +geniLexLiteral :: Parser (Literal PolValue) +geniLexLiteral = geniLiteral_ (mkGAnon,0) geniPolValue + +geniPolValue :: Parser (GeniVal, Int) +geniPolValue = + do p <- geniPolarity + v <- geniValue + return (v,p) + +-- ---------------------------------------------------------------------- +-- Tree schemata +-- ---------------------------------------------------------------------- + +geniMacros :: Parser [SchemaTree] +geniMacros = tillEof $ many geniTreeDef + +initType, auxType :: Parser Ptype +initType = do { reserved INITIAL ; return Initial } +auxType = do { reserved AUXILIARY ; return Auxiliar } + +geniTreeDef :: Parser SchemaTree +geniTreeDef = + do sourcePos <- getPosition + family <- identifier + tname <- option "" (colon *> identifier) + (pars,iface) <- geniParams + theTtype <- (initType <|> auxType) + theTree <- geniTree + -- sanity checks? + let treeFail x = + do setPosition sourcePos -- FIXME does not do what I expect + fail $ "In tree " ++ T.unpack family ++ ":" + ++ T.unpack tname ++ " " ++ show sourcePos ++ ": " ++ x + let theNodes = T.flatten theTree + numFeet = length [ x | x <- theNodes, gtype x == Foot ] + numAnchors = length [ x | x <- theNodes, ganchor x ] + when (not $ any ganchor theNodes) $ + treeFail "At least one node in an LTAG tree must be an anchor" + when (numAnchors > 1) $ + treeFail "There can be no more than 1 anchor node in a tree" + when (numFeet > 1) $ + treeFail "There can be no more than 1 foot node in a tree" + when (theTtype == Initial && numFeet > 0) $ + treeFail "Initial trees may not have foot nodes" + -- + psem <- option Nothing $ do { keywordSemantics; liftM Just (squares geniSemantics) } + ptrc <- option [] $ do { keyword TRACE; squares (many identifier) } + -- + return TT{ params = pars + , pfamily = family + , pidname = tname + , pinterface = sortFlist iface + , ptype = theTtype + , tree = theTree + , ptrace = ptrc + , psemantics = psem + } + +geniTree :: (Ord v, GeniValLike v) => Parser (T.Tree (GNode v)) +geniTree = + do node <- geniNode + kids <- option [] (braces $ many geniTree) + "child nodes" + -- sanity checks + let noKidsAllowed t c = when (c node && (not.null $ kids)) $ + fail $ t ++ " nodes may *not* have any children" + noKidsAllowed "Anchor" $ ganchor + noKidsAllowed "Substitution" $ (== Subs) . gtype + noKidsAllowed "Foot" $ (== Foot) . gtype + -- + return (T.Node node kids) + +geniNode :: (Ord v, GeniValLike v) => Parser (GNode v) +geniNode = do + name <- identifier + nodeType <- geniNodeAnnotation + lex_ <- if nodeType == AnnoLexeme + then ((stringLiteral <|> identifier) `sepBy` symbol "|") "some lexemes" + else return [] + constr <- case nodeType of + AnnoDefault -> adjConstraintParser + AnnoAnchor -> adjConstraintParser + _ -> return True + -- features only obligatory for non-lex nodes + (top,bot) <- if nodeType == AnnoLexeme + then option ([],[]) $ try topbotParser + else topbotParser + return $ GN { gnname = name + , gtype = fromAnnotation nodeType + , gup = sortFlist top + , gdown = sortFlist bot + , glexeme = lex_ + , ganchor = nodeType == AnnoAnchor + , gaconstr = constr + , gorigin = "" + } + where + adjConstraintParser = option False $ reserved ACONSTR >> char ':' >> symbol "noadj" >> return True + topbotParser = do + top <- geniFeats "top features" + symbol "!" + bot <- geniFeats "bot features" + return (top,bot) + +-- | Should be purely internal type to help parsing. +-- Injection to 'GType'. +-- +-- We don't just use GType directly because the annotations convey +-- subtle distinctions that aren't encoded, particularly between +-- lexemes and anchors +data Annotation = AnnoAnchor + | AnnoLexeme + | AnnoSubst + | AnnoFoot + | AnnoDefault + deriving Eq + +fromAnnotation :: Annotation -> GType +fromAnnotation AnnoLexeme = Lex +fromAnnotation AnnoAnchor = Lex +fromAnnotation AnnoSubst = Subs +fromAnnotation AnnoFoot = Foot +fromAnnotation AnnoDefault = Other + +geniNodeAnnotation :: Parser Annotation +geniNodeAnnotation = + (keyword TYPE *> ty) <|> + (reserved ANCHOR >> return AnnoAnchor) <|> + return AnnoDefault + where + ty = choice [ try (symbol s) >> return t | (s,t) <- table ] + table = + [ (ANCHOR, AnnoAnchor) + , (FOOT, AnnoFoot) + , (SUBST, AnnoSubst) + , (LEX, AnnoLexeme) + ] + +-- | This makes it possible to read anchored trees, which may be +-- useful for debugging purposes. +-- +-- FIXME: note that this is very rudimentary; we do not set id numbers, +-- parse polarities. You'll have to call +-- some of our helper functions if you want that functionality. +geniTagElems :: Parser [TagElem] +geniTagElems = tillEof $ setTidnums `fmap` many geniTagElem + +geniTagElem :: Parser TagElem +geniTagElem = do + family <- identifier + tname <- option "" $ (colon *> identifier) + iface <- (snd `liftM` geniParams) <|> geniFeats + theType <- initType <|> auxType + theTree <- geniTree + sem <- do { keywordSemantics; squares geniSemantics } + -- + return $ TE { idname = tname + , ttreename = family + , tinterface = iface + , ttype = theType + , ttree = theTree + , tsemantics = sem + , tidnum = -1 -- provisional id + , tpolarities = Map.empty + , tsempols = [] + , ttrace = [] + } + +-- | 'geniParams' recognises a list of parameters optionally followed by a +-- bang (\verb$!$) and a list of attribute-value pairs. This whole thing is +-- to wrapped in the parens. +-- +-- TODO: deprecate +geniParams :: Parser ([GeniVal], Flist GeniVal) +geniParams = parens $ do + pars <- many geniValue "some parameters" + interface <- option [] $ do { symbol "!"; many geniAttVal } + return (pars, interface) + +-- ---------------------------------------------------------------------- +-- Morphology +-- ---------------------------------------------------------------------- + +geniMorphInfo :: Parser [(Text,Flist GeniVal)] +geniMorphInfo = tillEof $ many morphEntry + +morphEntry :: Parser (Text,Flist GeniVal) +morphEntry = (,) <$> identifier <*> geniFeats + +-- ====================================================================== +-- Everything else +-- ====================================================================== + +-- ---------------------------------------------------------------------- +-- Polarities +-- ---------------------------------------------------------------------- + +-- | 'geniPolarity' associates a numerical value to a polarity symbol, +-- that is, '+' or '-'. +geniPolarity :: Parser Int +geniPolarity = option 0 (plus <|> minus) + where + plus = do { char '+'; return 1 } + minus = do { char '-'; return (-1) } + +-- ---------------------------------------------------------------------- +-- keyword +-- ---------------------------------------------------------------------- + +{-# INLINE keyword #-} +keyword :: Text -> Parser Text +keyword k = + (try $ do { reserved k; colon; return k }) T.unpack k ++ ":" + +{-# INLINE keywordSemantics #-} +keywordSemantics :: Parser Text +keywordSemantics = keyword SEMANTICS + +-- ---------------------------------------------------------------------- +-- language def helpers +-- ---------------------------------------------------------------------- + +lexer :: TokenParser () +lexer = makeTokenParser geniLanguageDef + +whiteSpace :: Parser () +whiteSpace = P.whiteSpace lexer + +identifier :: Parser Text +identifier = decode <$> P.identifier lexer + +-- stolen from Parsec code (ident) +-- | Like 'identifier' but allows for reserved words too +looseIdentifier :: Parser Text +looseIdentifier = + decode <$> do { i <- ident ; whiteSpace; return i } + where + ident = do + { c <- identStart geniLanguageDef + ; cs <- many (identLetter geniLanguageDef) + ; return (c:cs) } "identifier" + +colon :: Parser Text +colon = decode <$> P.colon lexer + +stringLiteral :: Parser Text +stringLiteral = decode <$> P.stringLiteral lexer + +squares, braces, parens :: Parser a -> Parser a +squares = P.squares lexer +braces = P.braces lexer +parens = P.parens lexer + +reserved :: Text -> Parser Text +reserved s = P.reserved lexer (T.unpack s) >> return s + +symbol :: Text -> Parser Text +symbol s = P.symbol lexer (T.unpack s) >> return s + +decode :: String -> Text +decode = T.pack + +-- ---------------------------------------------------------------------- +-- parsec helpers +-- ---------------------------------------------------------------------- + +-- | identifier, permitting reserved words too +identifierR :: Parser Text +identifierR = decode <$> do + { c <- P.identStart geniLanguageDef + ; cs <- many (P.identLetter geniLanguageDef) + ; return (c:cs) + } "identifier or reserved word" + +tillEof :: Parser a -> Parser a +tillEof p = whiteSpace *> p <* eof + +-- stolen from Parsec and adapted to use UTF-8 input +parseFromFile :: Parser a -> SourceName -> IO (Either ParseError a) +parseFromFile p fname + = do{ input <- UTF8.readFile fname + ; return (parse p fname input) + } diff --git a/src/NLP/GenI/Polarity.hs b/src/NLP/GenI/Polarity.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Polarity.hs @@ -0,0 +1,572 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Polarity( + module NLP.GenI.Polarity.Types, + + -- * Entry point + PolAut, PolState(PolSt), AutDebug, PolResult(..), + buildAutomaton, + + -- * Inner stuff (exported for debugging?) + makePolAut, + fixPronouns, + detectSansIdx, suggestPolFeatures, detectPols, detectPolPaths, + declareIdxConstraints, detectIdxConstraints, + prettyPolPaths, prettyPolPaths', + + -- re-exported from Automaton + automatonPaths, finalSt, + NFA(states, transitions), + ) +where + +import Data.Bits +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.List +import Data.Maybe (isNothing, isJust) +import Data.Text (Text) +import qualified Data.Text as T + +import NLP.GenI.Automaton +import NLP.GenI.FeatureStructure ( Flist, AvPair(..), FeatStruct, unifyFeat ) +import NLP.GenI.General + ( BitVector, isEmptyIntersect, thd3, Interval, ival, (!+!) + ) +import NLP.GenI.GeniVal ( GeniVal(gConstraints), mkGAnon, isAnon, replace ) +import NLP.GenI.Polarity.Internal +import NLP.GenI.Polarity.Types +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( Literal(..), SemInput, Sem, emptyLiteral + , sortSem + ) +import NLP.GenI.Tag ( TagElem(..), TagItem(..), setTidnums ) +import NLP.GenI.TreeSchema ( Ptype(Initial), GNode, root, gup, gdown, rootUpd) + +-- ---------------------------------------------------------------------- +-- Interface +-- ---------------------------------------------------------------------- + +-- | intermediate auts, seed aut, final aut, potentially modified sem +data PolResult = PolResult { prIntermediate :: [AutDebug] + , prInitial :: PolAut + , prFinal :: PolAut + , prSem :: Sem } +type AutDebug = (PolarityKey, PolAut, PolAut) + +-- | Constructs a polarity automaton. For debugging purposes, it returns +-- all the intermediate automata produced by the construction algorithm. +buildAutomaton :: Set.Set PolarityAttr -- ^ polarities to detect (eg. "cat") + -> FeatStruct GeniVal -- ^ root features to compensate for + -> PolMap -- ^ explicit extra polarities + -> SemInput -- ^ input semantics + -> [TagElem] -- ^ lexical selection + -> PolResult +buildAutomaton polarityAttrs rootFeat extrapol (tsem,tres,_) candRaw = + let -- root categories, index constraints, and external polarities + rcatPol :: PolMap + rcatPol = detectRootCompensation polarityAttrs rootFeat + -- index constraints on candidate trees + detect = detectIdxConstraints tres + constrain t = t { tpolarities = Map.unionWith (!+!) p r + } --, tinterface = [] } + where p = tpolarities t + r = detect . tinterface $ t + candRest = map constrain candRaw + inputRest = declareIdxConstraints tres + -- polarity detection + cand1 = map (detectPols polarityAttrs) candRest + extras1 = Map.unionsWith (!+!) [ extrapol, inputRest, rcatPol ] + ks1 = polarityKeys cand1 Map.empty + -- expanding unconstrained polarities + tconvert t = t { tpolarities = convertUnconstrainedPolarities ks1 (tpolarities t) } + cand = map tconvert cand1 + extras = convertUnconstrainedPolarities ks1 extras1 + ks = polarityKeys cand extras + -- building the automaton + in makePolAut cand tsem extras ks + +makePolAut :: [TagElem] -> Sem -> PolMap -> [PolarityKey] -> PolResult +makePolAut candsRaw tsemRaw extraPol ks = + let -- perform index counting + (tsem, cands') = fixPronouns (tsemRaw,candsRaw) + cands = setTidnums cands' + -- sorted semantics (for more efficient construction) + sortedsem = sortSemByFreq tsem cands + -- the seed automaton + smap = buildColumns cands sortedsem + seed = buildSeedAut smap sortedsem + -- building and remembering the automata + build k xs = (k,aut,prune aut):xs + where aut = buildPolAut k initK (thd3 $ head xs) + initK = Map.findWithDefault (ival 0) k extraPol + res = foldr build [(PolarityKeyStr "(seed)",seed,prune seed)] ks + in PolResult { prIntermediate = reverse res + , prInitial = seed + , prFinal = thd3 $ head res + , prSem = tsem } + +-- ==================================================================== +-- Polarity automaton +-- ==================================================================== + +-- | Note: this is not the same function as 'NLP.GenI.Tags.mapBySem'! +-- The fact that we +-- preserve the order of the input semantics is important for our handling +-- of multi-literal semantics and for semantic frequency sorting. +buildColumns :: (TagItem t) => [t] + -> Sem + -> Map.Map (Literal GeniVal) [t] +buildColumns cands [] = + Map.singleton emptyLiteral e + where e = filter (null.tgSemantics) cands + +buildColumns cands (l:ls) = + let matchfn t = l `elem` tgSemantics t + (match, cands2) = partition matchfn cands + next = buildColumns cands2 ls + in Map.insert l match next + +-- ---------------------------------------------------------------------- +-- Initial Automaton +-- ---------------------------------------------------------------------- + +buildSeedAut :: SemMap -> Sem -> PolAut +buildSeedAut cands tsem = + let start = polstart [] + hasZero (x,y) = x <= 0 && y >= 0 + isFinal (PolSt c _ pols) = + c == length tsem && all hasZero pols + initAut = NFA + { startSt = start + , isFinalSt = Just isFinal + , finalStList = [] + , states = [[start]] + , transitions = Map.empty } + in nubAut $ buildSeedAut' cands tsem 1 initAut + +-- for each literal... +buildSeedAut' :: SemMap -> Sem -> Int -> PolAut -> PolAut +buildSeedAut' _ [] _ aut = aut +buildSeedAut' cands (l:ls) i aut = + let -- previously created candidates + prev = head $ states aut + -- candidates that match the target semantics + tcands = Map.findWithDefault [] l cands + -- create the next batch of states + fn st ap = buildSeedAutHelper tcands l i st ap + (newAut,newStates) = foldr fn (aut,[]) prev + next = nub newStates : states aut + -- recursive step to the next literal + in buildSeedAut' cands ls (i+1) (newAut { states = next }) + +-- for each candidate corresponding to literal l... +buildSeedAutHelper :: [TagElem] + -> Literal GeniVal + -> Int + -> PolState + -> (PolAut,[PolState]) + -> (PolAut,[PolState]) +buildSeedAutHelper cs l i st (aut,prev) = + let -- get the extra semantics from the last state + (PolSt _ ex1 _) = st + -- candidates that match the target semantics and which + -- do not overlap the extra baggage semantics + tcand = [ Just t | t <- cs + , isEmptyIntersect ex1 (tsemantics t) ] + -- add the transitions out of the current state + addT tr (a,n) = (addTrans a st tr st2, st2:n) + where + st2 = PolSt i (delete l $ ex1 ++ ex2) [] + ex2 = case tr of + Nothing -> [] + Just tr_ -> tsemantics tr_ + in if (l `elem` ex1) + then addT Nothing (aut,prev) + else foldr addT (aut,prev) tcand + +-- ---------------------------------------------------------------------- +-- Construction +-- ---------------------------------------------------------------------- + +buildPolAut :: PolarityKey -> Interval -> PolAut -> PolAut +buildPolAut k initK skelAut = + let concatPol p (PolSt pr b pol) = PolSt pr b (p:pol) + newStart = concatPol initK $ startSt skelAut + -- + initAut = skelAut + { startSt = newStart + , states = [[newStart]] + , transitions = Map.empty } + -- cand' = observe "candidate map" cand + in nubAut $ buildPolAut' k (transitions skelAut) initAut + +{- +Our helper function looks at a single state in the skeleton automaton +and at one of the states in the new automaton which correspond to it. +We use the transitions from the old automaton to determine which states +to construct. Note: there can be more than one state in the automaton +which corresponds to a state in the old automaton. This is because we +are looking at a different polarity key, so that whereas two candidates +automaton may transition to the same state in the old automaton, their +polarity effects for the new key will make them diverge in the new +automaton. +-} + +buildPolAut' :: PolarityKey -> PolTransFn -> PolAut -> PolAut +-- for each literal... (this is implicit in the automaton state grouping) +buildPolAut' fk skeleton aut = + let -- previously created candidates + prev = head $ states aut + -- create the next batch of states + fn st ap = buildPolAutHelper fk skeleton st ap + (newAut,newStates) = foldr fn (aut,Set.empty) prev + next = Set.toList newStates : states aut + -- recursive step to the next literal + in if Set.null newStates + then aut + else buildPolAut' fk skeleton (newAut { states = next }) + +-- given a previously created state... +buildPolAutHelper :: PolarityKey -> PolTransFn -> PolState -> (PolAut,Set.Set PolState) -> (PolAut,Set.Set PolState) +buildPolAutHelper fk skeleton st (aut,prev) = + let -- reconstruct the skeleton state used to build st + PolSt pr ex (po1:skelpo1) = st + skelSt = PolSt pr ex skelpo1 + -- for each transition out of the current state + -- nb: a transition is (next state, [labels to that state]) + trans = Map.toList $ Map.findWithDefault Map.empty skelSt skeleton + result = foldr addT (aut,prev) trans + -- . for each label to the next state st2 + addT (oldSt2,trs) (a,n) = foldr (addTS oldSt2) (a,n) trs + -- .. calculate a new state and add a transition to it + addTS skel2 tr (a,n) = (addTrans a st tr st2, Set.insert st2 n) + where st2 = newSt tr skel2 + -- + newSt :: Maybe TagElem -> PolState -> PolState + newSt t skel2 = PolSt pr2 ex2 (po2:skelPo2) + where + PolSt pr2 ex2 skelPo2 = skel2 + po2 = po1 !+! Map.findWithDefault (ival 0) fk pol + pol = case t of Nothing -> Map.empty + Just t2 -> tpolarities t2 + in result + +-- ---------------------------------------------------------------------- +-- Pruning +-- ---------------------------------------------------------------------- + +{-| +The pruning algorithm takes as arguments a list of states to process. +Among these, any state which does not have outgoing transitions is +placed on the blacklist. We remove all transitions to the blacklist and +all states that only transition to the blacklist, and then we repeat +pruning, with a next batch of states. + +Finally, we return the pruned automaton. Note: in order for this to +work, it is essential that the final states are *not* included in the +list of states to process. +-} +prune :: PolAut -> PolAut +prune aut = + let theStates = states aut + final = finalSt aut + -- (remember that states is a list of lists) + lastStates = head theStates + nextStates = tail theStates + nonFinal = (lastStates \\ final) + -- the helper function will rebuild the state list + firstAut = aut { states = [] } + pruned = prune' (nonFinal:nextStates) firstAut + -- re-add the final state! + statesPruned = states pruned + headPruned = head statesPruned + tailPruned = tail statesPruned + in if (null theStates) + then aut + else pruned { states = (headPruned ++ final) : tailPruned } + +prune' :: [[PolState]] -> PolAut -> PolAut +prune' [] oldAut = oldAut { states = reverse $ states oldAut } +prune' (sts:next) oldAut = + let -- calculate the blacklist + oldT = transitions oldAut + oldSt = states oldAut + transFrom st = Map.lookup st oldT + blacklist = filter (isNothing.transFrom) sts + -- given a st: filter out all transitions to the blacklist + allTrans = Map.toList $ transitions oldAut + -- delete all transitions to the blacklist + miniTrim = Map.filterWithKey (\k _ -> not (k `elem` blacklist)) + -- extra cleanup: delete from map states that only transition to the blacklist + trim = Map.filterWithKey (\k m -> not (k `elem` blacklist || Map.null m)) + -- execute the kill and miniKill filters + newT = trim $ Map.fromList [ (st2, miniTrim m) | (st2,m) <- allTrans ] + -- new list of states and new automaton + newSts = sts \\ blacklist + newAut = oldAut { transitions = newT, + states = newSts : oldSt } + {- + -- debugging code + debugstr = "blacklist: [\n" ++ debugstr' ++ "]" + debugstr' = concat $ intersperse "\n" $ map showSt blacklist + showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po + showPr (_,pr,_) = pr ++ " " + showPo po = concat $ intersperse "," $ map show po + showEx ex = if (null ex) then "" else (showSem ex) + -} + -- recursive step + in if null blacklist + then oldAut { states = (reverse oldSt) ++ (sts:next) } + else prune' next newAut + +-- ==================================================================== +-- Zero-literal semantics +-- ==================================================================== + +type PredLite = (String,[GeniVal]) -- handle is head of arg list +type SemWeightMap = Map.Map PredLite SemPols + +-- | Returns a modified input semantics and lexical selection in which pronouns +-- are properly accounted for. +fixPronouns :: (Sem,[TagElem]) -> (Sem,[TagElem]) +fixPronouns (tsem,cands) = + let -- part 1 (for each literal get smallest charge for each idx) + getpols :: TagElem -> [ (PredLite,SemPols) ] + getpols x = zip [ (prettyStr p, h:as) | Literal h p as <- tsemantics x ] (tsempols x) + sempols :: [ (PredLite,SemPols) ] + sempols = concatMap getpols cands + usagemap :: SemWeightMap + usagemap = Map.fromListWith (zipWith min) sempols + -- part 2 (cancel sem polarities) + chargemap :: Map.Map GeniVal Int -- index to charge + chargemap = Map.fromListWith (+) $ concatMap clump $ Map.toList usagemap + where clump ((_,is),ps) = zip is ps + -- part 3 (adding extra semantics) + indices = concatMap fn (Map.toList chargemap) + where fn (i,c) = replicate (negate c) i + -- the extra columns + extraSem = map indexLiteral indices + tsem2 = sortSem (tsem ++ extraSem) + -- zero-literal semantic items to realise the extra columns + zlit = filter (null.tsemantics) cands + cands2 = (cands \\ zlit) ++ concatMap fn indices + where fn i = map (tweak i) zlit + tweak i x = assignIndex i $ x { tsemantics = [indexLiteral i] } + -- part 4 (insert excess pronouns in tree sem) + comparefn :: GeniVal -> Int -> Int -> [GeniVal] + comparefn i ct cm = if cm < ct then extra else [] + where maxNeeded = Map.findWithDefault 0 i chargemap -- cap the number added + extra = replicate (min (negate maxNeeded) (ct - cm)) i + comparePron :: (PredLite,SemPols) -> [GeniVal] + comparePron (lit,c1) = concat $ zipWith3 comparefn idxs c1 c2 + where idxs = snd lit + c2 = Map.findWithDefault [] lit usagemap + addextra :: TagElem -> TagElem + addextra c = c { tsemantics = sortSem (sem ++ extra) } + where sem = tsemantics c + extra = map indexLiteral $ concatMap comparePron (getpols c) + cands3 = map addextra cands2 + in (tsem2, cands3) + +-- | Builds a fake semantic predicate that the index counting mechanism uses to +-- represent extra columns. +indexLiteral :: GeniVal -> Literal GeniVal +indexLiteral x = Literal x mkGAnon [] + +-- Returns True if the given literal was introduced by the index counting mechanism +isExtraCol :: Literal GeniVal -> Bool +isExtraCol (Literal _ p []) = isAnon p +isExtraCol _ = False + +-- | 'assignIndex' is a useful way to restrict the behaviour of +-- null semantic items like pronouns using the information generated by +-- the index counting mechanism. The problem with null semantic items +-- is that their indices are not set, which means that they could +-- potentially combine with any other tree. To make things more +-- efficient, we can set the index of these items and thus reduce the +-- number of spurious combinations. +-- +-- Notes +-- +-- * These combinations could produce false results if the +-- input has to use multiple pronouns. For example, if you wanted to say +-- something like “John promises Mary to convince Paul to give her +-- his book”, these combinations could instead produce “give him +-- *her* book“. +-- +-- * This function works by FS unification on the root node of the +-- tree with the *[idx:i]*. If unification is not possible, +-- we simply return the tree as is. +-- +-- * This function renames the tree by appending the index to its name +assignIndex :: GeniVal -> TagElem -> TagElem +assignIndex i te = + let idxfs = [ AvPair __idx__ i ] + oldt = ttree te + oldr = root oldt + tfup = gup oldr + -- + in case unifyFeat tfup idxfs of + Nothing -> te + Just (gup2, sub) -> replace sub $ te { ttree = newt } + where newt = rootUpd oldt $ oldr { gup = gup2 } + +-- ==================================================================== +-- Further optimisations +-- ==================================================================== + +-- Index constraints +-- ----------------- +detectIdxConstraints :: Flist GeniVal -> Flist GeniVal -> PolMap +detectIdxConstraints cs interface = + let matches = intersect cs interface + matchStr = map idxConstraintKey matches + in Map.fromList $ zip matchStr ((repeat.ival) 1) + +declareIdxConstraints :: Flist GeniVal -> PolMap +declareIdxConstraints = Map.fromList . (map declare) where + declare c = (idxConstraintKey c, minusone) + minusone = ival (-1) + +-- TODO: test that index constraints come first +idxConstraintKey :: AvPair GeniVal -> PolarityKey +idxConstraintKey = PolarityKeyStr . ("." <>) . pretty + +-- Automatic polarity detection +-- ---------------------------- +suggestPolFeatures :: [TagElem] -> [Text] +suggestPolFeatures tes = + let -- only initial trees need be counted; in aux trees, the + -- root node is implicitly canceled by the foot node + rfeats, sfeats :: [Flist GeniVal] + rfeats = map (gdown.root.ttree) $ filter (\t -> ttype t == Initial) tes + sfeats = [ concat s | s <- map substTops tes, (not.null) s ] + -- + attrs :: Flist GeniVal -> [Text] + attrs avs = [ a | AvPair a v <- avs, isJust (gConstraints v) ] + theAttributes = map attrs $ rfeats ++ sfeats + in if null theAttributes then [] else foldr1 intersect theAttributes + +-- FIXME: temporary HACKY code - delete me as soon as possible (written +-- 2006-03-30 +-- +-- only initial trees need be counted; in aux trees, the +-- root node is implicitly canceled by the foot node +detectSansIdx :: [TagElem] -> [TagElem] +detectSansIdx = + let rfeats t = (gdown.root.ttree) t + feats t | ttype t == Initial = concat $ rfeats t : substTops t + feats t = concat $ substTops t + attrs avs = [ a | AvPair a v <- avs, isJust (gConstraints v) ] + hasIdx t = __idx__ `elem` (attrs.feats $ t) || (ttype t /= Initial && (null $ substTops t)) + in filter (not.hasIdx) + +detectPols :: Set.Set PolarityAttr -> TagElem -> TagElem +detectPols attrs t = + t { tpolarities = addPols (detectPolsH attrs t) (tpolarities t) } + +-- Chart sharing +-- ------------- + +-- | Given a list of paths (i.e. a list of list of trees) +-- return a list of trees such that each tree is annotated with the paths it +-- belongs to. +detectPolPaths :: [[TagElem]] -> [(TagElem,BitVector)] +detectPolPaths paths = + let pathFM = detectPolPaths' Map.empty 0 paths + lookupTr k = Map.findWithDefault 0 k pathFM + in map (\k -> (k, lookupTr k)) $ Map.keys pathFM + +type PolPathMap = Map.Map TagElem BitVector +detectPolPaths' :: PolPathMap -> Int -> [[TagElem]] -> PolPathMap + +detectPolPaths' accFM _ [] = accFM +detectPolPaths' accFM counter (path:ps) = + let currentBits = shiftL 1 counter -- shift counter times the 1 bit + fn f [] = f + fn f (t:ts) = fn (Map.insertWith (.|.) t currentBits f) ts + newFM = fn accFM path + in detectPolPaths' newFM (counter+1) ps + +-- | Render the list of polarity automaton paths as a string +prettyPolPaths :: BitVector -> Text +prettyPolPaths paths = + T.intercalate ", " $ map pretty pathlist + where + pathlist = prettyPolPaths' paths 1 + +prettyPolPaths' :: BitVector -> Int -> [Int] +prettyPolPaths' 0 _ = [] +prettyPolPaths' bv counter = + if b then (counter:next) else next + where b = testBit bv 0 + next = prettyPolPaths' (shiftR bv 1) (counter + 1) + +-- Semantic sorting +-- ---------------- + +sortSemByFreq :: Sem -> [TagElem] -> Sem +sortSemByFreq tsem cands = + let counts = map lenfn tsem + lenfn l = length $ filter fn cands + where fn x = l `elem` (tsemantics x) + -- note: we introduce an extra hack to push + -- index-counted extra columns to the end; just for UI reasons + sortfn a b + | isX a && isX b = compare (snd a) (snd b) + | isX a = GT + | isX b = LT + | otherwise = compare (snd a) (snd b) + where isX = isExtraCol.fst + sorted = sortBy sortfn $ zip tsem counts + in (fst.unzip) sorted + +-- ---------------------------------------------------------------------- +-- Types +-- ---------------------------------------------------------------------- + +-- Polarity NFA + +data PolState = PolSt Int [Literal GeniVal] [(Int,Int)] + -- ^ position in the input semantics, extra semantics, + -- polarity interval + deriving (Eq) +type PolTrans = TagElem +type PolAut = NFA PolState PolTrans +type PolTransFn = Map.Map PolState (Map.Map PolState [Maybe PolTrans]) + +instance Show PolState + where show (PolSt pr ex po) = show pr ++ " " ++ prettyStr ex ++ show po +-- showPred pr ++ " " ++ showSem ex ++ show po + +instance Ord PolState where + compare (PolSt pr1 ex1 po1) (PolSt pr2 ex2 po2) = + let prC = compare pr1 pr2 + expoC = compare (ex1,po1) (ex2,po2) + in if (prC == EQ) then expoC else prC + +-- We include also some fake states which are useful for general +-- housekeeping during the main algortihms. +fakestate :: Int -> [Interval] -> PolState +fakestate s pol = PolSt s [] pol --PolSt (0, s, [""]) [] pol + +-- | an initial state for polarity automata +polstart :: [Interval] -> PolState +polstart pol = fakestate 0 pol -- fakestate "START" pol diff --git a/src/NLP/GenI/Polarity.lhs b/src/NLP/GenI/Polarity.lhs deleted file mode 100644 --- a/src/NLP/GenI/Polarity.lhs +++ /dev/null @@ -1,1206 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2009 Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Polarity Optimisation} -\label{cha:Polarity} - -We introduce a notion of polarities as a means of pre-detecting -incompatibilities between candidate trees for different propositions. -This optimisation is inserted between candidate selection -(section \ref{sec:candidate_selection}) -and chart generation. The input to this optimisation is the -\jargon{target semantics} and the corresponding \jargon{candidate - trees}. - -This whole optimisation is based on adding polarities to the grammar. -We have a set of strings which we call \jargon{polarity keys}, and some -positive or negative integers which we call \jargon{charges}. Each tree -in the grammar may assign a charge to some number of polarity keys. For -example, here is a simple grammar that uses the polarity keys n and v. - -\begin{tabular}{|l|l|} -\hline -tree & polarity effects \\ -\hline -s(n$\downarrow$, v$\downarrow$, n$\downarrow$) & -2n -v\\ -v(hates) & +v\\ -n(mary) & +n\\ -n(john) & +n\\ -\hline -\end{tabular} - -For now, these annotations are done by hand, and are based on syntactic -criteria (substitution and root node categories) but one could envisage -alternate criteria or an eventual means of automating the process. - -The basic idea is to use the polarity keys to determine which subsets of -candidate trees are incompatible with each other and rule them out. We -construct a finite state automaton which uses polarity keys to -pre-calculate the compatibility of sets of trees. At the end of the -optimisation, we are left with an automaton, each path of which is a -potentially compatible set of trees. We then preform surface -realisation seperately, treating each path as a set of candidate trees. - -\emph{Important note}: one thing that may be confusing in this chapter -is that we refer to polarities (charges) as single integers, e.g, $-2n$. -In reality, to account for weird stuff like atomic disjunction, we do -not use simple integers, but polarities intervals, so more something -like $(-2,-2)n$! But for the most part, the intervals are zero length, -and you can just think of $-2n$ as shorthand for $(-2,-2)n$. - -\begin{code} -module NLP.GenI.Polarity( - -- * Entry point - PolAut, PolState(PolSt), AutDebug, PolResult, - buildAutomaton, - - -- * Inner stuff (exported for debugging?) - makePolAut, - fixPronouns, - detectSansIdx, detectPolFeatures, detectPols, detectPolPaths, - declareIdxConstraints, detectIdxConstraints, - showLite, showLitePm, showPolPaths, showPolPaths', - - -- re-exported from Automaton - automatonPaths, finalSt, - NFA(states, transitions), - ) -where -\end{code} - -\begin{code} -import Data.Bits -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.List -import Data.Maybe (isNothing, isJust) -import Data.Tree (flatten) -import qualified Data.Set as Set - -import NLP.GenI.Automaton -import NLP.GenI.Btypes(Pred, SemInput, Sem, Flist, AvPair(..), showAv, - GeniVal(..), fromGConst, isConst, - replace, - emptyPred, Ptype(Initial), - showFlist, showSem, sortSem, - GNode, root, gup, gdown, gtype, GType(Subs), - SemPols, unify, unifyFeat, rootUpd) -import NLP.GenI.General( - BitVector, isEmptyIntersect, thd3, - Interval, ival, (!+!), showInterval) -import NLP.GenI.PolarityTypes -import NLP.GenI.Tags(TagElem(..), TagItem(..), setTidnums) -\end{code} - -\section{Interface} - -\begin{code} --- | intermediate auts, seed aut, final aut, potentially modified sem -type PolResult = ([AutDebug], PolAut, PolAut, Sem) -type AutDebug = (PolarityKey, PolAut, PolAut) - --- | Constructs a polarity automaton. For debugging purposes, it returns --- all the intermediate automata produced by the construction algorithm. -buildAutomaton :: Set.Set PolarityAttr -- ^ polarities to detect - -> Flist -- ^ root features to compensate for - -> PolMap -- ^ explicit extra polarities - -> SemInput -- ^ input semantics - -> [TagElem] -- ^ lexical selection - -> PolResult -buildAutomaton polarityAttrs rootFeat extrapol (tsem,tres,_) candRaw = - let -- root categories, index constraints, and external polarities - rcatPol :: Map.Map PolarityKey Interval - rcatPol = Map.fromList . pdJusts - $ map (\v -> detectPolarityForAttr (-1) (pAttr v) rootFeat) - $ Set.toList polarityAttrs - pAttr p@(SimplePolarityAttr _) = spkAtt p - pAttr p@(RestrictedPolarityAttr _ _) = rpkAtt p - -- - allExtraPols = Map.unionsWith (!+!) [ extrapol, inputRest, rcatPol ] - -- index constraints on candidate trees - detect = detectIdxConstraints tres - constrain t = t { tpolarities = Map.unionWith (!+!) p r - } --, tinterface = [] } - where p = tpolarities t - r = detect . tinterface $ t - candRest = map constrain candRaw - inputRest = declareIdxConstraints tres - -- polarity detection - cand = detectPols polarityAttrs candRest - -- building the automaton - in makePolAut cand tsem allExtraPols -\end{code} - -\section{The automaton itself - outline} -\label{polarity:overview} - -We start with the controller function (the general architecture) and -detail the individual steps in the following sections. The basic -architecture is as follows: - -\begin{enumerate} -\item Build a seed automaton (section \ref{sec:seed_automaton}). -\item For each polarity key, elaborate the - automaton with the polarity information for that key - (section \ref{sec:automaton_construction}) and minimise - the automaton (section \ref{sec:automaton_pruning}). -\end{enumerate} - -The above process can be thought of as a more efficient way of -constructing an automaton for each polarity key, minimising said -automaton, and then taking their intersection. In any case, -we return everything a tuple with (1) a list of the automota that -were created (2) the final automaton (3) a possibly modified -input semantics. The first item is only neccesary for debugging; only -the last two are important. - -Note: -\begin{itemize} -\item the \fnparam{extraPol} argument is a map containing any initial - values for polarity keys. This is useful to impose external filters - like ``I only want expressions where the object is topicalised''. -\item to recuperate something useful from these automaton, it might - be helpful to call \fnref{automatonPaths} on it. -\end{itemize} - -\begin{code} -makePolAut :: [TagElem] -> Sem -> PolMap -> PolResult -makePolAut candsRaw tsemRaw extraPol = - let -- polarity items - ksCands = concatMap (Map.keys . tpolarities) cands - ksExtra = Map.keys extraPol - ks = sortBy (flip compare) $ nub $ ksCands ++ ksExtra - -- perform index counting - (tsem, cands') = fixPronouns (tsemRaw,candsRaw) - cands = setTidnums cands' - -- sorted semantics (for more efficient construction) - sortedsem = sortSemByFreq tsem cands - -- the seed automaton - smap = buildColumns cands sortedsem - seed = buildSeedAut smap sortedsem - -- building and remembering the automata - build k xs = (k,aut,prune aut):xs - where aut = buildPolAut k initK (thd3 $ head xs) - initK = Map.findWithDefault (ival 0) k extraPol - res = foldr build [(PolarityKey "(seed)",seed,prune seed)] ks - in (reverse res, seed, thd3 $ head res, tsem) -\end{code} - -% ==================================================================== -\section{Polarity automaton} -\label{sec:polarity_automaton} -% ==================================================================== - -We construct a finite state automaton for each polarity key that is in -the set of trees. It helps to imagine a table where each column -corresponds to a single proposition. - -\begin{center} -\begin{tabular}{|c|c|c|} -\hline -\semexpr{gift(g)} & \semexpr{cost(g,x)} & \semexpr{high(x)} \\ -\hline -\natlang{the gift} \color{blue}{+1np} & -\natlang{the cost of} & -\natlang{is high} \color{red}{-1np} \\ -% -\natlang{the present} \color{blue}{+1np} & -\natlang{costs} \color{red}{-1np} & -\natlang{a lot} \\ -% -&& \natlang{much} \\ -\hline -\end{tabular} -\end{center} - -Each column (proposition) has a different number of cells which -corresponds to the lexical ambiguity for that proposition, more -concretely, the number of candidate trees for that proposition. The -\jargon{polarity automaton} describes the different ways we can traverse -the table from column to column, choosing a cell to pass through at each -step and accumulating polarity along the way. Each state represents the -polarity at a column and each transition represents the tree we chose to -get there. All transitions from one columns $i$ to the next $i+1$ that -lead to the same accumulated polarity lead to the same state. - -% ---------------------------------------------------------------------- -\subsection{Columns} -% ---------------------------------------------------------------------- - -We build the columns for the polarity automaton as follows. Given a -input semantics \texttt{sem} and a list of trees \texttt{cands}, we -group the trees by the first literal of sem that is part of their tree -semantics. - -Note: this is not the same function as Tags.mapBySem! The fact that we -preserve the order of the input semantics is important for our handling -of multi-literal semantics and for semantic frequency sorting. - -\begin{code} -buildColumns :: (TagItem t) => [t] -> Sem -> Map.Map Pred [t] -buildColumns cands [] = - Map.singleton emptyPred e - where e = filter (null.tgSemantics) cands - -buildColumns cands (l:ls) = - let matchfn t = l `elem` tgSemantics t - (match, cands2) = partition matchfn cands - next = buildColumns cands2 ls - in Map.insert l match next -\end{code} - -% ---------------------------------------------------------------------- -\subsection{Initial Automaton} -\label{sec:seed_automaton} -% ---------------------------------------------------------------------- - -We first construct a relatively trivial polarity automaton without any -polarity effects. Each state except the start state corresponds -to a literal in the target semantics, and the transitions to a state -consist of the trees whose semantics is subsumed by that literal. - -\begin{code} -buildSeedAut :: SemMap -> Sem -> PolAut -buildSeedAut cands tsem = - let start = polstart [] - hasZero (x,y) = x <= 0 && y >= 0 - isFinal (PolSt c _ pols) = - c == length tsem && all hasZero pols - initAut = NFA - { startSt = start - , isFinalSt = Just isFinal - , finalStList = [] - , states = [[start]] - , transitions = Map.empty } - in nubAut $ buildSeedAut' cands tsem 1 initAut - --- for each literal... -buildSeedAut' :: SemMap -> Sem -> Int -> PolAut -> PolAut -buildSeedAut' _ [] _ aut = aut -buildSeedAut' cands (l:ls) i aut = - let -- previously created candidates - prev = head $ states aut - -- candidates that match the target semantics - tcands = Map.findWithDefault [] l cands - -- create the next batch of states - fn st ap = buildSeedAutHelper tcands l i st ap - (newAut,newStates) = foldr fn (aut,[]) prev - next = nub newStates : states aut - -- recursive step to the next literal - in buildSeedAut' cands ls (i+1) (newAut { states = next }) - --- for each candidate corresponding to literal l... -buildSeedAutHelper :: [TagElem] -> Pred -> Int -> PolState -> (PolAut,[PolState]) -> (PolAut,[PolState]) -buildSeedAutHelper cs l i st (aut,prev) = - let -- get the extra semantics from the last state - (PolSt _ ex1 _) = st - -- candidates that match the target semantics and which - -- do not overlap the extra baggage semantics - tcand = [ Just t | t <- cs - , isEmptyIntersect ex1 (tsemantics t) ] - -- add the transitions out of the current state - addT tr (a,n) = (addTrans a st tr st2, st2:n) - where - st2 = PolSt i (delete l $ ex1 ++ ex2) [] - ex2 = case tr of - Nothing -> [] - Just tr_ -> tsemantics tr_ - in if (l `elem` ex1) - then addT Nothing (aut,prev) - else foldr addT (aut,prev) tcand -\end{code} - -% ---------------------------------------------------------------------- -\subsection{Construction} -\label{sec:automaton_construction} -\label{sec:automaton_intersection} -% ---------------------------------------------------------------------- - -The goal is to construct a polarity automaton which accounts for a -given polarity key $k$. The basic idea is that given -literals $p_1..p_n$ in the target semantics, we create a start state, -calculate the states/transitions to $p_1$ and succesively calculate -the states/transitions from proposition $p_x$ to $p_{x+1}$ for all -$1 < x < n$. - -The ultimate goal is to construct an automaton that accounts for -multiple polarity keys. The simplest approach would be to -calculate a seperate automaton for each key, prune them all and -then intersect the pruned automaton together, but we can do much -better than that. Since the pruned automata are generally much -smaller in size, we perform an iterative intersection by using -a previously pruned automaton as the skeleton for the current -automaton. This is why we don't pass any literals or candidates -to the construction step; it takes them directly from the previous -automaton. See also section \ref{sec:seed_automaton} for the seed -automaton that you can use when there is no ``previous automaton''. - -\begin{code} -buildPolAut :: PolarityKey -> Interval -> PolAut -> PolAut -buildPolAut k initK skelAut = - let concatPol p (PolSt pr b pol) = PolSt pr b (p:pol) - newStart = concatPol initK $ startSt skelAut - -- - initAut = skelAut - { startSt = newStart - , states = [[newStart]] - , transitions = Map.empty } - -- cand' = observe "candidate map" cand - in nubAut $ buildPolAut' k (transitions skelAut) initAut -\end{code} - -Our helper function looks at a single state in the skeleton automaton -and at one of the states in the new automaton which correspond to it. -We use the transitions from the old automaton to determine which states -to construct. Note: there can be more than one state in the automaton -which corresponds to a state in the old automaton. This is because we -are looking at a different polarity key, so that whereas two candidates -automaton may transition to the same state in the old automaton, their -polarity effects for the new key will make them diverge in the new -automaton. - -\begin{code} -buildPolAut' :: PolarityKey -> PolTransFn -> PolAut -> PolAut --- for each literal... (this is implicit in the automaton state grouping) -buildPolAut' fk skeleton aut = - let -- previously created candidates - prev = head $ states aut - -- create the next batch of states - fn st ap = buildPolAutHelper fk skeleton st ap - (newAut,newStates) = foldr fn (aut,Set.empty) prev - next = Set.toList newStates : states aut - -- recursive step to the next literal - in if Set.null newStates - then aut - else buildPolAut' fk skeleton (newAut { states = next }) - --- given a previously created state... -buildPolAutHelper :: PolarityKey -> PolTransFn -> PolState -> (PolAut,Set.Set PolState) -> (PolAut,Set.Set PolState) -buildPolAutHelper fk skeleton st (aut,prev) = - let -- reconstruct the skeleton state used to build st - PolSt pr ex (po1:skelpo1) = st - skelSt = PolSt pr ex skelpo1 - -- for each transition out of the current state - -- nb: a transition is (next state, [labels to that state]) - trans = Map.toList $ Map.findWithDefault Map.empty skelSt skeleton - result = foldr addT (aut,prev) trans - -- . for each label to the next state st2 - addT (oldSt2,trs) (a,n) = foldr (addTS oldSt2) (a,n) trs - -- .. calculate a new state and add a transition to it - addTS skel2 tr (a,n) = (addTrans a st tr st2, Set.insert st2 n) - where st2 = newSt tr skel2 - -- - newSt :: Maybe TagElem -> PolState -> PolState - newSt t skel2 = PolSt pr2 ex2 (po2:skelPo2) - where - PolSt pr2 ex2 skelPo2 = skel2 - po2 = po1 !+! Map.findWithDefault (ival 0) fk pol - pol = case t of Nothing -> Map.empty - Just t2 -> tpolarities t2 - in result -\end{code} - -% ---------------------------------------------------------------------- -\subsection{Pruning} -\label{sec:automaton_pruning} -% ---------------------------------------------------------------------- - -Any path through the automaton which does not lead to final -polarity of zero sum can now be eliminated. We do this by stepping -recursively backwards from the final states: - -\begin{code} -prune :: PolAut -> PolAut -prune aut = - let theStates = states aut - final = finalSt aut - -- (remember that states is a list of lists) - lastStates = head theStates - nextStates = tail theStates - nonFinal = (lastStates \\ final) - -- the helper function will rebuild the state list - firstAut = aut { states = [] } - pruned = prune' (nonFinal:nextStates) firstAut - -- re-add the final state! - statesPruned = states pruned - headPruned = head statesPruned - tailPruned = tail statesPruned - in if (null theStates) - then aut - else pruned { states = (headPruned ++ final) : tailPruned } -\end{code} - -The pruning algorithm takes as arguments a list of states to process. -Among these, any state which does not have outgoing transitions is -placed on the blacklist. We remove all transitions to the blacklist and -all states that only transition to the blacklist, and then we repeat -pruning, with a next batch of states. - -Finally, we return the pruned automaton. Note: in order for this to -work, it is essential that the final states are *not* included in the -list of states to process. - -\begin{code} -prune' :: [[PolState]] -> PolAut -> PolAut -prune' [] oldAut = oldAut { states = reverse $ states oldAut } -prune' (sts:next) oldAut = - let -- calculate the blacklist - oldT = transitions oldAut - oldSt = states oldAut - transFrom st = Map.lookup st oldT - blacklist = filter (isNothing.transFrom) sts - -- given a st: filter out all transitions to the blacklist - allTrans = Map.toList $ transitions oldAut - -- delete all transitions to the blacklist - miniTrim = Map.filterWithKey (\k _ -> not (k `elem` blacklist)) - -- extra cleanup: delete from map states that only transition to the blacklist - trim = Map.filterWithKey (\k m -> not (k `elem` blacklist || Map.null m)) - -- execute the kill and miniKill filters - newT = trim $ Map.fromList [ (st2, miniTrim m) | (st2,m) <- allTrans ] - -- new list of states and new automaton - newSts = sts \\ blacklist - newAut = oldAut { transitions = newT, - states = newSts : oldSt } - {- - -- debugging code - debugstr = "blacklist: [\n" ++ debugstr' ++ "]" - debugstr' = concat $ intersperse "\n" $ map showSt blacklist - showSt (PolSt pr ex po) = showPr pr ++ showEx ex ++ showPo po - showPr (_,pr,_) = pr ++ " " - showPo po = concat $ intersperse "," $ map show po - showEx ex = if (null ex) then "" else (showSem ex) - -} - -- recursive step - in if null blacklist - then oldAut { states = (reverse oldSt) ++ (sts:next) } - else prune' next newAut -\end{code} - -% ==================================================================== -\section{Zero-literal semantics} -\label{sec:multiuse} -\label{semantic_weights} -\label{sec:nullsem} -\label{sec:co-anchors} -% ==================================================================== - -Lexical items with a \jargon{null semantics} typically correspond to -functions words: complementisers \natlang{(John likes \textbf{to} -read.)}, subcategorised prepositions \natlang{(Mary accuses John -\textbf{of} cheating.)}. Such items need not be lexical items at all. -We can exploit TAG's support for trees with multiple anchors, by -treating them as co-anchors to some primary lexical item. The English -infinitival \natlang{to}, for example, can appear in the tree -\tautree{to~take} as \koweytree{s(comp(to),v(take),np$\downarrow$)}. - -On the other hand, pronouns have a \jargon{zero-literal} semantics, one -which is not null, but which consists only of a variable index. For -example, the pronoun \natlang{she} in (\ref{ex:pronoun_pol_she}) has -semantics \semexpr{s} and in (\ref{ex:pronoun_pol_control}), -\natlang{he} has the semantics \semexpr{j}. - -{\footnotesize -\eenumsentence{\label{ex:pronoun_pol} -\item \label{ex:pronoun_pol_sue} -\semexpr{joe(j), sue(s), book(b), lend(l,j,b,s), boring(b) } -\\ \natlang{Joe lends Sue a boring book.} - -% Note for visually impaired readers: ignore anything with \color{white}. -% It is used as a form of indentation to help sighted users. -\item \label{ex:pronoun_pol_she} -\semexpr{joe(j), {\color{white}sue(s),} book(b), lend(l,j,b,s), boring(b) } -\\ \natlang{Joe lends her a boring book.} -} -\eenumsentence{\label{ex:pronoun_pol_control} -\item[{\color{white}a.}] \label{ex:pronoun_pol_control_inf} -\semexpr{joe(j), sue(s), leave(l,j), promise(p,j,s,l)} -\\ \natlang{Joe promises Sue to leave.} -\\ or \natlang{Joe promises Sue that he would leave.} -}} - -In figure \ref{fig:polarity_automaton_zerolit_bad}, we compare the -construction of polarity automata for (\ref{ex:pronoun_pol_sue}, left) -and (\ref{ex:pronoun_pol_she}, right). Building an automaton for -(\ref{ex:pronoun_pol_she}) fails because \tautree{sue} is not available -to cancel the negative polarities for \tautree{lends}; instead, a -pronoun must be used to take its place. The problem is that the -selection of a lexical items is only triggered when the construction -algorithm visits one of its semantic literals. Since pronoun semantics -have zero literals, they are \emph{never} selected. Making pronouns -visible to the construction algorithm would require us to count the -indices from the input semantics. Each index refers to an entity. This -entity must be ``consumed'' by a syntactic functor (e.g. a verb) and -``provided'' by a syntactic argument (e.g. a noun). - -%\footnote{This also holds true for sentences like \natlang{Joe sings -%badly and Sue sings well}, \semexpr{sing(s1,j) good(s1), sing(s2,m), -%bad(s2)} because each usage of \natlang{sings} actually corresponds to a -%different lexical item, \tautree{sings1} with the semantics -%\semexpr{sings(s1,j)} and \tautree{sings2} with \semexpr{sings(s2,m)}.}. - -\begin{figure}[htpb] -\begin{center} -\includegraphics[scale=0.25]{images/zeroaut-noun.pdf} -\includegraphics[scale=0.25]{images/zeroaut-sans.pdf} -\end{center} -\vspace{-0.4cm} -\caption{Difficulty with zero-literal semantics.} -\label{fig:polarity_automaton_zerolit_bad} -\end{figure} - -We make this explicit by annotating the semantics of the lexical input -(that is the set of lexical items selected on the basis of the input -semantics) with a form of polarities. Roughly, nouns provide -indices\footnote{except for predicative nouns, which like verbs, are -semantic functors} ($+$), modifiers leave them unaffected, and verbs -consume them ($-$). Predicting pronouns is then a matter of counting -the indices. If the positive and negative indices cancel each other -out, no pronouns are required. If there are more negative indices than -positive ones, then as many pronouns are required as there are negative -excess indices. In the table below, we show how the example semantics -above may be annotated and how many negative excess indices result: - -\begin{center} -{\footnotesize -\begin{tabular}{|l|r|r|r|} -\hline -\multicolumn{1}{|c|}{\bf semantics} & -{\bf \tt b} & -{\bf \tt j} & -{\bf \tt s} \\ -\hline -\semexpr{joe(+j) sue(+s) book(+b) lend(l,-j,-b,-s) boring(b)} & -\semexpr{0} & -\semexpr{0} & -\semexpr{0} \\ -\hline -\semexpr{joe(+j) {\color{white}sue(+s)} book(+b) lend(l,-j,-b,-s) boring(b)} & -\semexpr{0} & -\semexpr{0} & -\semexpr{1} \\ -\hline -\semexpr{joe(+j) sue(+s) leave(l,-j,-s) promise(p,{\color{white}-}j,-s,l)} & -\semexpr{0} & -\semexpr{0} & -\semexpr{0} \\ -\hline -\semexpr{joe(+j) sue(+s) leave(l,-j,-s) promise(p,-j,-s,l)} & -\semexpr{0} & -\semexpr{1} & -\semexpr{0} \\ -\hline -\end{tabular} -} -\end{center} - -Counting surplus indices allows us to establish the number of pronouns -used and thus gives us the information needed to build polarity -automata. We implement this by introducing a virtual literal for -negative excess index, and having that literal be realised by pronouns. -Building the polarity automaton as normal yields lexical combinations -with the required number of pronouns, as in figure -\ref{fig:polarity_automaton_zerolit}. - -\begin{figure}[htpb] -\begin{center} -\includegraphics[scale=0.25]{images/zeroaut-pron.pdf} -\end{center} -\vspace{-0.4cm} -\caption{Constructing a polarity automaton with zero-literal semantics.} -\label{fig:polarity_automaton_zerolit} -\end{figure} - -\label{different_sem_annotations} -The sitation is more complicated where the lexical input -contains lexical items with different annotations for the same -semantics. For instance, the control verb \natlang{promise} has two -forms: one which solicits an infinitive as in \natlang{promise to -leave}, and one which solicits a declarative clause as in -\natlang{promise that he would leave}. This means two different counts -of subject index \semexpr{j} in (\ref{ex:pronoun_pol_control}) : zero -for the form that subcategorises for the infinitive, or one for the -declarative. But to build a single automaton, these counts must be -reconciled, i.e., how many virtual literals do we introduce for -\semexpr{j}, zero or one? The answer is to introduce enough virtual -literals to satisfy the largest demand, and then use the multi-literal -extension to support alternate forms with a smaller demand. To handle -example (\ref{ex:pronoun_pol_control}), we introduce one virtual literal -for \semexpr{j} so that the declarative form can be produced, and treat -the soliciting \natlang{promise} as though its semantics includes that -literal along with its regular semantics (figure -\ref{fig:polarity_automaton_zerolit_promise}). In other words, the -infinitive-soliciting form is treated as if it already fulfils the role -of a pronoun, and does not need one in its lexical combination. - -\begin{figure}[htpb] -\begin{center} -\includegraphics[scale=0.25]{images/zeroaut-promise.pdf} -\end{center} -\vspace{-0.4cm} -\caption{Constructing a polarity automaton with zero-literal semantics.} -\label{fig:polarity_automaton_zerolit_promise} -\end{figure} - -We insert pronouns into the input semantics using the following process: -\begin{enumerate} -\item For each literal in the input semantics, establish the - smallest charge for each of its semantic indices. -\item Cancel out the polarities for every index in the input - semantics. -\item Compensate for any uncancelled negative polarities by an - adding an additional literal to the input semantics -- a pronoun -- - for every negative charge. -\item Finally, deal with the problem of lexical items who require fewer - pronouns than predicted by inserting the excess pronouns in their extra - literal semantics (see page \pageref{different_sem_annotations}) -\end{enumerate} - -\begin{code} -type PredLite = (String,[GeniVal]) -- handle is head of arg list -type SemWeightMap = Map.Map PredLite SemPols - --- | Returns a modified input semantics and lexical selection in which pronouns --- are properly accounted for. -fixPronouns :: (Sem,[TagElem]) -> (Sem,[TagElem]) -fixPronouns (tsem,cands) = - let -- part 1 (for each literal get smallest charge for each idx) - getpols :: TagElem -> [ (PredLite,SemPols) ] - getpols x = zip [ (show p, h:as) | (h,p,as) <- tsemantics x ] (tsempols x) - sempols :: [ (PredLite,SemPols) ] - sempols = concatMap getpols cands - usagemap :: SemWeightMap - usagemap = Map.fromListWith (zipWith min) sempols - -- part 2 (cancel sem polarities) - chargemap :: Map.Map GeniVal Int -- index to charge - chargemap = Map.fromListWith (+) $ concatMap clump $ Map.toList usagemap - where clump ((_,is),ps) = zip is ps - -- part 3 (adding extra semantics) - indices = concatMap fn (Map.toList chargemap) - where fn (i,c) = replicate (negate c) i - -- the extra columns - extraSem = map indexPred indices - tsem2 = sortSem (tsem ++ extraSem) - -- zero-literal semantic items to realise the extra columns - zlit = filter (null.tsemantics) cands - cands2 = (cands \\ zlit) ++ concatMap fn indices - where fn i = map (tweak i) zlit - tweak i x = assignIndex i $ x { tsemantics = [indexPred i] } - -- part 4 (insert excess pronouns in tree sem) - comparefn :: GeniVal -> Int -> Int -> [GeniVal] - comparefn i ct cm = if cm < ct then extra else [] - where maxNeeded = Map.findWithDefault 0 i chargemap -- cap the number added - extra = replicate (min (negate maxNeeded) (ct - cm)) i - comparePron :: (PredLite,SemPols) -> [GeniVal] - comparePron (lit,c1) = concat $ zipWith3 comparefn idxs c1 c2 - where idxs = snd lit - c2 = Map.findWithDefault [] lit usagemap - addextra :: TagElem -> TagElem - addextra c = c { tsemantics = sortSem (sem ++ extra) } - where sem = tsemantics c - extra = map indexPred $ concatMap comparePron (getpols c) - cands3 = map addextra cands2 - in (tsem2, cands3) - --- | Builds a fake semantic predicate that the index counting mechanism uses to --- represent extra columns. -indexPred :: GeniVal -> Pred -indexPred x = (x, GAnon, []) - --- Returns True if the given literal was introduced by the index counting mechanism -isExtraCol :: Pred -> Bool -isExtraCol (_,GAnon,[]) = True -isExtraCol _ = False -\end{code} - -\paragraph{assignIndex} is a useful way to restrict the behaviour of -null semantic items like pronouns using the information generated by -the index counting mechanism. The problem with null semantic items -is that their indices are not set, which means that they could -potentially combine with any other tree. To make things more -efficient, we can set the index of these items and thus reduce the -number of spurious combinations. - -Notes -\begin{itemize} -%\item These combinations could produce false results if the -%input has to use multiple pronouns. For example, if you wanted to say -%something like \natlang{John promises Mary to convince Paul to give her -% his book}, these combinations could instead produce \natlang{give him -% \textbf{her} book}. -\item This function works by FS unification on the root node of the - tree with the \fs{\it idx:i\\}. If unification is not possible, - we simply return the tree as is. -\item This function renames the tree by appending the index to its name -\end{itemize} - -\begin{code} -assignIndex :: GeniVal -> TagElem -> TagElem -assignIndex i te = - let idxfs = [ AvPair __idx__ i ] - oldt = ttree te - oldr = root oldt - tfup = gup oldr - -- - in case unifyFeat tfup idxfs of - Nothing -> te - Just (gup2, sub) -> replace sub $ te { ttree = newt } - where newt = rootUpd oldt $ oldr { gup = gup2 } -\end{code} - - -% ==================================================================== -\section{Further optimisations} -% ==================================================================== - -\subsection{Lexical filtering} \label{fn:detectIdxConstraints} - -Lexical filtering allows the user to constrain the lexical selection -to only those items that contain a certain property, for example, the -realising an item as a cleft. - -The idea is that the user provides an input like -\verb$idxconstraints:[cleft:j]$, -which means that the lexical selection must include exactly one tree -with the property cleft:j in its interface. This mechanism works as -pre-processing step after lexical selection and before polarity -automaton construction, in conjuction with the ExtraPolarities -mechanism. What we do is - -\begin{enumerate} -\item Preprocess the lexically selected trees; any tree which has a - a desired property (e.g. cleft:j) in its interface is assigned - a positive polarity for that property (+cleft:j) -\item Add all the index constraints as negative extra polarities (-cleft:j) -\end{enumerate} - -Note: we assume the index constraints and interface are sorted; also, we -prefix the index constraint polarities with a ``.'' because they are likely to -be very powerful filters and we would like them to be used first. - -\begin{code} -detectIdxConstraints :: Flist -> Flist -> PolMap -detectIdxConstraints cs interface = - let matches = intersect cs interface - matchStr = map idxConstraintKey matches - in Map.fromList $ zip matchStr ((repeat.ival) 1) - -declareIdxConstraints :: Flist -> PolMap -declareIdxConstraints = Map.fromList . (map declare) where - declare c = (idxConstraintKey c, minusone) - minusone = ival (-1) - -idxConstraintKey :: AvPair -> PolarityKey -idxConstraintKey = PolarityKey . ('.' :) . showAv -\end{code} - -\subsection{Automatic detection} - -Automatic detection is not an optimisation in itself, but a means to -make grammar development with polarities more convenient. - -\paragraph{Which attributes should we use?} Our detection process looks for -attributes which are defined on \emph{all} subst and root nodes of the -lexically selected items. Note that this should typically give you the -\verb!cat! and \verb!idx! polarities. - -\begin{code} -detectPolFeatures :: [TagElem] -> [String] -detectPolFeatures tes = - let -- only initial trees need be counted; in aux trees, the - -- root node is implicitly canceled by the foot node - rfeats, sfeats :: [Flist] - rfeats = map (gdown.root.ttree) $ filter (\t -> ttype t == Initial) tes - sfeats = [ concat s | s <- map substTops tes, (not.null) s ] - -- - attrs :: Flist -> [String] - attrs avs = [ a | AvPair a v <- avs, isConst v ] - theAttributes = map attrs $ rfeats ++ sfeats - in if null tes then [] else foldr1 intersect theAttributes - --- FIXME: temporary HACKY code - delete me as soon as possible (written --- 2006-03-30 --- --- only initial trees need be counted; in aux trees, the --- root node is implicitly canceled by the foot node -detectSansIdx :: [TagElem] -> [TagElem] -detectSansIdx = - let rfeats t = (gdown.root.ttree) t - feats t | ttype t == Initial = concat $ rfeats t : substTops t - feats t = concat $ substTops t - attrs avs = [ a | AvPair a v <- avs, isConst v ] - hasIdx t = __idx__ `elem` (attrs.feats $ t) || (ttype t /= Initial && (null $ substTops t)) - in filter (not.hasIdx) -\end{code} - -\paragraph{The polarity values} -First the simplified explanation: we assign every tree with a $-1$ charge for -every category for every substitution node it has. Additionally, we assign -every initial tree with a $+1$ charge for the category of its root node. So -for example, the tree s(n$\downarrow$, cl$\downarrow$, v(aime), n$\downarrow$) -should have the following polarities: s +1, cl -1, n -2. These charges are -added to any that previously been defined in the grammar. - -Now what really happens: we treat automaton polarities as intervals, not -as single integers! For the most part, nothing changes from the simplified -explanation. Where we added a $-1$ charge before, we now add a $(-1,-1)$ -charge. Similarly, we where added a $+1$ charge, we now add $(1,1)$. So -what's the point of all this? It helps us deal with atomic disjunction. - -\subparagraph{Atomic disjunction} Say we encounter a substitution node -whose category is either cl or n. What we do is add the polarities -$cl (-1,0), n (-1,0)$ which means that there are anywhere from -1 to -0 cl, and for n. -FIXME: What kind of sucks about all this though is that this slightly worsens -the filter because it allows for both cl and n to be $-1$ (or $0$) at the same -time. It would be nice to have some kind of mutual exclusion working. - -\begin{code} -detectPols :: Set.Set PolarityAttr -> [TagElem] -> [TagElem] -detectPols attrs = map (detectPolsH attrs) - -detectPolsH :: Set.Set PolarityAttr -> TagElem -> TagElem -detectPolsH polarityAttrs te = - let detectOrBust x1 x2 x3 x4 = - case detectPolarity x1 x2 x3 x4 of - PD_UserError e -> error $ e ++ " in " ++ tgIdName te -- ideally we'd propagate this - PD_Nothing -> [] - PD_Just p -> p - -- - rup = gup . root .ttree $ te - rdown = gdown . root . ttree $ te - -- - catAttr = SimplePolarityAttr "cat" - rstuffLite = concatMap (\v -> detectOrBust 1 v rup rdown) - $ Set.toList $ Set.delete catAttr polarityAttrs - rstuff :: [(PolarityKey,Interval)] - rstuff = if Set.member catAttr polarityAttrs - then -- cat is considered global to the whole tree to be - -- robust, we grab it from the top feature - detectOrBust 1 catAttr rup rup ++ rstuffLite - else rstuffLite - substuff :: [(PolarityKey,Interval)] - substuff = let tops = substTops te - detect :: PolarityAttr -> [(PolarityKey,Interval)] - detect v = concat $ zipWith (detectOrBust (-1) v) tops tops - in concatMap detect $ Set.toList polarityAttrs - -- substs and roots - pols = case ttype te of - Initial -> substuff ++ rstuff - _ -> substuff - -- - oldfm = tpolarities te - in te { tpolarities = foldr addPol oldfm pols } - -__cat__, __idx__ :: String -__cat__ = "cat" -__idx__ = "idx" - - -data PolarityDetectionResult = PD_UserError String - | PD_Nothing - | PD_Just [ (PolarityKey, Interval) ] - --- | Careful, this completely ignores any user errors -pdJusts :: [PolarityDetectionResult] -> [(PolarityKey,Interval)] -pdJusts = concatMap helper - where helper (PD_Just x) = x - helper _ = [] - -detectPolarity :: Int -- ^ polarity to assign - -> PolarityAttr -- ^ attribute to look for - -> Flist -- ^ feature structure to filter on - -> Flist -- ^ feature structure to get value from - -> PolarityDetectionResult -detectPolarity i (RestrictedPolarityAttr cat att) filterFl fl = - case [ v | AvPair a v <- filterFl, a == __cat__ ] of - [] -> PD_UserError $ "[polarities] No category " ++ cat ++ " in:" ++ showFlist filterFl - [v] -> if isJust (unify [GConst [cat]] [v]) - then detectPolarityForAttr i att fl - else PD_Nothing - _ -> PD_UserError $ "[polarities] More than one category " ++ " in:" ++ showFlist filterFl -detectPolarity i (SimplePolarityAttr att) _ fl = detectPolarityForAttr i att fl - -detectPolarityForAttr :: Int -- ^ polarity to assign - -> String - -> Flist - -> PolarityDetectionResult -detectPolarityForAttr i att fl = - case [ v | AvPair a v <- fl, a == att ] of - [] -> PD_UserError $ "[polarities] No value for attribute: " ++ att ++ " in:" ++ showFlist fl - [v] -> if isConst v - then PD_Just $ case prefixWith att (fromGConst v) of - [x] -> [ (PolarityKey x, ival i) ] -- singleton - xs -> map (\x -> (PolarityKey x, toZero i)) xs -- interval if ambiguous - else PD_UserError $ "[polarities] Non-constant value for attribute: " ++ att ++ " in:" ++ showFlist fl - _ -> PD_UserError $ "[polarities] More than one value for attribute: " ++ att ++ " in:" ++ showFlist fl - -toZero :: Int -> Interval -toZero x | x < 0 = (x, 0) - | otherwise = (0, x) - -prefixWith :: String -> [String] -> [String] -prefixWith att = map (\x -> att ++ ('_' : x)) - -substNodes :: TagElem -> [GNode] -substNodes t = [ gn | gn <- (flatten.ttree) t, gtype gn == Subs ] - -substTops :: TagElem -> [Flist] -substTops = map gup . substNodes -\end{code} - -\subsection{Chart sharing} - -Chart sharing is based on the idea that instead of performing a -seperate generation task for each automaton path, we should do -single generation task, but annotate each tree with set of the -automata paths it appears on. We then allow trees on the -same paths to be compared only if they are on the same path. -Note: chart sharing involves some mucking around with the generation -engine (see page \pageref{fn:Builder:preInit}) - -\begin{code} --- | Given a list of paths (i.e. a list of list of trees) --- return a list of trees such that each tree is annotated with the paths it --- belongs to. -detectPolPaths :: [[TagElem]] -> [(TagElem,BitVector)] -detectPolPaths paths = - let pathFM = detectPolPaths' Map.empty 0 paths - lookupTr k = Map.findWithDefault 0 k pathFM - in map (\k -> (k, lookupTr k)) $ Map.keys pathFM - -type PolPathMap = Map.Map TagElem BitVector -detectPolPaths' :: PolPathMap -> Int -> [[TagElem]] -> PolPathMap - -detectPolPaths' accFM _ [] = accFM -detectPolPaths' accFM counter (path:ps) = - let currentBits = shiftL 1 counter -- shift counter times the 1 bit - fn f [] = f - fn f (t:ts) = fn (Map.insertWith (.|.) t currentBits f) ts - newFM = fn accFM path - in detectPolPaths' newFM (counter+1) ps - --- | Render the list of polarity automaton paths as a string -showPolPaths :: BitVector -> String -showPolPaths paths = - let pathlist = showPolPaths' paths 1 - in concat $ intersperse ", " $ map show pathlist - -showPolPaths' :: BitVector -> Int -> [Int] -showPolPaths' 0 _ = [] -showPolPaths' bv counter = - if b then (counter:next) else next - where b = testBit bv 0 - next = showPolPaths' (shiftR bv 1) (counter + 1) -\end{code} - -\subsection{Semantic sorting} - -To minimise the number of states in the polarity automaton, we could -also sort the literals in the target semantics by the number of -corresponding lexically selected items. The idea is to delay branching -as much as possible so as to mimimise the number of states in the -automaton. - -Let's take a hypothetical example with two semantic literals: -bar (having two trees with polarties 0 and +1). -foo (having one tree with polarity -1) and -If we arbitrarily explored bar before foo (no semantic sorting), the -resulting automaton could look like this: - -\begin{verbatim} - bar foo -(0)--+---(0)------(-1) - | - +---(1)------(0) -\end{verbatim} - -With semantic sorting, we would explore foo before bar because foo has -fewer items and is less likely to branch. The resulting automaton -would have fewer states. - -\begin{verbatim} - foo bar -(0)-----(-1)--+---(-1) - | - +---(0) -\end{verbatim} - -The hope is that this would make the polarity automata a bit -faster to build, especially considering that we are working over -multiple polarity keys. - -Note: we have to take care to count each literal for each lexical -entry's semantics or else the multi-literal semantic code will choke. - -\begin{code} -sortSemByFreq :: Sem -> [TagElem] -> Sem -sortSemByFreq tsem cands = - let counts = map lenfn tsem - lenfn l = length $ filter fn cands - where fn x = l `elem` (tsemantics x) - -- note: we introduce an extra hack to push - -- index-counted extra columns to the end; just for UI reasons - sortfn a b - | isX a && isX b = compare (snd a) (snd b) - | isX a = GT - | isX b = LT - | otherwise = compare (snd a) (snd b) - where isX = isExtraCol.fst - sorted = sortBy sortfn $ zip tsem counts - in (fst.unzip) sorted -\end{code} - -% ---------------------------------------------------------------------- -\section{Types} -% ---------------------------------------------------------------------- - -\begin{code} -type SemMap = Map.Map Pred [TagElem] -type PolMap = Map.Map PolarityKey Interval - --- | Adds a new polarity item to a 'PolMap'. If there already is a polarity --- for that item, it is summed with the new polarity. -addPol :: (PolarityKey,Interval) -> PolMap -> PolMap -addPol (p,c) m = Map.insertWith (!+!) p c m - --- | Ensures that all states and transitions in the polarity automaton --- are unique. This is a slight optimisation so that we don't have to --- repeatedly check the automaton for state uniqueness during its --- construction, but it is essential that this check be done after --- construction -nubAut :: (Ord ab, Ord st) => NFA st ab -> NFA st ab -nubAut aut = - aut { - transitions = Map.map (\e -> Map.map nub e) (transitions aut) - } -\end{code} - -\subsection{Polarity NFA} - -We can define the polarity automaton as a NFA, or a five-tuple -$(Q, \Sigma, \delta, q_0, q_n)$ such that - -\begin{enumerate} -\item $Q$ is a set of states, each state being a tuple $(i,e,p)$ where $i$ -is an integer (representing a single literal in the target semantics), -$e$ is a list of extra literals -which are known by the state, and $p$ is a polarity. -\item $\Sigma$ is the union of the sets of candidate trees for all -propositions -\item $q_0$ is the start state $(0,[0,0])$ which does not correspond to any -propositions and is used strictly as a starting point. -\item $q_n$ is the final state $(n,[x,y])$ which corresponds to the last -proposition, with polarity $x \leq 0 \leq y$. -\item $\delta$ is the transition function between states, which we -define below. -\end{enumerate} - -Note: -\begin{itemize} -\item For convenience during automaton intersection, we actually define - the states as being $(i, [(p_x,p_y)])$ where $[(p_x,p_y)]$ is a list of - polarity intervals. -\item We use integer $i$ for each state instead of literals directly, - because it is possible for the target semantics to contain the - same literal twice (at least, with the index counting mechanism - in place) -\end{itemize} - -\begin{code} -data PolState = PolSt Int [Pred] [(Int,Int)] - -- ^ position in the input semantics, extra semantics, - -- polarity interval - deriving (Eq) -type PolTrans = TagElem -type PolAut = NFA PolState PolTrans -type PolTransFn = Map.Map PolState (Map.Map PolState [Maybe PolTrans]) - -instance Show PolState - where show (PolSt pr ex po) = show pr ++ " " ++ showSem ex ++ show po --- showPred pr ++ " " ++ showSem ex ++ show po - -instance Ord PolState where - compare (PolSt pr1 ex1 po1) (PolSt pr2 ex2 po2) = - let prC = compare pr1 pr2 - expoC = compare (ex1,po1) (ex2,po2) - in if (prC == EQ) then expoC else prC -\end{code} - -We include also some fake states which are useful for general -housekeeping during the main algortihms. - -\begin{code} -fakestate :: Int -> [Interval] -> PolState -fakestate s pol = PolSt s [] pol --PolSt (0, s, [""]) [] pol - --- | an initial state for polarity automata -polstart :: [Interval] -> PolState -polstart pol = fakestate 0 pol -- fakestate "START" pol -\end{code} - -% ---------------------------------------------------------------------- -\section{Display code} -\label{sec:display_pol} -% ---------------------------------------------------------------------- - -\begin{code} --- | 'showLite' is like Show but it's only used for debugging --- TODO: is this true? -class ShowLite a where - showLite :: a -> String - -instance (ShowLite a) => ShowLite [a] where - showLite x = "[" ++ (concat $ intersperse ", " $ map showLite x) ++ "]" -instance (ShowLite a, ShowLite b) => ShowLite (a,b) where - showLite (x,y) = "(" ++ (showLite x) ++ "," ++ (showLite y) ++ ")" - -instance ShowLite Int where showLite = show -instance ShowLite Char where showLite = show -\end{code} - -%\begin{code} -%instance (Show st, ShowLite ab) => ShowLite (NFA st ab) where -% showLite aut = -% concatMap showTrans $ toList (transitions aut) -% where showTrans ((st1, x), st2) = show st1 ++ showArrow x -% ++ show st2 ++ "\n" -% showArrow x = " --" ++ showLite x ++ "--> " -% -- showSt (PolSt pr po) = show po -%\end{code} - -\begin{code} -instance ShowLite TagElem where - showLite = idname - -{- --- | Display a SemMap in human readable text. -showLiteSm :: SemMap -> String -showLiteSm sm = - concatMap showPair $ toList sm - where showPair (pr, cs) = showPred pr ++ "\t: " ++ showPair' cs ++ "\n" - showPair' [] = "" - showPair' (te:cs) = tlIdname te ++ "[" ++ showLitePm (tpolarities te) ++ "]" - ++ " " ++ showPair' cs --} - --- | Display a PolMap in human-friendly text. --- The advantage is that it displays fewer quotation marks. -showLitePm :: PolMap -> String -showLitePm pm = - let showPair (f, pol) = showInterval pol ++ fromPolarityKey f - in concat $ intersperse " " $ map showPair $ Map.toList pm -\end{code} diff --git a/src/NLP/GenI/Polarity/Internal.hs b/src/NLP/GenI/Polarity/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Polarity/Internal.hs @@ -0,0 +1,190 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Polarity.Internal where + +import Control.Applicative +import Data.List +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Tree (flatten) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T + +import Data.FullList hiding ( (++) ) +import NLP.GenI.Automaton +import NLP.GenI.FeatureStructure +import NLP.GenI.General +import NLP.GenI.GeniVal +import NLP.GenI.Polarity.Types +import NLP.GenI.Pretty +import NLP.GenI.Semantics (Literal) +import NLP.GenI.Tag ( TagElem(..), TagItem(..) ) +import NLP.GenI.TreeSchema + ( Ptype(Initial) + , GNode, root, gup, gdown, gtype, GType(Subs), + ) + +data PolarityDetectionResult = PD_UserError String + | PD_Nothing + | PD_Just [ (PolarityKey, Interval) ] + | PD_Unconstrained (Text, Interval) + +-- ---------------------------------------------------------------------- +-- polarity detection +-- ---------------------------------------------------------------------- + +-- | Given a description of what the root feature should unify with +-- return a -1 polarity for all relevant polarity keys. This allows +-- us to compensate for the root node of any derived tree. +detectRootCompensation :: Set.Set PolarityAttr -> FeatStruct GeniVal -> PolMap +detectRootCompensation polarityAttrs rootFeat = + Map.fromListWith (!+!) . pdResults + $ map (\v -> detectPolarity (-1) (SimplePolarityAttr (pAttr v)) emptyFeatStruct rootFeat) + $ Set.toList polarityAttrs + where + pAttr p@(SimplePolarityAttr _) = spkAtt p + pAttr p@(RestrictedPolarityAttr _ _) = rpkAtt p + +detectPolsH :: Set.Set PolarityAttr -> TagElem -> [(PolarityKey,Interval)] +detectPolsH polarityAttrs te = + case ttype te of + Initial -> substuff ++ rstuff + _ -> substuff + where + pdError e = e ++ " in " ++ T.unpack (tgIdName te) -- ideally we'd propagate this + detectOrBust x1 x2 x3 x4 = pdToList pdError (detectPolarity x1 x2 x3 x4) + -- + rup = mkFeatStruct . gup . root .ttree $ te + rdown = mkFeatStruct . gdown . root . ttree $ te + -- + catAttr = SimplePolarityAttr "cat" + rstuffLite = concatMap (\v -> detectOrBust 1 v rup rdown) + $ Set.toList $ Set.delete catAttr polarityAttrs + rstuff = if Set.member catAttr polarityAttrs + then -- cat is considered global to the whole tree, + -- but to be robust, we grab it from the top feature + detectOrBust 1 catAttr rup rup ++ rstuffLite + else rstuffLite + substuff = let tops = map mkFeatStruct (substTops te) + detect :: PolarityAttr -> [(PolarityKey,Interval)] + detect v = concat $ zipWith (detectOrBust (-1) v) tops tops + in concatMap detect $ Set.toList polarityAttrs + +detectPolarity :: Int -- ^ polarity to assign + -> PolarityAttr -- ^ attribute to look for + -> FeatStruct GeniVal -- ^ feature structure to filter on ('RestrictedPolarityAttr' only) + -> FeatStruct GeniVal -- ^ feature structure to get value from + -> PolarityDetectionResult +detectPolarity i (RestrictedPolarityAttr cat att) filterFl fl = + case Map.lookup __cat__ filterFl of + Nothing -> PD_UserError . T.unpack $ "[polarities] No category " + `T.append` cat + `T.append` " in:" + `T.append` pretty filterFl + Just v -> if isJust (unify [mkGConstNone cat] [v]) + then detectPolarity i (SimplePolarityAttr att) emptyFeatStruct fl + else PD_Nothing +detectPolarity i (SimplePolarityAttr att) _ fl = + case Map.lookup att fl of + Nothing -> PD_Unconstrained (withZero att) + Just v -> case fromFL <$> gConstraints v of + Just [x] -> PD_Just [ (PolarityKeyAv att x, ival i) ] -- singleton + Just xs -> PD_Just $ map (withZero . PolarityKeyAv att) xs -- interval if ambiguous + Nothing -> PD_Unconstrained (withZero att) + where + withZero x = (x, toZero i) + +toZero :: Int -> Interval +toZero x | x < 0 = (x, 0) + | otherwise = (0, x) + +substNodes :: TagElem -> [GNode GeniVal] +substNodes t = [ gn | gn <- (flatten.ttree) t, gtype gn == Subs ] + +substTops :: TagElem -> [Flist GeniVal] +substTops = map gup . substNodes + +type SemMap = Map.Map (Literal GeniVal) [TagElem] +type PolMap = Map.Map PolarityKey Interval + +-- ---------------------------------------------------------------------- +-- after polarity detection +-- ---------------------------------------------------------------------- + +polarityKeys :: [TagElem] -> PolMap -> [PolarityKey] +polarityKeys cands extraPol = + sortBy (flip compare) $ nub $ ksCands ++ ksExtra + where + ksCands = concatMap (Map.keys . tpolarities) cands + ksExtra = Map.keys extraPol + +-- | Convert any unconstrained polarities in a 'PolMap' to constrained +-- ones, assuming a global list of known constrained keys. +convertUnconstrainedPolarities :: [PolarityKey] -> PolMap -> PolMap +convertUnconstrainedPolarities ks pmap = + addPols expansions con + where + (con, uncon) = Map.partitionWithKey constrained pmap + constrained (PolarityKeyVar _) _ = False + constrained _ _ = True + -- + expansions = [ (k,v) | (PolarityKeyVar a, v) <- Map.toList uncon + , k@(PolarityKeyAv a2 _) <- ks + , a == a2 + ] + +-- ---------------------------------------------------------------------- +-- helpers +-- ---------------------------------------------------------------------- + +-- duplicates are a matter of course +addPols :: [(PolarityKey,Interval)] -> PolMap -> PolMap +addPols pols m = foldr f m pols + where + f (p,c) = Map.insertWith (!+!) p c + +-- | Ensures that all states and transitions in the polarity automaton +-- are unique. This is a slight optimisation so that we don't have to +-- repeatedly check the automaton for state uniqueness during its +-- construction, but it is essential that this check be done after +-- construction +nubAut :: (Ord ab, Ord st) => NFA st ab -> NFA st ab +nubAut aut = + aut { + transitions = Map.map (\e -> Map.map nub e) (transitions aut) + } + +__cat__, __idx__ :: Text +__cat__ = "cat" +__idx__ = "idx" + + +-- | Note that this will crash if any of the entries are errors +pdResults :: [PolarityDetectionResult] -> [(PolarityKey, Interval)] +pdResults = concatMap (pdToList id) + +-- | Note that this will crash if any of the entries are errors +pdToList :: (String -> String) -- ^ on error message + -> PolarityDetectionResult + -> [(PolarityKey,Interval)] +pdToList _ (PD_Just x) = x +pdToList f (PD_UserError e) = error (f e) +pdToList _ (PD_Unconstrained (k,i)) = [ (PolarityKeyVar k, i) ] +pdToList _ PD_Nothing = [] diff --git a/src/NLP/GenI/Polarity/Types.hs b/src/NLP/GenI/Polarity/Types.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Polarity/Types.hs @@ -0,0 +1,84 @@ +-- GenI surface realiser +-- Copyright (C) 2009 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module NLP.GenI.Polarity.Types where + +import qualified Data.Set as Set +import Data.Generics ( Data ) +import Data.Typeable ( Typeable ) +import Data.Text ( Text ) +import qualified Data.Text as T + +import Control.DeepSeq + +import NLP.GenI.Pretty + +data PolarityKey = PolarityKeyAv Text Text + | PolarityKeyStr Text + | PolarityKeyVar Text -- ^ attribute + deriving (Eq, Ord, Data, Typeable) + +instance Pretty PolarityKey where + pretty (PolarityKeyAv a v) = a <> ":" <> v + pretty (PolarityKeyStr s) = s + pretty (PolarityKeyVar a) = a <> ":_" + +type SemPols = [Int] + +-- | 'PolarityAttr' is something you want to perform detect polarities on. +data PolarityAttr = SimplePolarityAttr { spkAtt :: Text } + -- | 'RestrictedPolarityKey' @c att@ is a polarity key in which we only pay + -- attention to nodes that have the category @c@. This makes it possible + -- to have polarities for a just a small subset of nodes + | RestrictedPolarityAttr { _rpkCat :: Text, rpkAtt :: Text } + deriving (Eq, Ord, Typeable) + +readPolarityAttrs :: String -> Set.Set PolarityAttr +readPolarityAttrs = Set.fromList . map helper . words + where + helper s = case break (== '.') s of + (a,"") -> SimplePolarityAttr (T.pack a) + (c,a) -> RestrictedPolarityAttr (T.pack c) (T.pack (drop 1 a)) + +showPolarityAttrs :: Set.Set PolarityAttr -> String +showPolarityAttrs = unwords . map show . Set.toList + +instance Show PolarityAttr where + show (SimplePolarityAttr a) = T.unpack a + show (RestrictedPolarityAttr c a) = T.unpack c ++ "." ++ T.unpack a + +{-! +deriving instance NFData PolarityKey +deriving instance NFData PolarityAttr +!-} +-- GENERATED START + + +instance NFData PolarityKey where + rnf (PolarityKeyAv x1 x2) = rnf x1 `seq` rnf x2 `seq` () + rnf (PolarityKeyStr x1 ) = rnf x1 `seq` () + rnf (PolarityKeyVar x1 ) = rnf x1 `seq` () + + +instance NFData PolarityAttr where + rnf (SimplePolarityAttr x1) = rnf x1 `seq` () + rnf (RestrictedPolarityAttr x1 x2) = rnf x1 `seq` rnf x2 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/PolarityTypes.hs b/src/NLP/GenI/PolarityTypes.hs deleted file mode 100644 --- a/src/NLP/GenI/PolarityTypes.hs +++ /dev/null @@ -1,44 +0,0 @@ --- GenI surface realiser --- Copyright (C) 2009 Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -module NLP.GenI.PolarityTypes where - -import Data.List ( break ) -import qualified Data.Set as Set -import Data.Generics ( Data ) -import Data.Typeable ( Typeable ) - -newtype PolarityKey = PolarityKey { fromPolarityKey :: String } deriving (Show, Eq, Ord, Data, Typeable) - --- | 'PolarityAttr' is something you want to perform detect polarities on. -data PolarityAttr = SimplePolarityAttr { spkAtt :: String } - -- | 'RestrictedPolarityKey' @c att@ is a polarity key in which we only pay - -- attention to nodes that have the category @c@. This makes it possible - -- to have polarities for a just a small subset of nodes - | RestrictedPolarityAttr { _rpkCat :: String, rpkAtt :: String } - deriving (Eq, Ord, Typeable) - -readPolarityAttrs :: String -> Set.Set PolarityAttr -readPolarityAttrs = Set.fromList . map helper . words - where - helper s = case break (== '.') s of - (a,"") -> SimplePolarityAttr a - (c,a) -> RestrictedPolarityAttr c (drop 1 a) - -instance Show PolarityAttr where - show (SimplePolarityAttr a) = a - show (RestrictedPolarityAttr c a) = c ++ "." ++ a diff --git a/src/NLP/GenI/Pretty.hs b/src/NLP/GenI/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Pretty.hs @@ -0,0 +1,88 @@ +-- GenI surface realiser +-- Copyright (C) 2012 Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This is not a proper pretty printer. I aim is to replace this with a +-- (de-facto) standard library if one should appear +module NLP.GenI.Pretty where + +import Data.Text ( Text ) +import qualified Data.Text as T + +-- | An alternative 'Show' instance (the idea being that we +-- should reserve 'Show' for outputting actual Haskell) +-- +-- Minimal implementation is 'pretty' or 'prettyStr' +class Pretty a where + pretty :: a -> Text + pretty = T.pack . prettyStr + + prettyStr :: a -> String + prettyStr = T.unpack . pretty + +instance Pretty String where + prettyStr a = a + +instance Pretty Int where + prettyStr a = show a + +instance Pretty Integer where + prettyStr a = show a + +between :: Text -> Text -> Text -> Text +between l r x = l `T.append` x `T.append` r + +parens :: Text -> Text +parens = between "(" ")" + +squares :: Text -> Text +squares = between "[" "]" + +-- | Identical to 'T.append' +(<>) :: Text -> Text -> Text +t1 <> t2 = t1 `T.append` t2 + +-- | Separated by space unless one of them is empty (in which case just +-- the non-empty one) +(<+>) :: Text -> Text -> Text +t1 <+> t2 | T.null t1 = t2 + | T.null t2 = t1 + | otherwise = t1 `T.append` " " `T.append` t2 + +-- | I think I want ($+$) here but I'm not sure I understand the +-- documentation from the pretty package. +-- +-- @t1 `above` t2@ separates the two by a newline, unless one +-- of them is empty. The vertical equivalent to '(<+>)' +above :: Text -> Text -> Text +above t1 t2 | T.null t1 = t2 + | T.null t2 = t1 + | otherwise = t1 `T.append` "\n" `T.append` t2 + +-- | +-- +-- > prettyCount toBlah "" (x,1) == "blah" +-- > prettyCount toBlah "foos" (x,1) == "blah" +-- > prettyCount toBlah "" (x,4) == "blah ×4" +-- > prettyCount toBlah "foos" (x,4) == "blah ×4 foos" +prettyCount :: (a -> Text) -> Text -> (a, Int) -> Text +prettyCount f _ (x, 1) = f x +prettyCount f ts (x, n) = f x <+> count <+> ts + where + count = '×' `T.cons` T.pack (show n) diff --git a/src/NLP/GenI/Regression.hs b/src/NLP/GenI/Regression.hs deleted file mode 100644 --- a/src/NLP/GenI/Regression.hs +++ /dev/null @@ -1,83 +0,0 @@ --- GenI surface realiser --- Copyright (C) 2009 Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - --- | Just regression testing of suites --- This can be seen as regression testing of GenI --- and also of grammars using GenI - -module NLP.GenI.Regression (regressionGeni) where - -import Control.Monad -import Data.IORef(readIORef, modifyIORef) -import Data.List(sort) -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 - ( fst3, - ) -import NLP.GenI.Geni -import NLP.GenI.Configuration - ( Params - , builderType , BuilderType(..) - ) -import qualified NLP.GenI.Builder as B -import NLP.GenI.Simple.SimpleBuilder - -regressionGeni :: ProgStateRef -> IO () -regressionGeni pstRef = do - do pst <- readIORef pstRef - loadEverything pstRef - tests <- (mapM toTest) . tsuite $ pst - runTestTT . (H.TestList) . concat $ tests - return () - 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 (tcSem tc) - let sentences = map lemmaSentenceString 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) - --- | 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 -> SemInput -> IO [GeniResult] -runOnSemInput pstRef semInput = - do modifyIORef pstRef (\x -> x{ts = semInput}) - pst <- readIORef pstRef - let config = pa pst - go = case builderType config of - NullBuilder -> helper B.nullBuilder - SimpleBuilder -> helper simpleBuilder_2p - SimpleOnePhaseBuilder -> helper simpleBuilder_1p - sort `fmap` go - where - helper builder = fst3 `fmap` runGeni pstRef builder diff --git a/src/NLP/GenI/Semantics.hs b/src/NLP/GenI/Semantics.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Semantics.hs @@ -0,0 +1,267 @@ +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module NLP.GenI.Semantics where + +import Control.Arrow ( first, (***), (&&&) ) +import Control.Applicative ( (<$>) ) +import Control.DeepSeq +import Data.Binary +import Data.Function ( on ) +import Data.Data +import Data.List ( nub, sortBy, delete, insert ) +import Data.Maybe ( isNothing, isJust, mapMaybe, fromMaybe ) +import qualified Data.Map as Map +import Data.Text ( Text ) +import qualified Data.Text as T + +import NLP.GenI.FeatureStructure +import NLP.GenI.GeniShow +import NLP.GenI.General ( histogram ) +import NLP.GenI.GeniVal +import NLP.GenI.Pretty + +-- handle, predicate, parameters +data Literal gv = Literal + { lHandle :: gv + , lPredicate :: gv + , lArgs :: [gv] + } + deriving (Eq, Data, Typeable) + +instance Ord gv => Ord (Literal gv) where + compare = compare `on` tucked + where + -- treat the handle as an argument + tucked l = (lPredicate l, lHandle l : lArgs l) + +type Sem = [Literal GeniVal] +type LitConstr = (Literal GeniVal, [Text]) +type SemInput = (Sem,Flist GeniVal,[LitConstr]) + +instance Collectable a => Collectable (Literal a) where + collect (Literal a b c) = collect a . collect b . collect c + +emptyLiteral :: Literal GeniVal +emptyLiteral = Literal mkGAnon mkGAnon [] + +-- Utility functions + +removeConstraints :: SemInput -> SemInput +removeConstraints (x, _, _) = (x, [], []) + +-- | default sorting for a semantics +sortSem :: Ord a => [Literal a] -> [Literal a] +sortSem = sortBy compareOnLiteral + +compareOnLiteral :: Ord a => Literal a -> Literal a -> Ordering +compareOnLiteral = compare + +-- sort primarily putting the ones with the most constants first +-- and secondarily by the number of instances a predicate occurs +-- (if plain string; atomic disjunction/vars treated as infinite) +sortByAmbiguity :: Sem -> Sem +sortByAmbiguity sem = sortBy (flip compare `on` criteria) sem + where + criteria = (constants &&& ambiguity) -- this is reverse sorting + -- so high numbers come first + ambiguity l = fromMaybe 0 $ do -- Maybe + p <- boringLiteral l + negate <$> Map.lookup p (literalCount sem) + +class HasConstants a where + constants :: a -> Int + +instance HasConstants GeniVal where + constants g = if isConst2 g then 1 else 0 + where + isConst2 :: GeniVal -> Bool + isConst2 x = isJust (gConstraints x) && isNothing (gLabel x) + +instance HasConstants a => HasConstants [a] where + constants = sum . map constants + +instance HasConstants (Literal GeniVal) where + constants (Literal h p args) = constants (h:p:args) + +literalCount :: [Literal GeniVal] -> Map.Map Text Int +literalCount = histogram . mapMaybe boringLiteral + +boringLiteral :: Literal GeniVal -> Maybe Text +boringLiteral = singletonVal . lPredicate + -- predicate with a straightfoward constant value + -- exactly one constraint + +-- Traversal + +instance DescendGeniVal a => DescendGeniVal (Literal a) where + descendGeniVal s (Literal h n lp) = Literal (descendGeniVal s h) + (descendGeniVal s n) + (descendGeniVal s lp) + +-- Pretty printing + +instance Pretty Sem where + pretty = geniShowText + +instance GeniShow Sem where + geniShowText = squares . T.unwords . map geniShowText + +instance Pretty (Literal GeniVal) where + pretty = geniShowText + +instance GeniShow (Literal GeniVal) where + geniShowText (Literal h p l) = + mh `T.append` geniShowText p + `T.append` (parens . T.unwords . map geniShowText $ l) + where + mh = if hideh h then "" else geniShowText h `T.snoc` ':' + hideh = maybe False isInternalHandle . singletonVal + +instance Pretty SemInput where + pretty = geniShowText + +instance GeniShow SemInput where + geniShowText (sem,icons,lcons) = T.intercalate "\n" . concat $ + [ [semStuff] + , [ idxStuff | not (null icons) ] + ] + where + semStuff = geniKeyword "semantics" + . squares . T.unwords + $ map withConstraints sem + idxStuff = geniKeyword "idxconstraints" + . squares + $ geniShowText icons + withConstraints lit = + case concat [ cs | (p,cs) <- lcons, p == lit ] of + [] -> geniShowText lit + cs -> geniShowText lit `T.append` (squares . T.unwords $ cs) + +isInternalHandle :: Text -> Bool +isInternalHandle = ("genihandle" `T.isPrefixOf`) + +-- ---------------------------------------------------------------------- +-- Subsumption +-- ---------------------------------------------------------------------- + +-- | @x `subsumeSem` y@ returns all the possible ways to unify +-- @x@ with some SUBSET of @y@ so that @x@ subsumes @y@. +-- If @x@ does NOT subsume @y@, we return the empty list. +subsumeSem :: Sem -> Sem -> [(Sem,Subst)] +subsumeSem x y | length x > length y = [] +subsumeSem x y = + map (first sortSem) $ subsumeSemH x y + +subsumeSemH :: Sem -> Sem -> [(Sem,Subst)] +subsumeSemH [] [] = [ ([], Map.empty) ] +subsumeSemH _ [] = error "subsumeSemH: got longer list in front" +subsumeSemH [] _ = [ ([], Map.empty) ] +subsumeSemH (x:xs) ys = nub $ + do let attempts = zip ys $ map (subsumeLiteral x) ys + (y, Just (x2, subst)) <- attempts + let next_xs = replace subst xs + next_ys = replace subst $ delete y ys + prepend = insert x2 *** appendSubst subst + prepend `fmap` subsumeSemH next_xs next_ys + +-- | @p1 `subsumeLiteral` p2@... FIXME +subsumeLiteral :: Literal GeniVal -> Literal GeniVal -> Maybe (Literal GeniVal, Subst) +subsumeLiteral (Literal h1 p1 la1) (Literal h2 p2 la2) = + if length la1 == length la2 + then do let hpla1 = h1:p1:la1 + hpla2 = h2:p2:la2 + (hpla, sub) <- hpla1 `allSubsume` hpla2 + return (toLiteral hpla, sub) + else Nothing + where + toLiteral (h:p:xs) = Literal h p xs + toLiteral _ = error "subsumeLiteral.toLiteral" + +-- ---------------------------------------------------------------------- +-- Unification +-- ---------------------------------------------------------------------- + +-- We return the list of minimal ways to unify two semantics. +-- By minimal, I mean that any literals that are not the product of a +-- succesful unification really do not unify with anything else. +unifySem :: Sem -> Sem -> [(Sem,Subst)] +unifySem xs ys = + map (first sortSem) $ + if length xs < length ys + then unifySemH xs ys + else unifySemH ys xs + +-- list monad for Prolog-style backtracking. +unifySemH :: Sem -> Sem -> [(Sem,Subst)] +unifySemH [] [] = return ([], Map.empty) +unifySemH [] xs = return (xs, Map.empty) +unifySemH xs [] = error $ "unifySem: shorter list should always be in front: " ++ prettyStr xs +unifySemH (x:xs) ys = nub $ do + let attempts = zip ys $ map (unifyLiteral x) ys + if all (isNothing . snd) attempts + then first (x:) `fmap` unifySemH xs ys -- only include x unmolested if no unification succeeds + else do (y, Just (x2, subst)) <- attempts + let next_xs = replace subst xs + next_ys = replace subst $ delete y ys + prepend = insert x2 *** appendSubst subst + prepend `fmap` unifySemH next_xs next_ys + +unifyLiteral :: Literal GeniVal -> Literal GeniVal -> Maybe (Literal GeniVal, Subst) +unifyLiteral (Literal h1 p1 la1) (Literal h2 p2 la2) = + if length la1 == length la2 + then do let hpla1 = h1:p1:la1 + hpla2 = h2:p2:la2 + (hpla, sub) <- hpla1 `unify` hpla2 + return (toLiteral hpla, sub) + else Nothing + where + toLiteral (h:p:xs) = Literal h p xs + toLiteral _ = error "unifyLiteral.toLiteral" + +-- ---------------------------------------------------------------------- +-- +-- ---------------------------------------------------------------------- + +{-! +deriving instance NFData Literal +deriving instance Binary Literal +!-} + +-- GENERATED START + + +instance NFData g => NFData (Literal g) where + rnf (Literal x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + + +instance Binary g => Binary (Literal g) where + put (Literal x1 x2 x3) + = do put x1 + put x2 + put x3 + get + = do x1 <- get + x2 <- get + x3 <- get + return (Literal x1 x2 x3) +-- GENERATED STOP diff --git a/src/NLP/GenI/Simple/SimpleBuilder.hs b/src/NLP/GenI/Simple/SimpleBuilder.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Simple/SimpleBuilder.hs @@ -0,0 +1,937 @@ +-- 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, LiberalTypeSynonyms, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Simple.SimpleBuilder ( + -- Types + Agenda, AuxAgenda, Chart, SimpleStatus, SimpleState, + SimpleItem(..), + + -- From SimpleStatus + simpleBuilder_1p, simpleBuilder_2p, simpleBuilder, + theAgenda, theHoldingPen, theChart, theResults, + initSimpleBuilder, + addToAgenda, addToChart, + genconfig, + SimpleGuiItem(..), + theTrash, step, + + unpackResult, + + -- * Aliases to non-exported functions + testCanAdjoin, testIapplyAdjNode, testEmptySimpleGuiItem + ) +where + +import Control.Arrow (first) +import Control.Monad (when, unless, liftM2) +import Control.Monad.State.Strict (get, put, modify, gets, runState, execStateT) +import Data.Bits +import Data.Generics ( Data ) +import Data.List (partition, foldl', sortBy, unfoldr ) +import Data.Maybe (isJust, isNothing, mapMaybe, fromMaybe) +import Data.Ord (comparing) +import Data.Text ( Text ) +import Data.Tree +import qualified Data.Map as Map +import qualified Data.Text as T + +import NLP.GenI.Automaton ( automatonPaths, NFA(..), addTrans ) +import NLP.GenI.Builder ( incrCounter, num_iterations, num_comparisons + , chart_size, SemBitMap, defineSemanticBits, semToBitVector, bitVectorToSem + , DispatchFilter, (>-->), condFilter, FilterStatus(Filtered, NotFiltered) + , GenStatus(..), + ) +import NLP.GenI.Configuration +import NLP.GenI.FeatureStructure ( unifyFeat, Flist ) +import NLP.GenI.General ( BitVector, mapMaybeM, mapTree', geniBug, preTerminals, repList ) +import NLP.GenI.GeniVal ( GeniVal, replace, DescendGeniVal(..), Subst, appendSubst ) +import NLP.GenI.Morphology.Types ( LemmaPlus(..) ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( sortSem, Sem ) +import NLP.GenI.Statistics (Statistics) +import NLP.GenI.Tag + ( TagElem, TagSite(..), getLexeme, toTagSite + , tidnum, idname, ttree, ttype, tsemantics + , detectSites, TagDerivation, DerivationStep(..) + , plugTree, spliceTree + , ts_rootFeatureMismatch, ts_synIncomplete, ts_semIncomplete + , ts_tbUnificationFailure + ) +import NLP.GenI.TreeSchema + ( Ptype(Initial), GNode(..), NodeName, gnnameIs + , GType(Other), root, foot ) +import qualified NLP.GenI.Builder as B + +-- -------------------------------------------------------------------- +-- The Builder interface +-- -------------------------------------------------------------------- + +type SimpleBuilder = B.Builder SimpleStatus SimpleItem Params +simpleBuilder_2p, simpleBuilder_1p :: SimpleBuilder +simpleBuilder_2p = simpleBuilder True +simpleBuilder_1p = simpleBuilder False + +simpleBuilder :: Bool -> SimpleBuilder +simpleBuilder twophase = me + where + me = B.Builder + { B.init = initSimpleBuilder twophase + , B.step = if twophase then generateStep_2p else generateStep_1p + , B.stepAll = B.defaultStepAll me + , B.finished = finished twophase + , B.unpack = unpackResults.theResults + , B.partial = unpackResults.partialResults + } + +-- -------------------------------------------------------------------- +-- Key types +-- -------------------------------------------------------------------- + +type Agenda = [SimpleItem] +type AuxAgenda = [SimpleItem] +type Chart = [SimpleItem] +type Trash = [SimpleItem] + +data GenerationPhase = SubstitutionPhase + | AdjunctionPhase + deriving (Show) + +isAdjunctionPhase :: GenerationPhase -> Bool +isAdjunctionPhase AdjunctionPhase = True +isAdjunctionPhase _ = False + +type SimpleState a = B.BuilderState SimpleStatus a + +data SimpleStatus = S + { theAgenda :: Agenda + , theHoldingPen :: AuxAgenda + , theChart :: Chart + , theTrash :: Trash + , theResults :: [SimpleItem] + , tsem :: BitVector + , step :: GenerationPhase + , gencounter :: Integer + , genconfig :: Params + -- we keep a SemBitMap strictly to help display the semantics + , semBitMap :: SemBitMap + } + -- deriving Show + +-- SimpleStatus updaters + +assignNewId :: SimpleItem -> SimpleState SimpleItem +assignNewId item = do + modify $ \s -> s{ gencounter = gencounter s + 1 } + counter <- gets gencounter + return $ item { siId = counter } + +addToAgenda :: SimpleItem -> SimpleState () +addToAgenda te = do + te2 <- assignNewId te + modify $ \s -> s{theAgenda = te2 : theAgenda s } + +updateAgenda :: Agenda -> SimpleState () +updateAgenda a = + modify $ \s -> s{theAgenda = a} + +addToAuxAgenda :: SimpleItem -> SimpleState () +addToAuxAgenda te = do + te2 <- assignNewId te + modify $ \s -> s { theHoldingPen = te2 : theHoldingPen s } + +addToChart :: SimpleItem -> SimpleState () +addToChart te = do + modify $ \s -> s { theChart = te:theChart s + } + incrCounter chart_size 1 + +addToTrash :: SimpleItem -> String -> SimpleState () +addToTrash te err = do + disableGui <- gets (hasFlagP DisableGuiFlg . genconfig) + unless disableGui $ + modify $ \s -> s { theTrash = te2 : theTrash s } + where + te2 = modifyGuiStuff (\g -> g { siDiagnostic = err : siDiagnostic g }) te + +addToResults :: SimpleItem -> SimpleState () +addToResults te = + modify $ \s -> s { theResults = te : theResults s } + +-- ---------------------------------------------------------------------- +-- SimpleItem +-- ---------------------------------------------------------------------- + +data SimpleItem = SimpleItem + { siId :: ChartId + -- + , siSubstnodes :: [NodeName] + , siAdjnodes :: [NodeName] + -- + , siSemantics :: BitVector + , siPolpaths :: BitVector + -- for generation sans semantics + -- , siAdjlist :: [(String,Integer)] -- (node name, auxiliary tree id) + , siNodes :: [GNode GeniVal] -- ^ actually a set + , siDerived :: Tree Text + , siRoot_ :: NodeName + , siFoot_ :: Maybe NodeName + -- + , siPendingTb :: [NodeName] -- only for one-phase + -- how was this item produced? + , siDerivation :: TagDerivation + -- for the debugger only + , siGuiStuff :: SimpleGuiItem + } -- deriving (Show) + + +lookupOrBug :: Text -> SimpleItem -> NodeName -> GNode GeniVal +lookupOrBug fnname item k = + case filter (gnnameIs k) (siNodes item) of + [] -> geniBug $ T.unpack fnname ++ ": could not find node " ++ T.unpack k + [gn] -> gn + _ -> geniBug $ T.unpack fnname ++ ": more than one node named " ++ T.unpack k + +siRoot :: SimpleItem -> TagSite +siRoot x = toTagSite . lookupOrBug "siRoot" x $ siRoot_ x + +siFoot :: SimpleItem -> Maybe TagSite +siFoot x = (toTagSite . lookupOrBug "siFoot" x) `fmap` siFoot_ x + +instance DescendGeniVal (Text, B.UninflectedDisjunction) where + descendGeniVal m (s,d) = (s, descendGeniVal m d) + +-- | Things whose only use is within the graphical debugger +data SimpleGuiItem = SimpleGuiItem + { siHighlight :: [Text] -- ^ nodes to highlight + -- if there are things wrong with this item, what? + , siDiagnostic :: [String] + , siFullSem :: Sem + , siIdname :: Text + } deriving (Data, Typeable) + +emptySimpleGuiItem :: SimpleGuiItem +emptySimpleGuiItem = SimpleGuiItem [] [] [] "" + +testEmptySimpleGuiItem :: SimpleGuiItem +testEmptySimpleGuiItem = emptySimpleGuiItem + +modifyGuiStuff :: (SimpleGuiItem -> SimpleGuiItem) -> SimpleItem -> SimpleItem +modifyGuiStuff fn i = i { siGuiStuff = fn . siGuiStuff $ i } + +type ChartId = Integer + +instance DescendGeniVal SimpleItem where + descendGeniVal s i = s `seq` i `seq` + i { siNodes = descendGeniVal s (siNodes i) } + +{-# INLINE closedAux #-} + +-- | True if the chart item has no open substitution nodes +closed :: SimpleItem -> Bool +closed = null.siSubstnodes + +-- | True if the chart item is an auxiliary tree +aux :: SimpleItem -> Bool +aux = isJust . siFoot + +-- | True if both 'closed' and 'aux' are True +closedAux :: SimpleItem -> Bool +closedAux x = aux x && closed x + +adjdone :: SimpleItem -> Bool +adjdone = null.siAdjnodes + +siInitial :: SimpleItem -> Bool +siInitial = isNothing . siFoot + +-- -------------------------------------------------------------------- +-- Initialisation +-- -------------------------------------------------------------------- + +-- | Creates an initial SimpleStatus. +initSimpleBuilder :: Bool -> B.Input -> Params -> (SimpleStatus, Statistics) +initSimpleBuilder twophase input config = + let disableGui = hasFlagP DisableGuiFlg config + cands = map (initSimpleItem disableGui bmap) $ B.inCands input + (sem,_,_) = B.inSemInput input + bmap = defineSemanticBits sem + -- FIXME: I don't know if this matters for one-phase + -- because of on-the-fly tb unification (in 2p), we + -- need an initial tb step that only addresses the + -- nodes with null adjunction constraints + simpleDp = if twophase then simpleDispatch_2p else simpleDispatch_1p + initialDp = dpTbNaFailure >--> dpTbFailure >--> simpleDp + -- + initS = S{ theAgenda = [] + , theHoldingPen = [] + , theChart = [] + , theTrash = [] + , theResults = [] + , semBitMap = bmap + , tsem = semToBitVector bmap sem + , step = SubstitutionPhase + , gencounter = 0 + , genconfig = config } + -- + in B.unlessEmptySem input config $ + runState (execStateT (mapM initialDp cands) initS) (B.initStats config) + + +initSimpleItem :: Bool -- ^ disable gui + -> SemBitMap -> (TagElem, BitVector) -> SimpleItem +initSimpleItem disableGui bmap (teRaw,pp) = + let (te,tlite) = renameNodesWithTidnum teRaw in + case detectSites (ttree te) of + (snodes,anodes,nullAdjNodes) -> SimpleItem + { siId = tidnum te + , siSemantics = semToBitVector bmap (tsemantics te) + , siSubstnodes = snodes + , siAdjnodes = anodes + , siPolpaths = pp + -- for generation sans semantics + -- , siAdjlist = [] + , siNodes = flatten.ttree $ te + , siDerived = tlite + , siRoot_ = gnname . root $ theTree + , siFoot_ = if ttype te == Initial then Nothing else Just . gnname . foot $ theTree + , siDerivation = [ InitStep (gorigin . root $ theTree) ] + -- note: see comment in initSimpleBuilder re: tb unification + , siPendingTb = nullAdjNodes + -- + , siGuiStuff = if disableGui then emptySimpleGuiItem else initSimpleGuiItem te + } + where theTree = ttree te + +initSimpleGuiItem :: TagElem -> SimpleGuiItem +initSimpleGuiItem te = SimpleGuiItem + { siHighlight = [] + , siDiagnostic = [] + , siFullSem = tsemantics te + , siIdname = idname te } + +renameNodesWithTidnum :: TagElem -> (TagElem, Tree NodeName) +renameNodesWithTidnum te = + ( te { ttree = mapTree' renameNode theTree } + , mapTree' newName theTree + ) + where + theTree = ttree te + renameNode n = n { gnname = newName n } + newName n = gnname n `T.append` "-" `T.append` tidstr te + tidstr = T.pack . show . tidnum + +-- -------------------------------------------------------------------- +-- Generate +-- -------------------------------------------------------------------- + +-- One-phase generation + +generateStep_1p :: SimpleState () +generateStep_1p = + do isDone <- gets (null.theAgenda) + let dispatch = mapM simpleDispatch_1p + if isDone + then return () + else do incrCounter num_iterations 1 + given <- selectGiven + -- do both substitution and adjunction + _ <- applySubstitution1p given >>= dispatch + _ <- passiveAdjunction1p given >>= dispatch + _ <- activeAdjunction1p given >>= dispatch + _ <- sansAdjunction1p given >>= dispatch + -- determine which of the res should go in the agenda + -- (monadic state) and which should go in the result (res') + addToChart given + +-- Two-phase generation + +generateStep_2p :: SimpleState () +generateStep_2p = do + nir <- gets (null.theAgenda) + curStep <- gets step + case curStep of + SubstitutionPhase -> if nir then switchToAux else generateStep_2p_sub + AdjunctionPhase -> if nir then return () else generateStep_2p_adj + +generateStep_2p_sub :: SimpleState () +generateStep_2p_sub = + do incrCounter num_iterations 1 + -- choose an item from the agenda + given <- selectGiven + res <- applySubstitution given + mapM_ simpleDispatch_2p res + -- put the given into the chart untouched + addToChart given + +generateStep_2p_adj :: SimpleState () +generateStep_2p_adj = + do incrCounter num_iterations 1 + -- choose an item from the agenda + given <- selectGiven + res <- liftM2 (++) (applyAdjunction2p given) (sansAdjunction2p given) + mapM_ simpleDispatch_2p_adjphase res + when (adjdone given) $ trashIt given + +-- Helpers for the generateSteps + +trashIt :: SimpleItem -> SimpleState () +trashIt item = + do disableGui <- gets (hasFlagP DisableGuiFlg . genconfig) + unless disableGui $ do + s <- get + let bmap = semBitMap s + itemSem = siSemantics item + inputSem = tsem s + reason = if inputSem == itemSem + then "unknown reason!" + else ts_semIncomplete $ bitVectorToSem bmap $ inputSem `xor` itemSem + addToTrash item reason + +-- | Arbitrarily selects and removes an element from the agenda and +-- returns it. +selectGiven :: SimpleState SimpleItem +selectGiven = do + agenda <- gets theAgenda + case agenda of + [] -> geniBug "null agenda in selectGiven" + (a:atail) -> updateAgenda atail >> return a + +-- Switching phases + +switchToAux :: SimpleState () +switchToAux = do + st <- get + let oldAuxTrees = theHoldingPen st + -- You might be wondering why we ignore the auxiliary trees in the + -- chart; this is because all the syntactically complete auxiliary + -- trees have already been filtered away by calls to classifyNew + initialT = filter siInitial (theChart st) + (compT1, incompT1) = partition (null.siSubstnodes) initialT + (auxTrees, compT2) = + ( mapMaybe (detectNa oldAuxTrees) oldAuxTrees + , mapMaybe (detectNa auxTrees) compT1 ) + (compT3, incompT3) = semfilter (tsem st) auxTrees compT2 + -- + compT = compT3 + put st{ theAgenda = [] + , theHoldingPen = [] + , theChart = auxTrees + , step = AdjunctionPhase } + mapM_ simpleDispatch_2p_adjphase compT + -- toss the syntactically incomplete stuff in the trash + mapM_ (\t -> addToTrash t ts_synIncomplete) incompT1 + mapM_ (\t -> addToTrash t "sem-filtered") incompT3 + +-- Completion + +finished :: Bool -> SimpleStatus -> GenStatus +finished twophase st + | reallyDone = B.Finished + | atMaxResults = B.Finished + | atMaxSteps = B.Error $ "Max steps exceeded" <+> parens (pretty maxSteps) + | otherwise = B.Active + where + reallyDone = null (theAgenda st) && (not twophase || isAdjunctionPhase (step st)) + atMaxResults = maybeIf (<= fromIntegral (length (theResults st))) $ getFlagP MaxResultsFlg (genconfig st) + atMaxSteps = maybeIf (< gencounter st) mMaxSteps + mMaxSteps = getFlagP MaxStepsFlg (genconfig st) + maxSteps = fromMaybe (error "get maxsteps") mMaxSteps + maybeIf bf = maybe False bf + +-- SemFilter Optimisation + +semfilter :: BitVector -> [SimpleItem] -> [SimpleItem] -> ([SimpleItem], [SimpleItem]) +semfilter inputsem auxs initial = + let auxsem x = foldl' (.|.) 0 [ siSemantics a | a <- auxs, siPolpaths a .&. siPolpaths x /= 0 ] + -- lite, here, means sans auxiliary semantics + notjunk x = (siSemantics x) .&. inputsemLite == inputsemLite + where inputsemLite = inputsem `xor` (auxsem x) + -- note that we can't just compare against siSemantics because + -- that would exclude trees that have stuff in the aux semantics + -- which would be overzealous + in partition notjunk initial + +-- -------------------------------------------------------------------- +-- Substitution +-- -------------------------------------------------------------------- + +applySubstitution :: SimpleItem -> SimpleState ([SimpleItem]) +applySubstitution item = + do gr <- lookupChart item + active <- mapM (\x -> iapplySubst True item x) gr + passive <- mapM (\x -> iapplySubst True x item) gr + let res = concat $ active ++ passive + incrCounter num_comparisons (2 * (length gr)) + return res + +applySubstitution1p :: SimpleItem -> SimpleState ([SimpleItem]) +applySubstitution1p item = + do gr <- lookupChart item + active <- if adjdone item then return [] + else mapM (\x -> iapplySubst False item x) gr + passive <- mapM (\x -> iapplySubst False x item) $ filter adjdone gr + let res = concat $ active ++ passive + incrCounter num_comparisons (2 * (length gr)) + return res + +-- | Note: returns ONE possible substitution (the head node) +-- of the first in the second. As all substitutions nodes should +-- be substituted we force substitution in order. +iapplySubst :: Bool -> SimpleItem -> SimpleItem -> SimpleState [SimpleItem] +iapplySubst twophase item1 item2 | siInitial item1 && closed item1 = {-# SCC "applySubstitution" #-} + case siSubstnodes item2 of + [] -> return [] + (shead : stail) -> + let doIt = + do -- Maybe monad + let (TagSite n fu fd nOrigin) = toTagSite (lookupOrBug "iapplySubst" item2 shead) + (TagSite rn ru rd rOrigin) = siRoot item1 + (newU, subst1) <- unifyFeat ru fu + (newD, subst2) <- unifyFeat (replace subst1 rd) + (replace subst1 fd) + let subst = appendSubst subst1 subst2 + -- gui stuff + newRoot g = g { gup = newU, gdown = newD, gtype = Other } + let pending = if twophase then [] + else rn : (siPendingTb item1 ++ siPendingTb item2) + let item1g = item1 { siNodes = repList (gnnameIs rn) newRoot (siNodes item1) } + return $! replace subst $ combineSimpleItems [rn] item1g $ + item2 { siSubstnodes = stail ++ (siSubstnodes item1) + , siAdjnodes = siAdjnodes item1 ++ siAdjnodes item2 + , siDerived = plugTree (siDerived item1) n (siDerived item2) + , siDerivation = addToDerivation SubstitutionStep (item1, rOrigin) (item2,nOrigin,n) + , siPendingTb = pending + } + in case doIt of + Nothing -> return [] + Just x -> do incrCounter "substitutions" 1 + return [x] +iapplySubst _ _ _ = return [] + +-- -------------------------------------------------------------------- +-- Adjunction +-- --------------------------------------------------------------- + +applyAdjunction2p :: SimpleItem -> SimpleState ([SimpleItem]) +applyAdjunction2p item = {-# SCC "applyAdjunction2p" #-} + do gr <-lookupChart item + incrCounter num_comparisons (length gr) + mapMaybeM (\a -> tryAdj True a item) gr + +passiveAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] +passiveAdjunction1p item | closed item && siInitial item = + do gr <- lookupChart item + mapMaybeM (\a -> tryAdj False a item) $ filter validAux gr +passiveAdjunction1p _ = return [] + +activeAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] +activeAdjunction1p item | validAux item = + do gr <- lookupChart item + mapMaybeM (\p -> tryAdj False item p) $ filter (\x -> siInitial x && closed x) gr +activeAdjunction1p _ = return [] + +validAux :: SimpleItem -> Bool +validAux t = closedAux t && adjdone t + +tryAdj :: Bool -> SimpleItem -> SimpleItem -> SimpleState (Maybe SimpleItem) +tryAdj twophase aItem pItem = + do case iapplyAdjNode twophase aItem pItem of + Just x -> do incrCounter "adjunctions" 1 + return $ Just x + Nothing -> return Nothing + +-- | Ignore the next adjunction node +sansAdjunction1p, sansAdjunction2p :: SimpleItem -> SimpleState [SimpleItem] +sansAdjunction1p item | closed item = + case siAdjnodes item of + [] -> return [] + (ahead : atail) -> + return $ [item { siAdjnodes = atail + , siPendingTb = ahead : (siPendingTb item) } ] +sansAdjunction1p _ = return [] + +-- | Ignore the next adjunction node +sansAdjunction2p item | closed item = + case siAdjnodes item of + [] -> return [] + (ahead : atail) -> do + let (TagSite gn t b _) = toTagSite (lookupOrBug "sansAdjunction2p" item ahead) + -- do top/bottom unification on the node + case unifyFeat t b of + Nothing -> + do addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item) + ts_tbUnificationFailure + return [] + Just (tb,s) -> + let item1 = constrainAdj gn tb item + in return $! [replace s $! item1 { siAdjnodes = atail }] +sansAdjunction2p _ = return [] + +iapplyAdjNode :: Bool -> SimpleItem -> SimpleItem -> Maybe SimpleItem +iapplyAdjNode twophase aItem pItem = {-# SCC "iapplyAdjNode" #-} + case siAdjnodes pItem of + [] -> Nothing + (pHead : pTail) -> do + -- let's go! + let pSite = toTagSite (lookupOrBug "iapplyAdjNode" pItem pHead) + (anr, anf, subst12) <- canAdjoin aItem pSite + let r_name = siRoot_ aItem + r = siRoot aItem + f <- siFoot aItem + let an_name = tsName pSite + -- the new adjunction nodes + aItem2 = aItem { siNodes = map (setSites anr) (siNodes aItem) } + where + setSites (TagSite n u d _) gn = + if gnname gn == n then gn { gup = u, gdown = d } else gn + rawCombined = + combineSimpleItems [tsName r, an_name] aItem2 $ pItem + { siAdjnodes = pTail ++ siAdjnodes aItem + , siDerived = spliceTree (tsName f) (siDerived aItem) an_name (siDerived pItem) + , siDerivation = addToDerivation AdjunctionStep (aItem,tsOrigin r) (pItem,tsOrigin pSite,an_name) + -- , siAdjlist = (n, (tidnum te1)):(siAdjlist item2) + -- if we adjoin into the root, the new root is that of the aux + -- tree (affects 1p only) + , siRoot_ = if isRootOf pItem an_name then r_name else siRoot_ pItem + , siPendingTb = + if twophase then [] + else tsName f : siPendingTb pItem ++ siPendingTb aItem + } + -- one phase = postpone tb unification + -- two phase = do tb unification on the fly + finalRes1p = return $ replace subst12 rawCombined + finalRes2p = + do -- tb on the former foot + tbRes <- unifyFeat (tsUp anf) (tsDown anf) + let (anf_tb, subst3) = tbRes + myRes = constrainAdj an_name anf_tb res' + -- apply the substitutions + res' = replace (appendSubst subst12 subst3) rawCombined + return myRes + -- --------------- + if twophase then finalRes2p else finalRes1p + +testIapplyAdjNode :: Bool -> SimpleItem -> SimpleItem -> Maybe SimpleItem +testIapplyAdjNode = iapplyAdjNode + +canAdjoin :: SimpleItem -> TagSite -> Maybe (TagSite, TagSite, Subst) +canAdjoin aItem pSite = do + -- let's go! + let r = siRoot aItem -- auxiliary tree, eh? + f <- siFoot aItem -- should really be an error if fails + (anr_up', subst1) <- unifyFeat (tsUp r) (tsUp pSite) + (anf_down, subst2) <- unifyFeat (replace subst1 $ tsDown f) (replace subst1 $ tsDown pSite) + let -- combined substitution list and success condition + subst12 = appendSubst subst1 subst2 + anr = replace subst12 $ r { tsUp = anr_up' } -- resulting node based on the root node of the aux tree + anf = replace subst12 $ f { tsDown = anf_down } -- resulting node based on the foot node of the aux tree + return (anr, anf, subst12) + +testCanAdjoin :: SimpleItem -> TagSite -> Maybe (TagSite, TagSite, Subst) +testCanAdjoin = canAdjoin + +detectNa :: [SimpleItem] -- ^ aux trees + -> SimpleItem -- ^ me + -> Maybe SimpleItem +detectNa rawAux i = helper (map look (siAdjnodes i)) Map.empty [] + where + look = toTagSite . lookupOrBug "detectNa" i + compatAux = filterCompatible i rawAux + helper [] s acc = Just $ replace s $ i { siAdjnodes = acc } + helper (t:ts) s acc = + let hasAdj = any isJust $ map (\a -> canAdjoin a t) compatAux + in case (snd `fmap` unifyFeat (tsUp t) (tsDown t)) of + Just s2 -> if hasAdj + then helper ts s (tsName t : acc) + else helper (replace s2 ts) (appendSubst s s2) acc + Nothing -> if hasAdj + then helper ts s (tsName t : acc) + else Nothing + +-- -------------------------------------------------------------------- +-- Helper functions for operations +-- -------------------------------------------------------------------- + +isRootOf :: SimpleItem -> Text -> Bool +isRootOf item n = n == siRoot_ item + +-- | Retrieves a list of trees from the chart which could be combined with the given agenda tree. +-- The current implementation searches for trees which +-- * do not have overlapping semantics with the given +-- * are on the some of the same polarity automaton paths as the +-- current agenda item +lookupChart :: SimpleItem -> SimpleState [SimpleItem] +lookupChart given = gets (filterCompatible given . theChart) + +filterCompatible :: SimpleItem -> [SimpleItem] -> [SimpleItem] +filterCompatible given chart = + [ i | i <- chart + -- should be on the same polarity path (chart sharing) + , (siPolpaths i) .&. gpaths /= 0 + -- semantics should not be overlapping + && (siSemantics i .&. gsem ) == 0 + ] + where + gpaths = siPolpaths given + gsem = siSemantics given + +-- | Helper function for when chart operations succeed. +combineSimpleItems :: [NodeName] -- ^ nodes to highlight + -> SimpleItem -> SimpleItem -> SimpleItem +combineSimpleItems hi item1 item2 = {-# SCC "combineSimpleItems" #-} + item2 { siSemantics = siSemantics item1 .|. siSemantics item2 + , siPolpaths = siPolpaths item1 .&. siPolpaths item2 + , siGuiStuff = combineSimpleGuiItems hi (siGuiStuff item1) (siGuiStuff item2) + , siNodes = siNodes item1 ++ siNodes item2 + } + +combineSimpleGuiItems :: [NodeName] + -> SimpleGuiItem -> SimpleGuiItem -> SimpleGuiItem +combineSimpleGuiItems hi item1 item2 = + item2 { siFullSem = sortSem $ siFullSem item1 ++ siFullSem item2 + , siDiagnostic = siDiagnostic item1 ++ siDiagnostic item2 + , siHighlight = hi + } + +constrainAdj :: Text -> Flist GeniVal -> SimpleItem -> SimpleItem +constrainAdj gn newT g = + g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) } + where fixIt n = n { gup = newT, gdown = [], gaconstr = True } + +-- Derivation trees + +addToDerivation :: (Text -> Text -> Text -> DerivationStep) + -> (SimpleItem, Text) + -> (SimpleItem, Text, Text) + -> TagDerivation +addToDerivation op (tc,tcOrigin) (tp,tpOrigin,tpSite) = + let hp = siDerivation tp + hc = filter (not . isInit) (siDerivation tc) + newnode = op tcOrigin tpOrigin tpSite + in newnode:hp++hc + where + isInit :: DerivationStep -> Bool + isInit (InitStep _) = True + isInit _ = False + +-- -------------------------------------------------------------------- +-- Dispatching new results +-- -------------------------------------------------------------------- + +type SimpleDispatchFilter = DispatchFilter SimpleState SimpleItem + +simpleDispatch_2p :: SimpleDispatchFilter +simpleDispatch_2p = + simpleDispatch (dpRootFeatFailure >--> dpToResults) + (dpAux >--> dpToAgenda) + +simpleDispatch_2p_adjphase :: SimpleDispatchFilter +simpleDispatch_2p_adjphase = + simpleDispatch (dpRootFeatFailure >--> dpToResults) + dpToAgenda + +simpleDispatch_1p :: SimpleDispatchFilter +simpleDispatch_1p = + simpleDispatch (dpRootFeatFailure >--> dpTbFailure >--> dpToResults) + dpToAgenda + +simpleDispatch :: SimpleDispatchFilter -> SimpleDispatchFilter -> SimpleDispatchFilter +simpleDispatch resFilter nonResFilter item = + do inputsem <- gets tsem + let synComplete x = siInitial x && closed x && adjdone x + semComplete x = inputsem == siSemantics x + isResult x = synComplete x && semComplete x + condFilter isResult resFilter nonResFilter item + +dpAux, dpToAgenda :: SimpleDispatchFilter +dpTbFailure, dpToResults :: SimpleDispatchFilter +dpToTrash :: String -> SimpleDispatchFilter + +dpToAgenda x = addToAgenda x >> return Filtered +dpToResults x = addToResults x >> return Filtered +dpToTrash m x = addToTrash x m >> return Filtered + +dpAux item = + if closedAux item + then addToAuxAgenda item >> return Filtered + else return (NotFiltered item) + +{- +-- | Dispatches to the trash and returns Nothing if there is a tree +-- size limit in effect and the item is over that limit. The +-- tree size limit is used in 'IgnoreSemantics' mode. +dpTreeLimit item = + do config <- gets genconfig + case maxTrees config of + Nothing -> return $ Just item + Just lim -> if (length.snd.siDerivation) item > lim + then do addToTrash item (ts_overnumTrees lim) + return Nothing + else return $ Just item + where ts_overnumTrees l = "Over derivation size of " ++ (show l) +-} + +dpTbNaFailure :: SimpleDispatchFilter +dpTbNaFailure item = + case tbUnifyNaNodes (siNodes item) of + Nothing -> dpToTrash ("top-bottom unification failure in NA nodes") item + Just (ns2,s) -> return . NotFiltered . replace s $ item { siNodes = ns2 } + +-- | This is only used for the one-phase algorithm +dpTbFailure item = + return (if tbUnifyTree item then NotFiltered item else Filtered) + +-- | If the item (ostensibly a result) does not have the correct root +-- category, return Nothing; otherwise return Just item +dpRootFeatFailure :: SimpleDispatchFilter +dpRootFeatFailure item = + do config <- gets genconfig + let rootFeat = getListFlagP RootFeatureFlg config + (TagSite _ top _ _) = siRoot item + case unifyFeat rootFeat top of + Nothing -> + dpToTrash (ts_rootFeatureMismatch rootFeat) item + Just (_, s) -> + return . NotFiltered $ replace s item + +-- -------------------------------------------------------------------- +-- Top and bottom unification +-- -------------------------------------------------------------------- + +tbUnifyNaNodes :: [GNode GeniVal] -> Maybe ([GNode GeniVal], Subst) +tbUnifyNaNodes [] = Just ([], Map.empty) +tbUnifyNaNodes (n:ns) = + if gaconstr n + then do (ud, sub) <- unifyFeat (gup n) (gdown n) + let n2 = n { gup = ud, gdown = [] } + (ns2, sub2) <- tbUnifyNaNodes (replace sub ns) + return (n2:ns2, sub `appendSubst` sub2) + else first (n:) `fmap` tbUnifyNaNodes ns + +type TbEither = Either Text Subst +tbUnifyTree :: SimpleItem -> Bool +tbUnifyTree item = {-# SCC "tbUnifyTree" #-} + case foldl' tbUnifyNode (Right Map.empty) pending of + Left _ -> False + Right _ -> True + where + pending = map (toTagSite . lookupOrBug "tbUnifyTree" item) (siPendingTb item) + +tbUnifyNode :: TbEither -> TagSite -> TbEither +tbUnifyNode (Right pending) rawSite = + -- apply pending substitutions + case replace pending rawSite of + (TagSite name up down _) -> + -- check top/bottom unification on this node + case unifyFeat up down of + -- stop all future iterations + Nothing -> Left name + -- apply any new substutions to the whole tree + Just (_,sb) -> Right (appendSubst pending sb) + +-- if earlier we had a failure, don't even bother +tbUnifyNode (Left n) _ = Left n + +-- -------------------------------------------------------------------- +-- Unpacking the results +-- -------------------------------------------------------------------- + +unpackResults :: [SimpleItem] -> [B.Output] +unpackResults = concatMap unpackResult + +--Change, instead of returning the features of the parent node for every leaf, return: +-- -the features of the parent node when the leaf doesn't have features (top and bottom feature structure empty) +-- -the features of the node in case it has (in this case return the unification of top and bottom features). +unpackResult :: SimpleItem -> [B.Output] +unpackResult item = + let look = lookupOrBug "unpackResult" item + toUninflectedDisjunction (pt,t) = + --B.UninflectedDisjunction (getLexeme (look t)) (gup (look pt)) + B.UninflectedDisjunction (getLexeme (look t)) + (gup . look $ if emptyFeatureStr (look t) then pt else t) + + derivation = siDerivation item + paths = automatonPaths . listToSentenceAut . map toUninflectedDisjunction . preTerminals . siDerived $ item + in map (\p -> (siId item, p, derivation)) paths + +emptyFeatureStr :: GNode GeniVal -> Bool +emptyFeatureStr n= null (gdown n) && null (gup n) + +-- Sentence automata + +listToSentenceAut :: [ B.UninflectedDisjunction ] -> B.SentenceAut +listToSentenceAut nodes = + let theStart = 0 + theEnd = length nodes - 1 + theStates = [theStart..theEnd] + -- + emptyAut = NFA + { startSt = theStart + , isFinalSt = Nothing + , finalStList = [theEnd] + , states = [theStates] + , transitions = Map.empty } + -- create a transition for each lexeme in the node to the + -- next state... + helper :: (Int, B.UninflectedDisjunction) -> B.SentenceAut -> B.SentenceAut + helper (current, B.UninflectedDisjunction lemmas features) aut = + foldl' addT aut lemmas + where + addT a t = addTrans a current (Just (LemmaPlus t features)) next + next = current + 1 + -- + in foldr helper emptyAut (zip theStates nodes) + +-- -------------------------------------------------------------------- +-- Partial results +-- -------------------------------------------------------------------- + +partialResults :: SimpleStatus -> [SimpleItem] +partialResults st = unfoldr getNext 0 + where + inputsem = tsem st + trash = theTrash st + trashC = sortBy (comparing $ negate . fst) $ + map (\t -> (coverage inputsem t, t)) trash + getNext sem = case getItems sem of + [] -> Nothing + (it:_) -> Just (it, siSemantics it .|. sem) + getItems sem = [ i | (_,i) <- trashC, siSemantics i .&. sem == 0 ] + +coverage :: BitVector -> SimpleItem -> Int +coverage sem it = countBits (sem .&. siSemantics it) + +countBits :: Bits a => a -> Int +countBits 0 = 0 +countBits bs = if testBit bs 0 then 1 + next else next + where next = countBits (shiftR bs 1) + +-- -------------------------------------------------------------------- +-- Performance +-- -------------------------------------------------------------------- + +{- +instance NFData SimpleItem where + rnf (SimpleItem x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 + ) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 + `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 + `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 + `seq` rnf x14 +-} diff --git a/src/NLP/GenI/Simple/SimpleBuilder.lhs b/src/NLP/GenI/Simple/SimpleBuilder.lhs deleted file mode 100644 --- a/src/NLP/GenI/Simple/SimpleBuilder.lhs +++ /dev/null @@ -1,1225 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{SimpleBuilder} -\label{cha:SimpleBuilder} - -A SimpleBuilder is a Builder which constructs derived trees using a -simple agenda control mechanism and two-phase realisation (substitution -before adjunction). There is no packing strategy whatsoever; each chart -item is a derived tree. - -\begin{code} -{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-} -{-# LANGUAGE LiberalTypeSynonyms, TemplateHaskell #-} -module NLP.GenI.Simple.SimpleBuilder ( - -- Types - Agenda, AuxAgenda, Chart, SimpleStatus, SimpleState, - SimpleItem(..), - - -- From SimpleStatus - simpleBuilder_1p, simpleBuilder_2p, simpleBuilder, - theAgenda, theHoldingPen, theChart, theResults, - initSimpleBuilder, - addToAgenda, addToChart, - genconfig, - SimpleGuiItem(..), - theTrash, step, - - unpackResult, - ) -where -\end{code} - - -\ignore{ -\begin{code} -import Control.Arrow ( second ) -import Control.Monad (when, unless, liftM2) -import Control.Monad.State.Strict - (get, put, modify, gets, runState, execStateT) - -import Data.List (partition, delete, foldl') -import Data.Maybe (isJust, isNothing, mapMaybe) -import Data.Ord (comparing) -import Data.Bits -import qualified Data.Map as Map -import Data.Tree - -import Data.Generics ( Data ) -import Data.Generics.PlateDirect - -import NLP.GenI.Statistics (Statistics) - -import NLP.GenI.Automaton ( automatonPaths, NFA(..), addTrans ) -import NLP.GenI.Btypes - ( Ptype(Initial) - , GeniVal - , replace, DescendGeniVal(..) - , GNode(..), NodeName - , root, foot - , plugTree, spliceTree - , unifyFeat, Flist, Subst, mergeSubst - ) -import NLP.GenI.Builder ( - incrCounter, num_iterations, num_comparisons, chart_size, - SemBitMap, defineSemanticBits, semToBitVector, bitVectorToSem, - DispatchFilter, (>-->), condFilter, nullFilter, - semToIafMap, IafAble(..), IafMap, fromUniConst, getIdx, - recalculateAccesibility, iafBadSem, ts_iafFailure, - LemmaPlus(..), - ) -import qualified NLP.GenI.Builder as B - -import NLP.GenI.Tags (TagElem, TagSite(..), - tagLeaves, tidnum, - ttree, ttype, tsemantics, - detectSites, - TagDerivation, DerivationStep(..), - ts_rootFeatureMismatch, - ) -import NLP.GenI.Configuration -import NLP.GenI.General - ( BitVector, mapMaybeM, mapTree', geniBug, preTerminals, ) - -import NLP.GenI.Btypes ( GType(Other), sortSem, Sem, gnnameIs ) -import NLP.GenI.General ( repList, ) -import NLP.GenI.Tags ( idname, - ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure, - ) - -import Data.List ( sortBy, unfoldr ) -\end{code} -} - -% -------------------------------------------------------------------- -\section{The Builder interface} -% -------------------------------------------------------------------- - -Here is our implementation of Builder. - -\begin{code} -type SimpleBuilder = B.Builder SimpleStatus SimpleItem Params -simpleBuilder_2p, simpleBuilder_1p :: SimpleBuilder -simpleBuilder_2p = simpleBuilder True -simpleBuilder_1p = simpleBuilder False - -simpleBuilder :: Bool -> SimpleBuilder -simpleBuilder twophase = B.Builder - { B.init = initSimpleBuilder twophase - , B.step = if twophase then generateStep_2p else generateStep_1p - , B.stepAll = B.defaultStepAll (simpleBuilder twophase) - , B.finished = \s -> (null.theAgenda) s && (not twophase || isAdjunctionPhase (step s)) - , B.unpack = unpackResults.theResults - , B.partial = unpackResults.partialResults - } -\end{code} - -% -------------------------------------------------------------------- -\section{Key types} -% -------------------------------------------------------------------- - -\begin{code} -type Agenda = [SimpleItem] -type AuxAgenda = [SimpleItem] -type Chart = [SimpleItem] -type Trash = [SimpleItem] - -data GenerationPhase = SubstitutionPhase - | AdjunctionPhase - deriving (Show) - -isAdjunctionPhase :: GenerationPhase -> Bool -isAdjunctionPhase AdjunctionPhase = True -isAdjunctionPhase _ = False -\end{code} - -\subsection{SimpleState and SimpleStatus} - -The \fnreflite{SimpleState} is a state monad where the state being -thread through is a \fnreflite{SimpleStatus}. The two are named -deliberately alike to indicate their close relationship. - -To prevent confusion, we ought to keep a somewhat consistent naming -scheme across the builders: FooState for the state monad, FooStatus for -the state monad's ``contents'', and FooItem for the chart items -manipulated. - -Note the theTrash is not actually essential to the operation of the -generator; it is for pratical debugging of grammars. Instead of -trees dissapearing off the face of the debugger; they go into the -trash where the user can inspect them and try to figure out why they -went wrong. - -\begin{code} -type SimpleState a = B.BuilderState SimpleStatus a - -data SimpleStatus = S - { theAgenda :: Agenda - , theHoldingPen :: AuxAgenda - , theChart :: Chart - , theTrash :: Trash - , theResults :: [SimpleItem] - , theIafMap :: IafMap -- for index accessibility filtering - , tsem :: BitVector - , step :: GenerationPhase - , gencounter :: Integer - , genconfig :: Params - -- we keep a SemBitMap strictly to help display the semantics - , semBitMap :: SemBitMap - } - deriving Show -\end{code} - -\subsubsection{SimpleStatus updaters} - -\begin{code} -addToAgenda :: SimpleItem -> SimpleState () -addToAgenda te = - modify $ \s -> s{theAgenda = te : theAgenda s } - -updateAgenda :: Agenda -> SimpleState () -updateAgenda a = - modify $ \s -> s{theAgenda = a} - -addToAuxAgenda :: SimpleItem -> SimpleState () -addToAuxAgenda te = do - s <- get - -- each new tree gets a unique id... this makes comparisons faster - let counter = gencounter s + 1 - te2 = te { siId = counter } - put s{gencounter = counter, - theHoldingPen = te2 : theHoldingPen s } - -addToChart :: SimpleItem -> SimpleState () -addToChart te = do - modify $ \s -> s { theChart = te:theChart s } - incrCounter chart_size 1 - -addToTrash :: SimpleItem -> String -> SimpleState () -addToTrash te err = do - disableGui <- gets (hasFlagP DisableGuiFlg . genconfig) - unless disableGui $ - modify $ \s -> s { theTrash = te2 : theTrash s } - where - te2 = modifyGuiStuff (\g -> g { siDiagnostic = err:siDiagnostic g }) te - -addToResults :: SimpleItem -> SimpleState () -addToResults te = - modify $ \s -> s { theResults = te : theResults s } -\end{code} - -\subsection{SimpleItem} - -\begin{code} -data SimpleItem = SimpleItem - { siId :: ChartId - -- - , siSubstnodes :: [TagSite] - , siAdjnodes :: [TagSite] - -- - , siSemantics :: BitVector - , siPolpaths :: BitVector - -- for generation sans semantics - -- , siAdjlist :: [(String,Integer)] -- (node name, auxiliary tree id) - -- for index accesibility filtering (one-phase only) - , siAccesible :: [ String ] -- it's acc/inacc/undetermined - , siInaccessible :: [ String ] -- that's why you want both - -- - -- | actually: a set of pre-terminals and their leaves - , siLeaves :: [(String, B.UninflectedDisjunction)] - , siDerived :: Tree String - , siRoot :: TagSite - , siFoot :: Maybe TagSite - -- - , siPendingTb :: [ TagSite ] -- only for one-phase - -- how was this item produced? - , siDerivation :: TagDerivation - -- for the debugger only - , siGuiStuff :: SimpleGuiItem - } deriving (Show) - -instance Biplate SimpleItem GeniVal where - biplate (SimpleItem x1 zss zas x2 x3 x4 x5 zls x6 zr zf zp x7 zg) = - plate SimpleItem |- x1 - ||+ zss ||+ zas |- x2 |- x3 |- x4 |- x5 - ||+ zls |- x6 - |+ zr |+ zf ||+ zp |- x7 - |+ zg - -instance Biplate (String, B.UninflectedDisjunction) GeniVal where - biplate (s,d) = plate (,) |- s |+ d - -instance DescendGeniVal (String, B.UninflectedDisjunction) where - descendGeniVal m (s,d) = (s, descendGeniVal m d) - --- | Things whose only use is within the graphical debugger -data SimpleGuiItem = SimpleGuiItem - { siHighlight :: [String] -- ^ nodes to highlight - , siNodes :: [GNode] -- ^ actually a set - -- if there are things wrong with this item, what? - , siDiagnostic :: [String] - , siFullSem :: Sem - , siIdname :: String - } deriving (Show, Data, Typeable) - -instance Biplate SimpleGuiItem GeniVal where - biplate (SimpleGuiItem x1 zns x2 zsem x3) = - plate SimpleGuiItem |- x1 - ||+ zns |- x2 - ||+ zsem |- x3 - -emptySimpleGuiItem :: SimpleGuiItem -emptySimpleGuiItem = SimpleGuiItem [] [] [] [] "" - -modifyGuiStuff :: (SimpleGuiItem -> SimpleGuiItem) -> SimpleItem -> SimpleItem -modifyGuiStuff fn i = i { siGuiStuff = fn . siGuiStuff $ i } - -type ChartId = Integer - -instance DescendGeniVal SimpleItem where - descendGeniVal s i = s `seq` i `seq` - i { siSubstnodes = descendGeniVal s (siSubstnodes i) - , siAdjnodes = descendGeniVal s (siAdjnodes i) - , siLeaves = descendGeniVal s (siLeaves i) - , siRoot = descendGeniVal s (siRoot i) - , siFoot = descendGeniVal s (siFoot i) - , siPendingTb = descendGeniVal s (siPendingTb i) - , siGuiStuff = descendGeniVal s (siGuiStuff i) - } - -instance DescendGeniVal SimpleGuiItem where - descendGeniVal s i = i { siNodes = descendGeniVal s (siNodes i) } -\end{code} - -\begin{code} -{-# INLINE closedAux #-} - --- | True if the chart item has no open substitution nodes -closed :: SimpleItem -> Bool -closed = null.siSubstnodes - --- | True if the chart item is an auxiliary tree -aux :: SimpleItem -> Bool -aux = isJust . siFoot - --- | True if both 'closed' and 'aux' are True -closedAux :: SimpleItem -> Bool -closedAux x = aux x && closed x - -adjdone :: SimpleItem -> Bool -adjdone = null.siAdjnodes - -siInitial :: SimpleItem -> Bool -siInitial = isNothing . siFoot -\end{code} - -% -------------------------------------------------------------------- -\section{Initialisation} -% -------------------------------------------------------------------- - -\begin{code} --- | Creates an initial SimpleStatus. -initSimpleBuilder :: Bool -> B.Input -> Params -> (SimpleStatus, Statistics) -initSimpleBuilder twophase input config = - let disableGui = hasFlagP DisableGuiFlg config - cands = map (initSimpleItem disableGui bmap) $ B.inCands input - (sem,_,_) = B.inSemInput input - bmap = defineSemanticBits sem - -- FIXME: I don't know if this matters for one-phase - -- because of on-the-fly tb unification (in 2p), we - -- need an initial tb step that only addresses the - -- nodes with null adjunction constraints - simpleDp = if twophase then simpleDispatch_2p - else simpleDispatch_1p (hasOpt Iaf config) - initialDp = dpTbFailure >--> simpleDp - -- - initS = S{ theAgenda = [] - , theHoldingPen = [] - , theChart = [] - , theTrash = [] - , theResults = [] - , semBitMap = bmap - , tsem = semToBitVector bmap sem - , theIafMap = semToIafMap sem - , step = SubstitutionPhase - , gencounter = toInteger $ length cands - , genconfig = config } - -- - in B.unlessEmptySem input config $ - runState (execStateT (mapM initialDp cands) initS) (B.initStats config) - - -initSimpleItem :: Bool -- ^ disable gui - -> SemBitMap -> (TagElem, BitVector) -> SimpleItem -initSimpleItem disableGui bmap (teRaw,pp) = - let (te,tlite) = renameNodesWithTidnum teRaw in - case detectSites (ttree te) of - (snodes,anodes,nullAdjNodes) -> setIaf $ SimpleItem - { siId = tidnum te - , siSemantics = semToBitVector bmap (tsemantics te) - , siSubstnodes = snodes - , siAdjnodes = anodes - , siPolpaths = pp - -- for index accesibility filtering - , siAccesible = [] -- see below - , siInaccessible = [] - -- for generation sans semantics - -- , siAdjlist = [] - , siLeaves = map (second (uncurry B.UninflectedDisjunction)) $ tagLeaves te - , siDerived = tlite - , siRoot = ncopy.root $ theTree - , siFoot = if ttype te == Initial then Nothing - else Just . ncopy.foot $ theTree - , siDerivation = [] - -- note: see comment in initSimpleBuilder re: tb unification - , siPendingTb = nullAdjNodes - -- - , siGuiStuff = if disableGui then emptySimpleGuiItem else initSimpleGuiItem te - } - where setIaf i = i { siAccesible = iafNewAcc i } - theTree = ttree te - -initSimpleGuiItem :: TagElem -> SimpleGuiItem -initSimpleGuiItem te = SimpleGuiItem - { siHighlight = [] - , siNodes = flatten.ttree $ te - , siDiagnostic = [] - , siFullSem = tsemantics te - , siIdname = idname te } - -renameNodesWithTidnum :: TagElem -> (TagElem, Tree NodeName) -renameNodesWithTidnum te = - ( te { ttree = mapTree' renameNode theTree } - , mapTree' newName theTree ) - where theTree = ttree te - renameNode n = n { gnname = newName n } - newName n = gnname n ++ "-" ++ tidstr - tidstr = show . tidnum $ te -\end{code} - -% -------------------------------------------------------------------- -\section{Generate} -% -------------------------------------------------------------------- - -\subsection{One-phase generation} - -This is a standard chart-and-agenda mechanism, where each iteration -consists of picking an item off the agenda and combining it with -elements from the chart. - -\begin{code} -generateStep_1p :: SimpleState () -generateStep_1p = - do isDone <- gets (null.theAgenda) - iaf <- gets (hasOpt Iaf .genconfig) - let dispatch = mapM (simpleDispatch_1p iaf) - if isDone - then return () - else do incrCounter num_iterations 1 - given <- selectGiven - -- do both substitution and adjunction - applySubstitution1p given >>= dispatch - passiveAdjunction1p given >>= dispatch - activeAdjunction1p given >>= dispatch - sansAdjunction1p given >>= dispatch - -- determine which of the res should go in the agenda - -- (monadic state) and which should go in the result (res') - addToChart given -\end{code} - -\subsection{Two-phase generation} - -Following \cite{carroll1999ecg}, we could also separate realisation into -two distinct phases. This requires that we maintain two seperate -agendas and process them sequentially, one loop after the other. See -\fnref{switchToAux} for details. - -\begin{itemize} -\item If both Agenda and AuxAgenda are empty then there is nothing to do, - otherwise, if Agenda is empty then we switch to the application of the - Adjunction rule. -\item After the rule is applied we classify solutions into those that are complete - and cover the semantics and those that don't. The first ones are returned - and added to the result, while the others are sent back to Agenda. -\item Notice that if we are applying the Substitution rule then the - current agenda item is added to the chart, otherwise it is deleted. -\end{itemize} - -\begin{code} -generateStep_2p :: SimpleState () -generateStep_2p = do - nir <- gets (null.theAgenda) - curStep <- gets step - case curStep of - SubstitutionPhase -> if nir then switchToAux else generateStep_2p_sub - AdjunctionPhase -> if nir then return () else generateStep_2p_adj - -generateStep_2p_sub :: SimpleState () -generateStep_2p_sub = - do incrCounter num_iterations 1 - -- choose an item from the agenda - given <- selectGiven - res <- applySubstitution given - mapM_ simpleDispatch_2p res - -- put the given into the chart untouched - addToChart given - -generateStep_2p_adj :: SimpleState () -generateStep_2p_adj = - do incrCounter num_iterations 1 - -- choose an item from the agenda - given <- selectGiven - res <- liftM2 (++) (applyAdjunction2p given) (sansAdjunction2p given) - mapM_ simpleDispatch_2p_adjphase res - when (adjdone given) $ trashIt given -\end{code} - -\subsection{Helpers for the generateSteps} - -\begin{code} -trashIt :: SimpleItem -> SimpleState () -trashIt item = - do disableGui <- gets (hasFlagP DisableGuiFlg . genconfig) - unless disableGui $ do - s <- get - let bmap = semBitMap s - itemSem = siSemantics item - inputSem = tsem s - reason = if inputSem == itemSem - then "unknown reason!" - else ts_semIncomplete $ bitVectorToSem bmap $ inputSem `xor` itemSem - addToTrash item reason - --- | Arbitrarily selects and removes an element from the agenda and --- returns it. -selectGiven :: SimpleState SimpleItem -selectGiven = do - agenda <- gets theAgenda - case agenda of - [] -> geniBug "null agenda in selectGiven" - (a:atail) -> updateAgenda atail >> return a -\end{code} - -\subsection{Switching phases} - -After the substitution and na-constraint phases are complete, we switch to the -final adjunction phase. We do this by deleting junk from the agenda -(particularly, trees with open substitution sites remaining), transfering trees -from the holding pen to the chart and setting the phase to AdjunctionPhase - -\begin{code} -switchToAux :: SimpleState () -switchToAux = do - st <- get - let oldAuxTrees = theHoldingPen st - config = genconfig st - -- You might be wondering why we ignore the auxiliary trees in the - -- chart; this is because all the syntactically complete auxiliary - -- trees have already been filtered away by calls to classifyNew - initialT = filter siInitial (theChart st) - (compT1, incompT1) = partition (null.siSubstnodes) initialT - -- - (auxTrees, compT2) = - if hasOpt EarlyNa config - then ( mapMaybe (detectNa oldAuxTrees) oldAuxTrees - , mapMaybe (detectNa auxTrees) compT1 ) - else ( oldAuxTrees, compT1 ) - -- - (compT3, incompT3) = - if hasOpt SemFiltered config - then semfilter (tsem st) auxTrees compT2 - else (compT2, []) - -- - compT = compT3 - -- the root cat filter by Claire - put st{ theAgenda = [] - , theHoldingPen = [] - , theChart = auxTrees - , step = AdjunctionPhase } - mapM_ simpleDispatch_2p_adjphase compT - -- toss the syntactically incomplete stuff in the trash - mapM_ (\t -> addToTrash t ts_synIncomplete) incompT1 - mapM_ (\t -> addToTrash t "sem-filtered") incompT3 -\end{code} - -\subsubsection{SemFilter Optimisation} -\label{sec:semfilter} - -The purpose of the semantic filter optimisation is to take full -advantage of Carroll's delayed adjunction. Consider the semantics -\semexpr{def(m), poor(m), brokenhearted(m), man(m), def(w), woman(w), -beautiful(w), heartless(w), rejects(w,m)}. At the switchToAux step, we -are left with the initial trees \natlang{man}, \natlang{woman}, \natlang{the - woman rejects the man}. - -It would be nice to filter out the structures \natlang{man} and \natlang{woman} -since we know that they are not going to be semantically complete even with -adjunction. More precisely, on the switch to adjunction, we do the following: - -\begin{itemize} -\item Take the union of the semantics of all auxiliary trees; which - we call $\phi^*$ -\item Delete any initial tree with semantics $\phi^s$ such that - $\phi^s \cup \phi^*$ is not the target semantics -\end{itemize} - -In other words, we delete all initial trees that cannot produce a semantically -complete result even with the help of auxiliary trees. - -FIXME: comment 2006-04-18: sem filter each polarity path separately (this is -more aggressive; it gives us much more filtering) - -\begin{code} -semfilter :: BitVector -> [SimpleItem] -> [SimpleItem] -> ([SimpleItem], [SimpleItem]) -semfilter inputsem auxs initial = - let auxsem x = foldl' (.|.) 0 [ siSemantics a | a <- auxs, siPolpaths a .&. siPolpaths x /= 0 ] - -- lite, here, means sans auxiliary semantics - notjunk x = (siSemantics x) .&. inputsemLite == inputsemLite - where inputsemLite = inputsem `xor` (auxsem x) - -- note that we can't just compare against siSemantics because - -- that would exclude trees that have stuff in the aux semantics - -- which would be overzealous - in partition notjunk initial -\end{code} - -% -------------------------------------------------------------------- -\section{Operations} -% -------------------------------------------------------------------- - -We implement the two TAG operations, substitution and adjunction, below. -These are the only two operations we have, because we're working with a -very simple builder that constructs derived trees. - -% -------------------------------------------------------------------- -\subsection{Substitution} -\label{sec:substitution} -% -------------------------------------------------------------------- - -\paragraph{applySubstitution} Given a SimpleItem it returns the list of all -possible substitutions between it and the elements in Chart - -\begin{code} -applySubstitution :: SimpleItem -> SimpleState ([SimpleItem]) -applySubstitution item = - do gr <- lookupChart item - active <- mapM (\x -> iapplySubst True item x) gr - passive <- mapM (\x -> iapplySubst True x item) gr - let res = concat $ active ++ passive - incrCounter num_comparisons (2 * (length gr)) - return res - -applySubstitution1p :: SimpleItem -> SimpleState ([SimpleItem]) -applySubstitution1p item = - do gr <- lookupChart item - active <- if adjdone item then return [] - else mapM (\x -> iapplySubst False item x) gr - passive <- mapM (\x -> iapplySubst False x item) $ filter adjdone gr - let res = concat $ active ++ passive - incrCounter num_comparisons (2 * (length gr)) - return res - --- | Note: returns ONE possible substitution (the head node) --- of the first in the second. As all substitutions nodes should --- be substituted we force substitution in order. -iapplySubst :: Bool -> SimpleItem -> SimpleItem -> SimpleState [SimpleItem] -iapplySubst twophase item1 item2 | siInitial item1 && closed item1 = {-# SCC "applySubstitution" #-} - case siSubstnodes item2 of - [] -> return [] - ((TagSite n fu fd nOrigin) : stail) -> - let doIt = - do -- Maybe monad - let r@(TagSite rn ru rd rOrigin) = siRoot item1 - (newU, subst1) <- unifyFeat ru fu - (newD, subst2) <- unifyFeat (replace subst1 rd) - (replace subst1 fd) - let subst = mergeSubst subst1 subst2 - nr = TagSite rn newU newD rOrigin - adj1 = nr : (delete r $ siAdjnodes item1) - adj2 = siAdjnodes item2 - item1g = item1 { siGuiStuff = g2 } - where g2 = g { siNodes = repList (gnnameIs rn) newRoot (siNodes g) } - g = siGuiStuff item1 - -- gui stuff - newRoot g = g { gup = newU, gdown = newD, gtype = Other } - let pending = if twophase then [] - else nr : (siPendingTb item1 ++ siPendingTb item2) - return $! replace subst $ combineSimpleItems [rn] item1g $ - item2 { siSubstnodes = stail ++ (siSubstnodes item1) - , siAdjnodes = adj2 ++ adj1 - , siDerived = plugTree (siDerived item1) n (siDerived item2) - , siDerivation = addToDerivation 's' (item1g,rOrigin) (item2,nOrigin,n) - , siLeaves = (siLeaves item1) ++ (siLeaves item2) - , siPendingTb = pending - } - in case doIt of - Nothing -> return [] - Just x -> do incrCounter "substitutions" 1 - return [x] -iapplySubst _ _ _ = return [] -\end{code} - -% -------------------------------------------------------------------- -\subsection{Adjunction} -\label{sec:adjunction} -\label{sec:ordered_adjunction} -\label{sec:foot_constraint} -% --------------------------------------------------------------- - -\paragraph{applyAdjunction2p} Given a SimpleItem, it returns the list of all -possible adjunctions between it and the elements in Chart. -The Chart contains Auxiliars, while SimpleItem is an Initial - -Note: as of 13 april 2005 - only uses ordered adjunction as described in -\cite{kow04a} -\begin{code} -applyAdjunction2p :: SimpleItem -> SimpleState ([SimpleItem]) -applyAdjunction2p item = {-# SCC "applyAdjunction2p" #-} - do gr <-lookupChart item - incrCounter num_comparisons (length gr) - mapMaybeM (\a -> tryAdj True a item) gr - -passiveAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] -passiveAdjunction1p item | closed item && siInitial item = - do gr <- lookupChart item - mapMaybeM (\a -> tryAdj False a item) $ filter validAux gr -passiveAdjunction1p _ = return [] - -activeAdjunction1p :: SimpleItem -> SimpleState [SimpleItem] -activeAdjunction1p item | validAux item = - do gr <- lookupChart item - mapMaybeM (\p -> tryAdj False item p) $ filter (\x -> siInitial x && closed x) gr -activeAdjunction1p _ = return [] - -validAux :: SimpleItem -> Bool -validAux t = closedAux t && adjdone t - -tryAdj :: Bool -> SimpleItem -> SimpleItem -> SimpleState (Maybe SimpleItem) -tryAdj twophase aItem pItem = - do case iapplyAdjNode twophase aItem pItem of - Just x -> do incrCounter "adjunctions" 1 - return $ Just x - Nothing -> return Nothing -\end{code} - -Note that in the one-phase variant of non-adjunction, we can't do top/bot -unification on the fly, because afaik we can't tell that a node will never -be revisited. One example of this is if you try to adjoin into the root - -\begin{code} --- | Ignore the next adjunction node -sansAdjunction1p, sansAdjunction2p :: SimpleItem -> SimpleState [SimpleItem] -sansAdjunction1p item | closed item = - case siAdjnodes item of - [] -> return [] - (ahead : atail) -> - return $ [item { siAdjnodes = atail - , siPendingTb = ahead : (siPendingTb item) } ] -sansAdjunction1p _ = return [] - --- | Ignore the next adjunction node -sansAdjunction2p item | closed item = - case siAdjnodes item of - [] -> return [] - (TagSite gn t b o: atail) -> do - -- do top/bottom unification on the node - case unifyFeat t b of - Nothing -> - do addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item) - ts_tbUnificationFailure - return [] - Just (tb,s) -> - let item1 = if isRootOf item gn - then item { siRoot = TagSite gn tb [] o } - else item - item2 = modifyGuiStuff (constrainAdj gn tb) item1 - in return $! [replace s $! item2 { siAdjnodes = atail }] -sansAdjunction2p _ = return [] -\end{code} - -The main work for adjunction is done in the helper function below -(see also figure \ref{fig:adjunction}). -Auxiliary tree \texttt{te1} has a root node \texttt{r} and a foot -node \texttt{f}. Main tree \texttt{te2} has an adjunction site \texttt{an}. -The resulting tree \texttt{res} is a result of splicing \texttt{te1} into -\texttt{te2}. We replace \texttt{s} with the nodes \texttt{anr} and -\texttt{anf} (which are the results of unifying \texttt{an} with \texttt{r} - and \texttt{f} respectively). - -\begin{figure} -\begin{center} -\includegraphics[scale=0.5]{images/adjunction.pdf} -\label{fig:adjunction} -\caption{iapplyAdjNode} -\end{center} -\end{figure} - -In addition to the trees proper, we have to consider that each tree has -a list with a copy of its adjunction sites. The adjunction list of the -result (\texttt{adjnodes res}) should then contain \texttt{adjnodes te1} -and \texttt{adjnodes te2}, but replacing \texttt{r} and \texttt{an} -with \texttt{anr}. - -\begin{code} -iapplyAdjNode :: Bool -> SimpleItem -> SimpleItem -> Maybe SimpleItem -iapplyAdjNode twophase aItem pItem = {-# SCC "iapplyAdjNode" #-} - case siAdjnodes pItem of - [] -> Nothing - (pSite : pTail) -> do - -- let's go! - (anr, anf, subst12) <- canAdjoin aItem pSite - let r = siRoot aItem - f <- siFoot aItem - let an_name = tsName pSite - -- the new adjunction nodes - auxlite = delete r $ siAdjnodes aItem - newadjnodes = anr : (pTail ++ auxlite) - -- Ugh, this is horrible: this is just to make sure the GUI gets - -- updated accordingly. The code used to be a lot simpler, but - -- I started trying to move stuff out of the way in the interests - -- of efficiency, and to pack as much gui-related stuff as possible - -- into a single tuple. - aItem2 = aItem { siGuiStuff = fixNodes $ siGuiStuff aItem } - where fixNodes g = g { siNodes = map (setSites anr) (siNodes g) } - setSites (TagSite n u d _) gn = - if gnname gn == n then gn { gup = u, gdown = d } - else gn - rawCombined = - combineSimpleItems [tsName r, an_name] aItem2 $ pItem - { siAdjnodes = newadjnodes - , siLeaves = siLeaves aItem ++ siLeaves pItem - , siDerived = spliceTree (tsName f) (siDerived aItem) an_name (siDerived pItem) - , siDerivation = addToDerivation 'a' (aItem,tsOrigin r) (pItem,tsOrigin pSite,an_name) - -- , siAdjlist = (n, (tidnum te1)):(siAdjlist item2) - -- if we adjoin into the root, the new root is that of the aux - -- tree (affects 1p only) - , siRoot = if isRootOf pItem an_name then r else siRoot pItem - , siPendingTb = - if twophase then [] - else anf : (siPendingTb pItem) ++ (siPendingTb aItem) - } - -- one phase = postpone tb unification - -- two phase = do tb unification on the fly - finalRes1p = return $ replace subst12 rawCombined - finalRes2p = - do -- tb on the former foot - tbRes <- unifyFeat (tsUp anf) (tsDown anf) - let (anf_tb, subst3) = tbRes - myRes = modifyGuiStuff (constrainAdj an_name anf_tb) res' - -- apply the substitutions - res' = replace (mergeSubst subst12 subst3) rawCombined - return myRes - -- --------------- - if twophase then finalRes2p else finalRes1p - --- Note that we do not propagate variable substitutions in the nodes we return -canAdjoin :: SimpleItem -> TagSite -> Maybe (TagSite, TagSite, Subst) -canAdjoin aItem pSite = do - -- let's go! - let r = siRoot aItem -- auxiliary tree, eh? - f <- siFoot aItem -- should really be an error if fails - (anr_up', subst1) <- unifyFeat (tsUp r) (tsUp pSite) - (anf_down, subst2) <- unifyFeat (replace subst1 $ tsDown f) (replace subst1 $ tsDown pSite) - let -- combined substitution list and success condition - subst12 = mergeSubst subst1 subst2 - anr = replace subst12 $ r { tsUp = anr_up' } - anf = replace subst12 $ pSite { tsDown = anf_down } - return (anr, anf, subst12) -\end{code} - -\begin{code} -detectNa :: [SimpleItem] -- ^ aux trees - -> SimpleItem -- ^ me - -> Maybe SimpleItem -detectNa rawAux i = helper (siAdjnodes i) Map.empty [] - where - compatAux = filterCompatible i rawAux - helper [] s acc = Just $ replace s $ i { siAdjnodes = acc } - helper (t:ts) s acc = - let hasAdj = any isJust $ map (\a -> canAdjoin a t) compatAux - in case (snd `fmap` unifyFeat (tsUp t) (tsDown t)) of - Just s2 -> if hasAdj - then helper ts s (t : acc) - else helper (replace s2 ts) (mergeSubst s s2) acc - Nothing -> if hasAdj - then helper ts s (t : acc) - else Nothing -\end{code} - -% -------------------------------------------------------------------- -\subsection{Helper functions for operations} -% -------------------------------------------------------------------- - -\begin{code} -ncopy :: GNode -> TagSite -ncopy x = TagSite (gnname x) (gup x) (gdown x) (gorigin x) - -isRootOf :: SimpleItem -> String -> Bool -isRootOf item n = n == rname - where (TagSite rname _ _ _) = siRoot item - --- | Retrieves a list of trees from the chart which could be combined with the given agenda tree. --- The current implementation searches for trees which --- * do not have overlapping semantics with the given --- * are on the some of the same polarity automaton paths as the --- current agenda item -lookupChart :: SimpleItem -> SimpleState [SimpleItem] -lookupChart given = gets (filterCompatible given . theChart) - -filterCompatible :: SimpleItem -> [SimpleItem] -> [SimpleItem] -filterCompatible given chart = - [ i | i <- chart - -- should be on the same polarity path (chart sharing) - , (siPolpaths i) .&. gpaths /= 0 - -- semantics should not be overlapping - && (siSemantics i .&. gsem ) == 0 - ] - where - gpaths = siPolpaths given - gsem = siSemantics given - --- | Helper function for when chart operations succeed. -combineSimpleItems :: [NodeName] -- ^ nodes to highlight - -> SimpleItem -> SimpleItem -> SimpleItem -combineSimpleItems hi item1 item2 = {-# SCC "combineSimpleItems" #-} - item2 { siSemantics = siSemantics item1 .|. siSemantics item2 - , siPolpaths = siPolpaths item1 .&. siPolpaths item2 - , siGuiStuff = combineSimpleGuiItems hi (siGuiStuff item1) (siGuiStuff item2) - } - -combineSimpleGuiItems :: [NodeName] - -> SimpleGuiItem -> SimpleGuiItem -> SimpleGuiItem -combineSimpleGuiItems hi item1 item2 = - item2 { siFullSem = sortSem $ siFullSem item1 ++ siFullSem item2 - , siNodes = siNodes item1 ++ siNodes item2 - , siDiagnostic = siDiagnostic item1 ++ siDiagnostic item2 - , siHighlight = hi - } - -constrainAdj :: String -> Flist -> SimpleGuiItem -> SimpleGuiItem -constrainAdj gn newT g = - g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) } - where fixIt n = n { gup = newT, gdown = [], gaconstr = True } -\end{code} - -\subsubsection{Derivation trees} - -We make the simplifying assumption that each chart item is only used once. -This is clearly wrong if we allow for items with an empty semantics, but -since we do not actually allow such a thing, we're ok. - -\begin{code} -addToDerivation :: Char - -> (SimpleItem,String) - -> (SimpleItem,String,String) - -> TagDerivation -addToDerivation op (tc,tcOrigin) (tp,tpOrigin,tpSite) = - let hp = siDerivation tp - hc = siDerivation tc - newnode = DerivationStep op tcOrigin tpOrigin tpSite - in newnode:hp++hc -\end{code} - - - -% -------------------------------------------------------------------- -\section{Dispatching new results} -% -------------------------------------------------------------------- - -Dispatching is the process where new chart items are assigned to one of -the trash, agenda, auxiliary agenda or chart. The item could be -modified during dispatch-time; for example, we might do top/bottom -unification on it. See \ref{sec:dispatching} for more details. - -\begin{code} -type SimpleDispatchFilter = DispatchFilter SimpleState SimpleItem - -simpleDispatch_2p :: SimpleDispatchFilter -simpleDispatch_2p = - simpleDispatch (dpRootFeatFailure >--> dpToResults) - (dpAux >--> dpToAgenda) - -simpleDispatch_2p_adjphase :: SimpleDispatchFilter -simpleDispatch_2p_adjphase = - simpleDispatch (dpRootFeatFailure >--> dpToResults) - dpToAgenda - -simpleDispatch_1p :: Bool -> SimpleDispatchFilter -simpleDispatch_1p iaf = - simpleDispatch (dpRootFeatFailure >--> dpTbFailure >--> dpToResults) - (maybeDpIaf >--> dpToAgenda) - where maybeDpIaf = if iaf then dpIafFailure else nullFilter - -simpleDispatch :: SimpleDispatchFilter -> SimpleDispatchFilter -> SimpleDispatchFilter -simpleDispatch resFilter nonResFilter item = - do inputsem <- gets tsem - let synComplete x = siInitial x && closed x && adjdone x - semComplete x = inputsem == siSemantics x - isResult x = synComplete x && semComplete x - condFilter isResult resFilter nonResFilter item - -dpAux, dpToAgenda :: SimpleDispatchFilter -dpTbFailure, dpToResults :: SimpleDispatchFilter -dpToTrash :: String -> SimpleDispatchFilter - -dpToAgenda x = addToAgenda x >> return Nothing -dpToResults x = addToResults x >> return Nothing -dpToTrash m x = addToTrash x m >> return Nothing - -dpAux item = - if closedAux item - then addToAuxAgenda item >> return Nothing - else return $ Just item - -{- --- | Dispatches to the trash and returns Nothing if there is a tree --- size limit in effect and the item is over that limit. The --- tree size limit is used in 'IgnoreSemantics' mode. -dpTreeLimit item = - do config <- gets genconfig - case maxTrees config of - Nothing -> return $ Just item - Just lim -> if (length.snd.siDerivation) item > lim - then do addToTrash item (ts_overnumTrees lim) - return Nothing - else return $ Just item - where ts_overnumTrees l = "Over derivation size of " ++ (show l) --} - --- | This is only used for the one-phase algorithm -dpTbFailure item = - return $ if tbUnifyTree item then Just item else Nothing - --- | If the item (ostensibly a result) does not have the correct root --- category, return Nothing; otherwise return Just item -dpRootFeatFailure :: SimpleDispatchFilter -dpRootFeatFailure item = - do config <- gets genconfig - let rootFeat = getListFlagP RootFeatureFlg config - (TagSite _ top _ _) = siRoot item - case unifyFeat rootFeat top of - Nothing -> - dpToTrash (ts_rootFeatureMismatch rootFeat) item - Just (_, s) -> - return . Just $ replace s item -\end{code} -% -------------------------------------------------------------------- -\subsection{Top and bottom unification} -% -------------------------------------------------------------------- - -\paragraph{tbUnifyTree} unifies the top and bottom feature structures -of each node on each tree. Note: this only determines if it is -possible to do so. Actually returning the results is possible -and even easy -(you'll have to look back into the darcs repository and unpull the - patch from 2006-05-21T15:40:51 ``Remove top/bot unification standalone - code.'') -but since it is only used in the one-phase algorithm and for the -graphical interface, I decided not to bother. - -\begin{code} -type TbEither = Either String Subst -tbUnifyTree :: SimpleItem -> Bool -tbUnifyTree item = {-# SCC "tbUnifyTree" #-} - case foldl' tbUnifyNode (Right Map.empty) (siPendingTb item) of - Left _ -> False - Right _ -> True -\end{code} - -Our helper function corresponds to the first unification step. It is -meant to be called from a fold. The node argument represents the -current node being explored. The Either argument holds a list of -pending substitutions and a copy of the entire tree. - -There are two things going on in here: - -\begin{enumerate} -\item check if unification is possible - first we apply the pending - substitutions on the node and then we check if unification - of the top and bottom feature structures of that node - succeeds -\item keep track of the substitutions that need to be performed - - any new substitutions that result from unification are - added to the pending list -\end{enumerate} - -Note that we wrap the second argument in a Maybe; this is used to -indicate that if unification suceeds or fails. We also use it to -prevent the function from doing any work if a unification failure -from a previous call has already occured. - -Getting this right was a big pain in the butt, so don't go trying to -simplify this over-complicated code unless you know what you're doing. - -\begin{code} -tbUnifyNode :: TbEither -> TagSite -> TbEither -tbUnifyNode (Right pending) rawSite = - -- apply pending substitutions - case replace pending rawSite of - (TagSite name up down _) -> - -- check top/bottom unification on this node - case unifyFeat up down of - -- stop all future iterations - Nothing -> Left name - -- apply any new substutions to the whole tree - Just (_,sb) -> Right (mergeSubst pending sb) - --- if earlier we had a failure, don't even bother -tbUnifyNode (Left n) _ = Left n -\end{code} - -% -------------------------------------------------------------------- -\subsection{Index accesibility filtering} -\label{sec:simple:iaf} -% -------------------------------------------------------------------- - -Note that index accesibility filtering only makes sense for the one-phase -algorithm. See also \ref{sec:iaf} for more details about what this is. - -\begin{code} -instance IafAble SimpleItem where - iafAcc = siAccesible - iafInacc = siInaccessible - iafSetAcc a i = i { siAccesible = a } - iafSetInacc a i = i { siInaccessible = a } - iafNewAcc i = - concatMap fromUniConst $ - concat [ getIdx up | (TagSite _ up _ _) <- siSubstnodes i ] - -dpIafFailure :: SimpleDispatchFilter -dpIafFailure item | aux item = return $ Just item -dpIafFailure itemRaw = - do s <- get - let bmap = semBitMap s - item = recalculateAccesibility itemRaw - badSem = iafBadSem (theIafMap s) bmap (tsem s) siSemantics item - inAcc = iafInacc item - if badSem == 0 - then -- can't dispatch, but that's good! - -- (note that we return the item with its iaf criteria updated) - return $ Just item - else dpToTrash (ts_iafFailure inAcc $ bitVectorToSem bmap badSem) item -\end{code} - - -% -------------------------------------------------------------------- -\section{Unpacking the results} -% -------------------------------------------------------------------- - -Unpacking the results consists of converting each result into a sentence -automaton (to take care of atomic disjunction) and reading the paths of -each automaton. - -\begin{code} -unpackResults :: [SimpleItem] -> [B.Output] -unpackResults = concatMap unpackResult - -unpackResult :: SimpleItem -> [B.Output] -unpackResult item = - let leafMap :: Map.Map String B.UninflectedDisjunction - leafMap = Map.fromList . siLeaves $ item - lookupOrBug :: NodeName -> B.UninflectedDisjunction - lookupOrBug k = case Map.lookup k leafMap of - Nothing -> geniBug $ "unpackResult : could not find node " ++ k - Just w -> w - derivation = siDerivation item - paths = automatonPaths . listToSentenceAut $ - [ lookupOrBug k | (k,_) <- (preTerminals . siDerived) item ] - in zip paths (repeat derivation) -\end{code} - -\subsection{Sentence automata} - -\fnlabel{listToSentenceAut} converts a list of GNodes into a sentence -automaton. It's a actually pretty stupid conversion in fact. We pretty -much make a straight path through the automaton, with the only -cleverness being that we provide a different transition for each -atomic disjunction. - -\begin{code} -listToSentenceAut :: [ B.UninflectedDisjunction ] -> B.SentenceAut -listToSentenceAut nodes = - let theStart = 0 - theEnd = length nodes - 1 - theStates = [theStart..theEnd] - -- - emptyAut = NFA - { startSt = theStart - , isFinalSt = Nothing - , finalStList = [theEnd] - , states = [theStates] - , transitions = Map.empty } - -- create a transition for each lexeme in the node to the - -- next state... - helper :: (Int, B.UninflectedDisjunction) -> B.SentenceAut -> B.SentenceAut - helper (current, B.UninflectedDisjunction lemmas features) aut = - foldl' addT aut lemmas - where - addT a t = addTrans a current (Just (LemmaPlus t features)) next - next = current + 1 - -- - in foldr helper emptyAut (zip theStates nodes) -\end{code} - -% -------------------------------------------------------------------- -\section{Partial results} -% -------------------------------------------------------------------- - -The user may ask for partial results when realisation fails. We implement this -using a greedy, full-commitment algorithm. Find the discarded result that -matches the largest part of the semantics and output that fragment. If there -are parts of the input semantics not covered by that fragment, search for the -largest chunk that covers the missing semantics. Recurse until there are no -more eligible items. - -\begin{code} -partialResults :: SimpleStatus -> [SimpleItem] -partialResults st = unfoldr getNext 0 - where - inputsem = tsem st - trash = theTrash st - trashC = sortBy (comparing $ negate . fst) $ - map (\t -> (coverage inputsem t, t)) trash - getNext sem = case getItems sem of - [] -> Nothing - (it:_) -> Just (it, siSemantics it .|. sem) - getItems sem = [ i | (_,i) <- trashC, siSemantics i .&. sem == 0 ] - -coverage :: BitVector -> SimpleItem -> Int -coverage sem it = countBits (sem .&. siSemantics it) - -countBits :: Bits a => a -> Int -countBits 0 = 0 -countBits bs = if testBit bs 0 then 1 + next else next - where next = countBits (shiftR bs 1) -\end{code} - -% -------------------------------------------------------------------- -% Performance -% -------------------------------------------------------------------- - -\begin{code} -{- -instance NFData SimpleItem where - rnf (SimpleItem x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 - ) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 - `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 - `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 - `seq` rnf x14 --} -\end{code} - diff --git a/src/NLP/GenI/Simple/SimpleGui.lhs b/src/NLP/GenI/Simple/SimpleGui.lhs deleted file mode 100644 --- a/src/NLP/GenI/Simple/SimpleGui.lhs +++ /dev/null @@ -1,208 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Simple GUI} - -\begin{code} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module NLP.GenI.Simple.SimpleGui where -\end{code} - -\ignore{ -\begin{code} -import Graphics.UI.WX - -import Control.Arrow ( (&&&) ) -import Data.IORef -import qualified Data.Map as Map - -import NLP.GenI.Statistics (Statistics) - -import NLP.GenI.Btypes (GNode(gnname, gup), AvPair(..), emptyGNode, GeniVal(GConst)) -import NLP.GenI.Configuration ( Params(..) ) -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, GraphvizGuiSt(..), - viewTagWidgets, XMGDerivation(getSourceTrees), - ) -import NLP.GenI.Tags (tsemantics, DerivationStep(dsChild), TagElem(idname, ttree), TagItem(..), emptyTE) -import NLP.GenI.GraphvizShow ( graphvizShowDerivation ) - -import qualified NLP.GenI.Builder as B -import NLP.GenI.Builder (LemmaPlus(..)) -import qualified NLP.GenI.BuilderGui as BG -import NLP.GenI.Polarity -import NLP.GenI.Simple.SimpleBuilder - ( simpleBuilder, SimpleStatus, SimpleItem(..), SimpleGuiItem(..) - , unpackResult - , step, theResults, theAgenda, theHoldingPen, 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 (Just &&& siToSentence) 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 "HOLDING" $ theHoldingPen st - trash = section "TRASH" $ theTrash st - chart = section "CHART" $ theChart st - results = section "RESULTS" $ theResults st - -- - section n i = hd : (map tlFn i) - where hd = (Nothing, "___" ++ n ++ "___") - tlFn x = (Just x, siToSentence x ++ (showPaths $ siPolpaths x)) - showPaths t = " (" ++ showPolPaths t ++ ")" - in concat [ agenda, auxAgenda, chart, trash, results ] - -simpleItemBar :: Params -> DebuggerItemBar SimpleStatus Bool SimpleItem -simpleItemBar pa f gvRef updaterFn = - do ib <- panel f [] - phaseTxt <- staticText ib [ text := "" ] - 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 ] - -- - let lay = hfloatCentre . container ib . row 5 $ - [ hspace 5 - , widget phaseTxt - , hglue - , widget detailsChk - , hglue - , viewTagLay - , hspace 5 ] - let onUpdate = - do status <- gvcore `fmap` readIORef gvRef - set phaseTxt [ text := show (step status) ] - return (lay, onUpdate) -\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 dsChild . 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 = [ AvPair "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 lpLemma . fst $ h -\end{code} diff --git a/src/NLP/GenI/Statistics.hs b/src/NLP/GenI/Statistics.hs --- a/src/NLP/GenI/Statistics.hs +++ b/src/NLP/GenI/Statistics.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} ---------------------------------------------------- -- -- -- Statistics.hs: -- @@ -29,7 +28,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -} - +{-# LANGUAGE FlexibleContexts, RankNTypes #-} module NLP.GenI.Statistics(Statistics, StatisticsState, emptyStats, @@ -46,6 +45,8 @@ import Data.Maybe (mapMaybe) import Text.JSON +import Control.DeepSeq + ------------------------------------------- -- Statistics are collections of Metrics -- which can be printed out (at regular intervals) @@ -103,3 +104,20 @@ -- not quite showJSON here metricToJSON :: Metric -> (String, JSValue) metricToJSON (IntMetric s i) = (s, showJSON i) + +{-! +deriving instance NFData Statistics +deriving instance NFData Metric +!-} + + +-- GENERATED START + + +instance NFData Statistics where + rnf (Stat x1) = rnf x1 `seq` () + + +instance NFData Metric where + rnf (IntMetric x1 x2) = rnf x1 `seq` rnf x2 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/SysGeni.hs b/src/NLP/GenI/SysGeni.hs deleted file mode 100644 --- a/src/NLP/GenI/SysGeni.hs +++ /dev/null @@ -1,77 +0,0 @@ --- GenI surface realiser --- Copyright (C) 2005 Carlos Areces and Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -{-# LANGUAGE ForeignFunctionInterface #-} - --- | 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 @../Resources/bin@ --- to the path for the miscellaneous resources that we ship with with GenI. -module NLP.GenI.SysGeni -where - -import qualified System.Process as S - -import Data.List (isSuffixOf) -import System.FilePath -import System.IO (Handle) -import System.Exit (ExitCode) - -#ifdef __GLASGOW_HASKELL__ -import Foreign -import Foreign.C -import Control.Monad -#include "ghcconfig.h" -#endif - --- * Running a process - -waitForProcess :: S.ProcessHandle -> IO ExitCode -waitForProcess = S.waitForProcess - --- | 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 @../Resources/bin@. -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 - --- * Process helpers - -foreign import ccall unsafe "getProgArgv" - getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - -getProgDirName :: IO String -getProgDirName = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - getProgArgv p_argc p_argv - argv <- peek p_argv - s <- peekElemOff argv 0 >>= peekCString - return $ takeDirectory s diff --git a/src/NLP/GenI/Tag.hs b/src/NLP/GenI/Tag.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Tag.hs @@ -0,0 +1,396 @@ +-- GenI surface realiser +-- Copyright (C) 2005 Carlos Areces and Eric Kow +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +-- | This module provides basic datatypes specific to Tree Adjoining Grammar +-- (TAG) elementary trees and some low-level operations. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module NLP.GenI.Tag ( + -- Main Datatypes + Tags, TagElem(..), TagItem(..), TagSite(..), + TagDerivation, DerivationStep(..), dsChild, dsParent, dsParentSite, + ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure, + ts_rootFeatureMismatch, + + -- Functions from Tags + addToTags, tagLeaves, getLexeme, toTagSite, + + -- Functions from TagElem + setTidnums, plugTree, spliceTree, + + -- General functions + mapBySem, + collect, detectSites, +) where + +import Control.Applicative ( (<$>), (<*>) ) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, catMaybes) +import Data.Tree +import Data.Text ( Text ) +import qualified Data.Text as T + +import Control.DeepSeq +import Data.Generics (Data) +import Data.Typeable (Typeable) +import Data.FullList hiding ( (++) ) +import Text.JSON + +import NLP.GenI.FeatureStructure ( AvPair(..), Flist ) +import NLP.GenI.General (listRepNode, groupByFM, preTerminals, geniBug) +import NLP.GenI.GeniShow +import NLP.GenI.GeniVal ( GeniVal(..), DescendGeniVal(..), Collectable(..), Idable(..), + isConst, + ) +import NLP.GenI.Polarity.Types ( PolarityKey(..), SemPols ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( Sem, Literal(..), emptyLiteral ) +import NLP.GenI.TreeSchema + ( Ptype(..), GNode(..), GType(..), NodeName, lexemeAttributes ) + +-- ---------------------------------------------------------------------- +-- Tags +-- ---------------------------------------------------------------------- + +-- | An anchored grammar. +-- The grammar associates a set of semantic predicates to a list of trees each. +type Tags = Map.Map String [TagElem] + +-- | 'addTags' @tags key elem@ adds @elem@ to the the list of elements associated +-- to the key +addToTags :: Tags -> String -> TagElem -> Tags +addToTags t k e = Map.insertWith (++) k [e] t + +-- ---------------------------------------------------------------------- +-- TagElem +-- ---------------------------------------------------------------------- + +data TagSite = TagSite + { tsName :: Text + , tsUp :: Flist GeniVal + , tsDown :: Flist GeniVal + , tsOrigin :: Text + } + deriving (Eq, Ord, Data, Typeable) + +data TagElem = TE + { idname :: Text + , ttreename :: Text + , tidnum :: Integer + , ttype :: Ptype + , ttree :: Tree (GNode GeniVal) + , tsemantics :: Sem + -- optimisation stuff + -- (polarity key to charge interval) + , tpolarities :: Map.Map PolarityKey (Int,Int) + , tinterface :: Flist GeniVal -- for idxconstraints (pol) + , ttrace :: [Text] + , tsempols :: [SemPols] -- ^ can be empty + } + deriving (Eq, Data, Typeable) + +-- | Given a tree(GNode) returns a list of substitution or adjunction +-- nodes, as well as remaining nodes with a null adjunction constraint. +detectSites :: Tree (GNode GeniVal) -> ([NodeName], [NodeName], [NodeName]) +detectSites t = + ( sites isSub -- for substitution + , sites (not.gaconstr) -- for adjunction + , sites constrButNotSub -- for neither + ) + where + ns = flatten t + sites match = map gnname . filter match $ ns + isSub n = gtype n == Subs + constrButNotSub n = gaconstr n && (not $ isSub n) + +toTagSite :: GNode GeniVal -> TagSite +toTagSite n = TagSite (gnname n) (gup n) (gdown n) (gorigin n) + +type TagDerivation = [ DerivationStep ] + +data DerivationStep = SubstitutionStep Text Text Text + | AdjunctionStep Text Text Text + | InitStep Text + deriving (Show, Ord, Eq) + +dsOp :: DerivationStep -> Char +dsOp (SubstitutionStep {}) = 's' +dsOp (AdjunctionStep {}) = 'a' +dsOp (InitStep {}) = 'i' + +dsChild :: DerivationStep -> Text +dsChild (SubstitutionStep c _ _) = c +dsChild (AdjunctionStep c _ _ ) = c +dsChild (InitStep c) = c + +dsParent :: DerivationStep -> Maybe Text +dsParent (SubstitutionStep _ p _) = Just p +dsParent (AdjunctionStep _ p _) = Just p +dsParent (InitStep _) = Nothing + +dsParentSite :: DerivationStep -> Maybe Text +dsParentSite (SubstitutionStep _ _ s) = Just s +dsParentSite (AdjunctionStep _ _ s) = Just s +dsParentSite (InitStep _) = Nothing + +instance JSON DerivationStep where + readJSON j = do + jo <- fromJSObject `fmap` readJSON j + let field x = maybe (fail $ "Could not find: " ++ x) readJSON + $ lookup x jo + op <- field "op" + child <- field "child" + case op of + "s" -> AdjunctionStep child <$> field "parent" <*> field "parent-node" + "a" -> SubstitutionStep child <$> field "parent" <*> field "parent-node" + "i" -> return (InitStep child) + x -> fail $ "Don't know about derivation operation '" ++ x ++ "'" + showJSON x = + JSObject . toJSObject $ [ ("op", showJSON $ dsOp x) + , ("child", showJSON $ dsChild x) + ] ++ catMaybes + [ (\v -> ("parent", showJSON v)) <$> dsParent x + , (\v -> ("parent-node", showJSON v)) <$> dsParentSite x + ] + +instance Ord TagElem where + compare t1 t2 = + case (ttype t1, ttype t2) of + (Initial, Initial) -> compareId + (Initial, Auxiliar) -> LT + (Auxiliar, Initial) -> GT + (Auxiliar, Auxiliar) -> compareId + where compareId = compare (tidnum t1) (tidnum t2) + +instance DescendGeniVal TagElem where + descendGeniVal s te = + te { tinterface = descendGeniVal s (tinterface te) + , ttree = descendGeniVal s (ttree te) + , tsemantics = descendGeniVal s (tsemantics te) } + +instance DescendGeniVal TagSite where + descendGeniVal s (TagSite n fu fd o) = TagSite n (descendGeniVal s fu) (descendGeniVal s fd) o + +instance Collectable TagElem where + collect t = (collect $ tinterface t) . (collect $ ttree t) + . (collect $ tsemantics t) + +instance Idable TagElem where + idOf = tidnum + +-- Substitution and Adjunction + +-- | Plug the first tree into the second tree at the specified node. +-- Anything below the second node is silently discarded. +-- We assume the trees are pluggable; it is treated as a bug if +-- they are not! +plugTree :: Tree NodeName + -> NodeName + -> Tree NodeName + -> Tree NodeName +plugTree male n female = + case listRepNode (const male) (nmatch n) [female] of + ([r], True) -> r + _ -> geniBug oops + where + oops = "plugTree: unexpected plug failure at node " ++ T.unpack n + +-- | Given two trees 'auxt' and 't', splice the tree 'auxt' into +-- 't' via the TAG adjunction rule. +spliceTree :: NodeName -- ^ foot node of the aux tree + -> Tree NodeName -- ^ aux tree + -> NodeName -- ^ place to adjoin in target tree + -> Tree NodeName -- ^ target tree + -> Tree NodeName +spliceTree f auxT n top = + plugTree middle n top + where + bottom = fromMaybe (geniBug oops) (findSubTree n top) + middle = plugTree bottom f auxT + oops = unwords + [ "NLP.GenI.Tag.spliceTree:" + , "Unexpected adjunction failure." + , "Could not find node " ++ T.unpack n ++ " of target tree." + ] + +nmatch :: NodeName -> Tree NodeName -> Bool +nmatch n (Node a _) = a == n + +findSubTree :: NodeName -> Tree NodeName -> Maybe (Tree NodeName) +findSubTree n n2@(Node x ks) + | x == n = Just n2 + | otherwise = case mapMaybe (findSubTree n) ks of + [] -> Nothing + (h:_) -> Just h + +-- Unique ID + +-- | Assigns a unique id to each element of this list, that is, an integer +-- between 1 and the size of the list. +setTidnums :: [TagElem] -> [TagElem] +setTidnums xs = zipWith (\c i -> setOrigin $ c {tidnum = i}) xs [1..] + +setOrigin :: TagElem -> TagElem +setOrigin te = + te { ttree = fmap setLabel . ttree $ te } + where + setLabel g = g { gorigin = nameNumber } + nameNumber = idname te + `T.append` ":" + `T.append` (T.pack . show . tidnum) te + +-- ---------------------------------------------------------------------- +-- TAG Item +-- ---------------------------------------------------------------------- + +-- | 'TagItem' is a generalisation of 'TagElem'. +class TagItem t where + tgIdName :: t -> Text + tgIdNum :: t -> Integer + tgSemantics :: t -> Sem + tgTree :: t -> Tree (GNode GeniVal) + +instance TagItem TagElem where + tgIdName = idname + tgIdNum = tidnum + tgSemantics = tsemantics + tgTree = ttree + +-- | Sorts trees into a Map.Map organised by the first literal of their +-- semantics. This is useful in at least three places: the polarity +-- optimisation, the gui display code, and code for measuring the efficiency +-- of GenI. Note: trees with a null semantics are filed under an empty +-- predicate, if any. +mapBySem :: (TagItem t) => [t] -> Map.Map (Literal GeniVal) [t] +mapBySem ts = + let gfn t = case tgSemantics t of + [] -> emptyLiteral + (x:_) -> x + in groupByFM gfn ts + +-- ---------------------------------------------------------------------- +-- Extracting sentences +-- ---------------------------------------------------------------------- + +type UninflectedDisjunction = ([Text], Flist GeniVal) + +-- | Normally, extracting the sentences from a TAG tree would just +-- consist of reading its leaves. But if you want the generator to +-- return inflected forms instead of just lemmas, you also need to +-- return the relevant features for each leaf. In TAG, or at least our +-- use of it, the features come from the *pre-terminal* nodes, that is, +-- not the leaves themselves but their parents. Another bit of +-- trickiness: because of atomic disjunction, leaves might have more +-- than one value, so we can't just return a String lemma but a list of +-- String, one for each possibility. +tagLeaves :: TagElem -> [ (NodeName, UninflectedDisjunction) ] +tagLeaves te = [ (gnname pt, (getLexeme t, gup pt)) | (pt,t) <- preTerminals . ttree $ te ] + +-- | Try in order: lexeme, lexeme attributes, node name +getLexeme :: GNode GeniVal -> [Text] +getLexeme node = + case glexeme node of + [] -> fromMaybe [gnname node] $ firstMaybe grab lexemeAttributes + lexs -> lexs + where + grab la = firstMaybe match guppy + where + match (AvPair a v) | isConst v && a == la = + fromFL <$> gConstraints v + match _ = Nothing + guppy = gup node + +firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b +firstMaybe fn = listToMaybe . mapMaybe fn + +-- ---------------------------------------------------------------------- +-- Conversion to text +-- ---------------------------------------------------------------------- + +instance GeniShow TagElem where + geniShowText te = T.concat + [ "% ------------------------- ", idname te + , "\n", ttreename te, ":" , idname te + , " " , (geniShowText $ tinterface te) + , " " , (geniShowText $ ttype te) + , "\n", (geniShowText $ ttree te) + , "\n", geniKeyword "semantics" (geniShowText $ tsemantics te) + ] + +instance GeniShow [TagElem] where + geniShowText = T.intercalate "\n\n" . map geniShowText + +-- Useful for debugging adjunction and substitution nodes +instance Pretty [TagSite] where + pretty = + T.intercalate "\n " . map fn + where + fn (TagSite n t b o) = T.intercalate "/" + [ n, pretty t, pretty b, o ] + +-- ---------------------------------------------------------------------- +-- Diagnostic messages +-- +-- Diagnostic messages let us know why a TAG tree is not returned as a result. +-- Whenever GenI decides to discard a tree, it sets the tdiagnostic field of +-- the TagElem so that the person using a debugger can find out what went wrong. +-- ---------------------------------------------------------------------- + +ts_synIncomplete, ts_tbUnificationFailure :: String +ts_synIncomplete = "syntactically incomplete" +ts_tbUnificationFailure = "top/bot unification failure" + +ts_rootFeatureMismatch :: Flist GeniVal -> String +ts_rootFeatureMismatch good = "root feature does not unify with " ++ prettyStr good + +ts_semIncomplete :: [Literal GeniVal] -> String +ts_semIncomplete sem = "semantically incomplete - missing: " ++ prettyStr sem + +-- ---------------------------------------------------------------------- +-- Performance +-- ---------------------------------------------------------------------- + +{-! +deriving instance NFData TagElem +deriving instance NFData DerivationStep +!-} + +-- GENERATED START + + +instance NFData TagElem where + rnf (TE x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` + rnf x5 `seq` + rnf x6 `seq` + rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` () + + +instance NFData DerivationStep where + rnf (SubstitutionStep x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (AdjunctionStep x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` () + rnf (InitStep x1) = rnf x1 `seq` () +-- GENERATED STOP diff --git a/src/NLP/GenI/Tags.lhs b/src/NLP/GenI/Tags.lhs deleted file mode 100644 --- a/src/NLP/GenI/Tags.lhs +++ /dev/null @@ -1,380 +0,0 @@ -% GenI surface realiser -% Copyright (C) 2005 Carlos Areces and Eric Kow -% -% This program is free software; you can redistribute it and/or -% modify it under the terms of the GNU General Public License -% as published by the Free Software Foundation; either version 2 -% of the License, or (at your option) any later version. -% -% This program is distributed in the hope that it will be useful, -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% You should have received a copy of the GNU General Public License -% along with this program; if not, write to the Free Software -% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -\chapter{Tags} -\label{cha:Tags} - -This module provides basic datatypes specific to Tree Adjoining Grammar -(TAG) and some low-level operations. Note that we don't handle -substitution and adjunction here; see sections \ref{sec:substitution} -and \ref{sec:adjunction} instead. - -\begin{code} -{-# LANGUAGE TemplateHaskell #-} - -module NLP.GenI.Tags( - -- Main Datatypes - Tags, TagElem(..), TagItem(..), TagSite(..), - TagDerivation, DerivationStep(..), emptyTE, - ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure, - ts_rootFeatureMismatch, - - -- Functions from Tags - addToTags, tagLeaves, - - -- Functions from TagElem - setTidnums, - - -- General functions - mapBySem, subsumedBy, showTagSites, - collect, detectSites -) where -\end{code} - -\ignore{ -\begin{code} -import Control.Applicative ( (<$>), (<*>) ) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.List (intersperse) -import Data.Tree - -import Data.Generics (Data) -import Data.Generics.PlateDirect -import Data.Typeable (Typeable) -import Text.JSON - -import NLP.GenI.Btypes (Ptype(Initial, Auxiliar), SemPols, - GeniVal(GConst), AvPair(..), - GNode(gup, glexeme, gnname, gaconstr, gdown, gtype, gorigin), - GType(Subs), Flist, - DescendGeniVal(..), - Collectable(..), Idable(..), - Sem, Pred, emptyPred, - emptyGNode, - showFlist, showPairs, showSem, lexemeAttributes, - ) -import NLP.GenI.General (groupByFM, preTerminals) -import NLP.GenI.PolarityTypes (PolarityKey(..)) -\end{code} -} - -% ---------------------------------------------------------------------- -\section{Tags} -% ---------------------------------------------------------------------- - -\begin{code} --- | An anchored grammar. --- The grammar associates a set of semantic predicates to a list of trees each. -type Tags = Map.Map String [TagElem] - --- | 'addTags' @tags key elem@ adds @elem@ to the the list of elements associated --- to the key -addToTags :: Tags -> String -> TagElem -> Tags -addToTags t k e = Map.insertWith (++) k [e] t -\end{code} - -% ---------------------------------------------------------------------- -\section{TagElem} -% ---------------------------------------------------------------------- - -Final types used for the combined macros + lexicon. We assume that -a two trees are the same iff they have the same tidnum. To make this -work, we assign each tree with a unique id during the process of -combining macros with lexicon (see section \ref{sec:combine_macros}). - -\begin{code} -data TagSite = TagSite { tsName :: String - , tsUp :: Flist - , tsDown :: Flist - , tsOrigin :: String - } - deriving (Show, Eq, Ord, Data, Typeable) - -instance Biplate TagSite GeniVal where - biplate (TagSite x1 zu zd x2) = plate TagSite |- x1 ||+ zu ||+ zd |- x2 - -instance Biplate (Maybe TagSite) GeniVal where - biplate (Just x1) = plate Just |+ x1 - biplate Nothing = plate Nothing - -data TagElem = TE { - idname :: String, - ttreename :: String, - tidnum :: Integer, - ttype :: Ptype, - ttree :: Tree GNode, - tsemantics :: Sem, - -- optimisation stuff - -- (polarity key to charge interval) - tpolarities :: Map.Map PolarityKey (Int,Int), - tinterface :: Flist, -- for idxconstraints (pol) - ttrace :: [String], - tsempols :: [SemPols] - } - deriving (Show, Eq, Data, Typeable) - -instance Biplate TagElem GeniVal where - biplate (TE x1 x2 x3 x4 zt zsem x5 zint x6 x7) = - plate TE |- x1 |- x2 |- x3 |- x4 - |+ zt - ||+ zsem |- x5 - ||+ zint |- x6 |- x7 -\end{code} - -A TAG derivation history consists of a list of 3-tuples representing the -operation (s for substitution, a for adjunction), the name of the child tree, -the name of the parent tree and the node affected. - -\begin{code} -type TagDerivation = [ DerivationStep ] - -data DerivationStep = DerivationStep - { dsOp :: Char - , dsChild :: String - , dsParent :: String - , dsParentSite :: String - } deriving (Show, Ord, Eq) - -instance JSON DerivationStep where - readJSON j = - do jo <- fromJSObject `fmap` readJSON j - let field x = maybe (fail $ "Could not find: " ++ x) readJSON - $ lookup x jo - DerivationStep <$> field "op" - <*> field "child" - <*> field "parent" - <*> field "parent-node" - showJSON x = - JSObject . toJSObject $ [ ("op", showJSON $ dsOp x) - , ("child", showJSON $ dsChild x) - , ("parent", showJSON $ dsParent x) - , ("parent-node", showJSON $ dsParentSite x) - ] -\end{code} - -\begin{code} -instance Ord TagElem where - compare t1 t2 = - case (ttype t1, ttype t2) of - (Initial, Initial) -> compareId - (Initial, Auxiliar) -> LT - (Auxiliar, Initial) -> GT - (Auxiliar, Auxiliar) -> compareId - _ -> error "TagElem compare not exhaustively defined" - where compareId = compare (tidnum t1) (tidnum t2) - -instance DescendGeniVal TagElem where - descendGeniVal s te = - te { tinterface = descendGeniVal s (tinterface te) - , ttree = descendGeniVal s (ttree te) - , tsemantics = descendGeniVal s (tsemantics te) } - -instance DescendGeniVal TagSite where - descendGeniVal s (TagSite n fu fd o) = TagSite n (descendGeniVal s fu) (descendGeniVal s fd) o - -instance Collectable TagElem where - collect t = (collect $ tinterface t) . (collect $ ttree t) - . (collect $ tsemantics t) - -instance Idable TagElem where - idOf = tidnum -\end{code} - -\begin{code} -emptyTE :: TagElem -emptyTE = TE { idname = "", - ttreename = "", - tidnum = -1, - ttype = Initial, - ttree = Node emptyGNode [], - tsemantics = [], - tpolarities = Map.empty, - tsempols = [], - tinterface = [], - ttrace = [] - } - --- | Given a tree(GNode) returns a list of substitution or adjunction --- nodes, as well as remaining nodes with a null adjunction constraint. -detectSites :: Tree GNode -> ([TagSite], [TagSite], [TagSite]) -detectSites t = - ( sites isSub -- for substitution - , sites (not.gaconstr) -- for adjunction - , sites constrButNotSub -- for neither - ) - where - ns = flatten t - sites match = [ TagSite (gnname n) (gup n) (gdown n) (gorigin n) | n <- ns, match n ] - isSub n = gtype n == Subs - constrButNotSub n = gaconstr n && (not $ isSub n) -\end{code} - -\subsection{Unique ID} - -TagElem comparison relies exclusively on \fnparam{tidnum}, so you must -ensure that every TagElem you use has a unique ID. We provide two -helpful functions for this. These are most likely useful \emph{between} -lexical selection and generation proper, because during generation -proper, you can simply keep a counter within a State monad to assign -unique IDs to new TagElems. - -Note that we also label each node of the tree with its elementary tree -name and with the unique ID. This helps us to build derivation trees -correctly - -\begin{code} --- | Assigns a unique id to each element of this list, that is, an integer --- between 1 and the size of the list. -setTidnums :: [TagElem] -> [TagElem] -setTidnums xs = zipWith (\c i -> setOrigin $ c {tidnum = i}) xs [1..] - -setOrigin :: TagElem -> TagElem -setOrigin te = te { ttree = fmap setLabel . ttree $ te } - where setLabel g = g { gorigin = idname te ++ ":" ++ (show.tidnum) te } -\end{code} - -% ---------------------------------------------------------------------- -\section{TAG Item} -% ---------------------------------------------------------------------- - -\begin{code} --- | 'TagItem' is a generalisation of 'TagElem'. -class TagItem t where - tgIdName :: t -> String - tgIdNum :: t -> Integer - tgSemantics :: t -> Sem - -instance TagItem TagElem where - tgIdName = idname - tgIdNum = tidnum - tgSemantics = tsemantics -\end{code} - -% ---------------------------------------------------------------------- -\section{Map by sem} -% ---------------------------------------------------------------------- - -\begin{code} --- | Sorts trees into a Map.Map organised by the first literal of their --- semantics. This is useful in at least three places: the polarity --- optimisation, the gui display code, and code for measuring the efficiency --- of GenI. Note: trees with a null semantics are filed under an empty --- predicate, if any. -mapBySem :: (TagItem t) => [t] -> Map.Map Pred [t] -mapBySem ts = - let gfn t = case tgSemantics t of - [] -> emptyPred - (x:_) -> x - in groupByFM gfn ts - --- | 'subsumedBy' @cs ts@ determines if the candidate semantics @cs@ is --- subsumed by the proposition semantics @ts@. Notice how the proposition --- semantics is only a single item where as the candidate semantics is a --- list. --- --- We assume --- --- * most importantly that @cs@ has already its semantics instatiated --- (all variables assigned) --- --- * @cs@ and @ts@ are sorted --- --- * the list in each element of cs and ts is itself sorted -subsumedBy :: Sem -> Pred -> Bool -subsumedBy [] _ = False -subsumedBy ((ch, cp, cla):cl) (th, tp,tla) - | (ch == th) && (cp == tp) && (cla == tla) = True - -- if we haven't yet overshot, try for the next one - | cp < tp = subsumedBy cl (th, tp, tla) - | otherwise = False -\end{code} - -% ---------------------------------------------------------------------- -\section{Extracting sentences} -% ---------------------------------------------------------------------- - -Normally, extracting the sentences from a TAG tree would just consist of -reading its leaves. But if you want the generator to return inflected -forms instead of just lemmas, you also need to return the relevant -features for each leaf. In TAG, or at least our use of it, the features -come from the \emph{pre-terminal} nodes, that is, not the leaves -themselves but their parents. Another bit of trickiness: because of -atomic disjunction, leaves might have more than one value, so we can't -just return a String lemma but a list of String, one for each -possibility. - -\begin{code} -type UninflectedDisjunction = ([String], Flist) - -tagLeaves :: TagElem -> [ (String, UninflectedDisjunction) ] -tagLeaves te = [ (gnname pt, (getLexeme t, gup pt)) | (pt,t) <- preTerminals . ttree $ te ] - --- | Try in order: lexeme, lexeme attributes, node name -getLexeme :: GNode -> [String] -getLexeme node = - case glexeme node of - [] -> fromMaybe [gnname node] $ firstMaybe grab lexemeAttributes - lexs -> lexs - where - grab la = - let match (AvPair a (GConst v)) | a == la = Just v - match _ = Nothing - in firstMaybe match guppy - guppy = gup node - -firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b -firstMaybe fn = listToMaybe . mapMaybe fn - -\end{code} - -% ---------------------------------------------------------------------- -\section{Debugging} -% ---------------------------------------------------------------------- - -\begin{code} --- Useful for debugging adjunction and substitution nodes -showTagSites :: [TagSite] -> String -showTagSites sites = concat $ intersperse "\n " $ map fn sites - where - fn (TagSite n t b o) = - concat . intersperse "/" $ [ n, showPairs t, showPairs b, o ] -\end{code} - -% ---------------------------------------------------------------------- -\section{Diagnostic messages} -% ---------------------------------------------------------------------- - -Diagnostic messages let us know why a TAG tree is not returned as a result. -Whenever GenI decides to discard a tree, it sets the tdiagnostic field of -the TagElem so that the person using a debugger can find out what went wrong. - -\begin{code} -ts_synIncomplete, ts_tbUnificationFailure :: String -ts_synIncomplete = "syntactically incomplete" -ts_tbUnificationFailure = "top/bot unification failure" - -ts_rootFeatureMismatch :: Flist -> String -ts_rootFeatureMismatch good = "root feature does not unify with " ++ showFlist good - -ts_semIncomplete :: [Pred] -> String -ts_semIncomplete sem = "semantically incomplete - missing: " ++ showSem sem -\end{code} - -% ---------------------------------------------------------------------- -% Performance -% ---------------------------------------------------------------------- diff --git a/src/NLP/GenI/Test.hs b/src/NLP/GenI/Test.hs deleted file mode 100644 --- a/src/NLP/GenI/Test.hs +++ /dev/null @@ -1,31 +0,0 @@ --- ---------------------------------------------------------------------- --- GenI surface realiser --- Copyright (C) 2009 Eric Kow --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License --- as published by the Free Software Foundation; either version 2 --- of the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --- ---------------------------------------------------------------------- - -module NLP.GenI.Test where - -import System.Environment ( getArgs ) -import Test.Framework -import NLP.GenI.GeniVal ( testSuite ) - -runTests :: IO () -runTests = - do args <- filter (/= "--unit-tests") `fmap` getArgs - flip defaultMainWithArgs args - [ NLP.GenI.GeniVal.testSuite - ] diff --git a/src/NLP/GenI/TestSuite.hs b/src/NLP/GenI/TestSuite.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/TestSuite.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +module NLP.GenI.TestSuite +where + +import Data.Text ( Text) +import qualified Data.Text as T + +import NLP.GenI.GeniShow +import NLP.GenI.Pretty +import NLP.GenI.Semantics + +data TestCase = TestCase + { tcName :: Text + , tcSemString :: Text -- ^ for gui + , tcSem :: SemInput + , tcExpected :: [Text] -- ^ expected results (for testing) + } + +instance GeniShow TestCase where + geniShowText (TestCase { tcName = name + , tcExpected = sentences + , tcSemString = semStr + , tcSem = sem + }) = + T.unlines $ [ name, geniShowText sem ] + ++ map (geniKeyword "sentence" . squares) sentences + +instance Pretty TestCase where + pretty = geniShowText diff --git a/src/NLP/GenI/TreeSchema.hs b/src/NLP/GenI/TreeSchema.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/TreeSchema.hs @@ -0,0 +1,351 @@ +-- GenI surface realiser +-- Copyright (C) 2005-2009 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. + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverlappingInstances, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module provides basic datatypes specific to Tree Adjoining Grammar +-- tree schemata. +module NLP.GenI.TreeSchema ( + Macros, + SchemaTree, SchemaNode, Ttree(..), Ptype(..), + + -- Functions from Tree GNode + root, rootUpd, foot, setLexeme, setAnchor, lexemeAttributes, + crushTreeGNode, + + -- GNode + GNode(..), gnnameIs, NodeName, + GType(..), gCategory, showLexeme, + crushGNode, + ) where + +import qualified Data.Map as Map +import Data.Binary +import Data.Tree +import Data.Text ( Text ) +import qualified Data.Text as T + +import Control.DeepSeq +import Data.FullList hiding (head, tail, (++)) +import Data.Generics (Data) +import Data.Typeable (Typeable) + +import NLP.GenI.General (filterTree, listRepNode, geniBug, quoteText) +import NLP.GenI.GeniShow +import NLP.GenI.GeniVal ( GeniVal(..), DescendGeniVal(..), Collectable(..), + ) +import NLP.GenI.FeatureStructure ( AvPair(..), Flist, crushFlist ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( Sem ) + +-- ---------------------------------------------------------------------- +-- Tree schemata + +-- In GenI, the tree schemata are called `macros' for historical reasons. +-- We are working to phase out this name in favour of the more standard +-- `tree schema(ta)'. +-- ---------------------------------------------------------------------- + +type SchemaTree = Ttree SchemaNode +type SchemaNode = GNode [GeniVal] +type Macros = [SchemaTree] + +data Ttree a = TT + { params :: [GeniVal] + , pfamily :: Text + , pidname :: Text + , pinterface :: Flist GeniVal + , ptype :: Ptype + , psemantics :: Maybe Sem + , ptrace :: [Text] + , tree :: Tree a + } + deriving (Data, Typeable, Eq) + +data Ptype = Initial | Auxiliar + deriving (Show, Eq, Data, Typeable) + +instance DescendGeniVal v => DescendGeniVal (Ttree v) where + descendGeniVal s mt = + mt { params = descendGeniVal s (params mt) + , tree = descendGeniVal s (tree mt) + , pinterface = descendGeniVal s (pinterface mt) + , psemantics = descendGeniVal s (psemantics mt) } + +instance (Collectable a) => Collectable (Ttree a) where + collect mt = (collect $ params mt) . (collect $ tree mt) . + (collect $ psemantics mt) . (collect $ pinterface mt) + +-- ---------------------------------------------------------------------- +-- Tree manipulation +-- ---------------------------------------------------------------------- + +-- Traversal + +instance DescendGeniVal a => DescendGeniVal (Map.Map k a) where + descendGeniVal s = {-# SCC "descendGeniVal" #-} Map.map (descendGeniVal s) + +instance (Collectable a => Collectable (Tree a)) where + collect = collect.flatten + +-- Utility functions + +root :: Tree a -> a +root (Node a _) = a + +rootUpd :: Tree a -> a -> Tree a +rootUpd (Node _ l) b = (Node b l) + +foot :: Tree (GNode a) -> GNode a +foot t = case filterTree (\n -> gtype n == Foot) t of + [x] -> x + _ -> geniBug $ "foot returned weird result" + +-- | Given a lexical item @s@ and a Tree GNode t, returns the tree t' +-- where l has been assigned to the anchor node in t' +setAnchor :: FullList Text -> Tree (GNode a) -> Tree (GNode a) +setAnchor s t = + let filt (Node a []) = (gtype a == Lex && ganchor a) + filt _ = False + in case listRepNode (setLexeme (fromFL s)) filt [t] of + ([r],True) -> r + _ -> geniBug $ "setLexeme " ++ show s ++ " returned weird result" + +-- | Given a lexical item @l@ and a tree node @n@ (actually a subtree +-- with no children), return the same node with the lexical item as +-- its unique child. The idea is that it converts terminal lexeme nodes +-- into preterminal nodes where the actual terminal is the given lexical +-- item +setLexeme :: [Text] -> Tree (GNode a) -> Tree (GNode a) +setLexeme l (Node a []) = Node a [ Node subanc [] ] + where + subanc = GN + { gnname = T.concat $ "_" : gnname a : "." : l + , gup = [] + , gdown = [] + , gaconstr = True + , ganchor = False + , glexeme = l + , gtype = Other + , gorigin = "" + } +setLexeme _ _ = geniBug "impossible case in setLexeme - subtree with kids" + +-- ---------------------------------------------------------------------- +-- TAG nodes (GNode) +-- ---------------------------------------------------------------------- + +-- | A single node of a TAG tree. +data GNode gv = GN + { gnname :: NodeName + , gup :: Flist gv -- ^ top feature structure + , gdown :: Flist gv -- ^ bottom feature structure + , ganchor :: Bool -- ^ @False@ for na nodes + , glexeme :: [Text] -- ^ @[]@ for na nodes + , gtype :: GType + , gaconstr :: Bool + , gorigin :: Text -- ^ for TAG, this would be the elementary tree + -- that this node originally came from + } + deriving (Eq, Data, Typeable) + +-- Node type used during parsing of the grammar +data GType = Subs | Foot | Lex | Other + deriving (Show, Eq, Data, Typeable) + +type NodeName = Text + +-- Traversal + +instance Collectable gv => Collectable (GNode gv) where + collect n = (collect $ gdown n) . (collect $ gup n) + +instance DescendGeniVal v => DescendGeniVal (GNode v) where + descendGeniVal s gn = + gn { gup = descendGeniVal s (gup gn) + , gdown = descendGeniVal s (gdown gn) } + +-- Utilities + +gnnameIs :: NodeName -> GNode gv -> Bool +gnnameIs n = (== n) . gnname + +-- | Return the value of the "cat" attribute, if available +gCategory :: Flist GeniVal -> Maybe GeniVal +gCategory top = + case [ v | AvPair "cat" v <- top ] of + [] -> Nothing + [c] -> Just c + _ -> geniBug $ "Impossible case: node with more than one category" + +-- | Attributes recognised as lexemes, in order of preference +lexemeAttributes :: [Text] +lexemeAttributes = [ "lex", "phon", "cat" ] + +-- ---------------------------------------------------------------------- +-- Pretty printing and other text conversions +-- ---------------------------------------------------------------------- + +instance GeniShow Ptype where + geniShow Initial = "initial" + geniShow Auxiliar = "auxiliary" + +instance (GeniShow a) => GeniShow (Ttree a) where + geniShowText tt = T.intercalate "\n" . filter (not . T.null) $ + [ "% ------------------------- ", pidname tt + , T.unwords [ pfamily tt <> ":" <> pidname tt + , plist + , geniShowText (ptype tt) + ] + , geniShowText (tree tt) + , maybe "" showSem (psemantics tt) + , showTr (ptrace tt) + ] + where + plist = parens . T.unwords . concat $ + [ map geniShowText (params tt) + , ["!"] + , map geniShowText (pinterface tt) + ] + showSem = geniKeyword "semantics" . geniShowText + showTr = geniKeyword "trace" . squares . T.unwords + +-- | The default show for GNode tries to be very compact; it only shows the value +-- for cat attribute and any flags which are marked on that node. +-- +-- This is one the places where the pretty representation of a GenI object is +-- different from its GenI-format one +instance Pretty (GNode GeniVal) where + pretty gn = + stub `T.append` extra + where + cat_ = maybe "" pretty . gCategory $ gup gn + lex_ = showLexeme (glexeme gn) + -- + stub = T.intercalate ":" $ filter (not . T.null) [ cat_, lex_ ] + extra = case gtype gn of + Subs -> " !" + Foot -> " *" + _ -> if gaconstr gn then " #" else "" + +instance GeniShow (GNode GeniVal) where + geniShowText x = + T.unwords . filter (not . T.null) $ + [ gnname x, gaconstrstr, gtypestr x, glexstr x, tbFeats x ] + where + gaconstrstr = case (gaconstr x, gtype x) of + (True, Other) -> "aconstr:noadj" + _ -> "" + gtypestr n = case gtype n of + Subs -> "type:subst" + Foot -> "type:foot" + Lex -> if ganchor n && (null.glexeme) n + then "type:anchor" else "type:lex" + _ -> "" + glexstr n = + if null ls + then "" + else T.intercalate "|" (map quoteText ls) + where + ls = glexeme n + tbFeats n = + geniShowText (gup n) + `T.append` "!" + `T.append` geniShowText (gdown n) + + +-- FIXME: will have to think of nicer way - one which involves +-- unpacking the trees :-( +showLexeme :: [Text] -> Text +showLexeme [] = "" +showLexeme [l] = l +showLexeme xs = T.intercalate "|" xs + +-- Fancy disjunction + +crushTreeGNode :: Tree (GNode [GeniVal]) -> Maybe (Tree (GNode GeniVal)) +crushTreeGNode (Node x xs) = + do x2 <- crushGNode x + xs2 <- mapM crushTreeGNode xs + return $ Node x2 xs2 + +crushGNode :: GNode [GeniVal] -> Maybe (GNode GeniVal) +crushGNode gn = + do gup2 <- crushFlist (gup gn) + gdown2 <- crushFlist (gdown gn) + return $ GN { gnname = gnname gn + , gup = gup2 + , gdown = gdown2 + , ganchor = ganchor gn + , glexeme = glexeme gn + , gtype = gtype gn + , gaconstr = gaconstr gn + , gorigin = gorigin gn} + + +instance Binary Ptype where + put Initial = putWord8 0 + put Auxiliar = putWord8 1 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return Initial + 1 -> return Auxiliar + _ -> fail "no parse" + +instance Binary gv => Binary (GNode gv) where + put (GN a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h + get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (GN a b c d e f g h) + +instance Binary GType where + put Subs = putWord8 0 + put Foot = putWord8 1 + put Lex = putWord8 2 + put Other = putWord8 3 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> return Subs + 1 -> return Foot + 2 -> return Lex + 3 -> return Other + _ -> fail "no parse" + +instance (Binary a) => Binary (Ttree a) where + put (TT a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h + get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (TT a b c d e f g h) + +-- Node type used during parsing of the grammar +instance NFData GType where + rnf x = x `seq` () + +instance NFData Ptype where + rnf x = x `seq` () + +-- | A single node of a TAG tree. +instance NFData gv => NFData (GNode gv) where + rnf (GN x1 x2 x3 x4 x5 x6 x7 x8) + = rnf x1 `seq` + rnf x2 `seq` + rnf x3 `seq` + rnf x4 `seq` + rnf x5 `seq` + rnf x6 `seq` + rnf x7 `seq` rnf x8 `seq` () diff --git a/src/NLP/GenI/Warning.hs b/src/NLP/GenI/Warning.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Warning.hs @@ -0,0 +1,32 @@ +-- GenI surface realiser +-- Copyright (C) 2012 Eric Kow (Computational Linguistics Ltd) +-- +-- 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. + +-- | Typed warnings as an easier alternative to strings. +-- +-- This makes it easier to recognise repeated warnings and print them +-- out in a reasonable way +module NLP.GenI.Warning + ( -- * Collection of warnings + GeniWarnings, fromGeniWarnings, mkGeniWarnings + , sortWarnings + -- * Individual warnings + , GeniWarning(..), LexWarning(..) + , showGeniWarning + ) + where + +import NLP.GenI.Warning.Internal diff --git a/src/NLP/GenI/Warning/Internal.hs b/src/NLP/GenI/Warning/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NLP/GenI/Warning/Internal.hs @@ -0,0 +1,146 @@ +-- GenI surface realiser +-- Copyright (C) 2011 Eric Kow (on behalf of SRI) +-- +-- This program is free software; you can redistribute it and/or +-- modify it under the terms of the GNU General Public License +-- as published by the Free Software Foundation; either version 2 +-- of the License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +{-# LANGUAGE OverloadedStrings #-} +module NLP.GenI.Warning.Internal where + +import Data.FullList ( FullList, fromFL ) +import Data.List +import Data.Monoid ( Monoid, mconcat, mappend, mempty ) +import Data.Text ( Text ) +import qualified Data.Map as Map +import qualified Data.Text as T + +import Data.Poset + +import NLP.GenI.General ( histogram ) +import NLP.GenI.GeniVal ( GeniVal ) +import NLP.GenI.LexicalSelection.Types ( LexCombineError, showLexCombineError ) +import NLP.GenI.Lexicon ( LexEntry(..) ) +import NLP.GenI.Pretty +import NLP.GenI.Semantics ( Literal ) +import NLP.GenI.TreeSchema ( showLexeme ) + +-- | This exists because we want the 'Monoid' instance, providing a +-- GenI-specific notion of appending which merges instances of the +-- same error +newtype GeniWarnings = GeniWarnings { fromGeniWarnings :: [GeniWarning] } + +mkGeniWarnings :: [GeniWarning] -> GeniWarnings +mkGeniWarnings = mconcat . map (\x -> GeniWarnings [x]) + +instance Monoid GeniWarnings where + mempty = GeniWarnings [] + mappend (GeniWarnings g1) (GeniWarnings g2) = GeniWarnings (foldr appendWarning g2 g1) + +data GeniWarning = -- | A warning that should be repeated for each lexical entry affected + LexWarning [LexEntry] LexWarning + -- | A single custom warning + | CustomLexWarning Text + -- | Literals which did not receive any lexical selection + | NoLexSelection [Literal GeniVal] + -- | Warnings from the morphological realiser + | MorphWarning [Text] + deriving (Eq) + + +data LexWarning = LexCombineAllSchemataFailed + | LexCombineOneSchemaFailed LexCombineError + | MissingCoanchors Text Int + deriving (Eq) + +-- | Sort, treating non-comporable items as equal +posort :: Poset a => [a] -> [a] +posort = sortBy (flip fromPosetCmp) + where + fromPosetCmp x1 x2 = case posetCmp x1 x2 of + Comp o -> o + NComp -> EQ + +instance Poset GeniWarning where + -- 1. LexWarning + leq (LexWarning _ w1) (LexWarning _ w2) = leq w1 w2 + leq (LexWarning _ _) _ = True + -- 2. CustomLexWarning + leq (CustomLexWarning _) (LexWarning _ _) = False + leq (CustomLexWarning w1) (CustomLexWarning w2) = leq w1 w2 + leq (CustomLexWarning _) _ = True + -- 3. NoLexSelection + leq (NoLexSelection _) (LexWarning _ _) = False + leq (NoLexSelection _) (CustomLexWarning _) = False + leq (NoLexSelection _) (NoLexSelection _) = True + leq (NoLexSelection _) _ = True + -- 4. MorphWarning + leq (MorphWarning _) (LexWarning _ _) = False + leq (MorphWarning _) (CustomLexWarning _) = False + leq (MorphWarning _) (NoLexSelection _) = False + leq (MorphWarning w1) (MorphWarning w2) = leq w1 w2 + +instance Poset LexWarning where + -- 1. LexCombineOneSchemaFailed + leq (LexCombineOneSchemaFailed l1) (LexCombineOneSchemaFailed l2) = leq l1 l2 + leq (LexCombineOneSchemaFailed _) _ = True + -- 2. LexCombineAllSchemataFailed + leq LexCombineAllSchemataFailed (LexCombineOneSchemaFailed _) = False + leq LexCombineAllSchemataFailed _ = True + -- 3. MissingCoanchors + leq (MissingCoanchors _ n1) (MissingCoanchors _ n2) = leq n1 n2 + leq (MissingCoanchors _ _) (LexCombineOneSchemaFailed _) = False + leq (MissingCoanchors _ _) LexCombineAllSchemataFailed = False + +sortWarnings :: GeniWarnings -> GeniWarnings +sortWarnings (GeniWarnings ws) = GeniWarnings (posort ws) + +appendWarning :: GeniWarning -> [GeniWarning] -> [GeniWarning] +appendWarning w0 [] = [w0] +appendWarning w0 (w:ws) = case mergeWarning w0 w of + Just w1 -> w1 : ws + Nothing -> w : appendWarning w0 ws + +mergeWarning :: GeniWarning -> GeniWarning -> Maybe GeniWarning +mergeWarning (LexWarning ls1 w1) (LexWarning ls2 w2) | w1 == w2 = Just (LexWarning (ls1 ++ ls2) w1) +mergeWarning _ _ = Nothing + +-- | A warning may be displayed over several lines +showGeniWarning :: GeniWarning -> [Text] +showGeniWarning (NoLexSelection ps) = + [ "No lexical entries for literals:" <+> T.unwords (map pretty ps) ] +showGeniWarning (CustomLexWarning w) = [w] +showGeniWarning (LexWarning ls wa) = do -- list monad + wf <- Map.toList (toWfCount ls) + return (msg <> ":" <+> prettyCount showWithFam "lemmas" wf <> suffix) + where + (msg, suffix) = showLexWarning wa + showLexWarning LexCombineAllSchemataFailed = + ("Lexically selected but anchoring failed for *all* instances of", "") + showLexWarning (LexCombineOneSchemaFailed lc) = + showLexCombineError lc + showLexWarning (MissingCoanchors co n) = + (T.unwords [ "Expected co-anchor", co + , "is missing from", T.pack (show n), "schemata" + ] + , "") + showWithFam (w, f) = showLexeme (fromFL w) <+> parens f +showGeniWarning (MorphWarning ws) = map ("Morph:" <+>) ws + +-- word and all families associated with that word +type WordFamilyCount = Map.Map (FullList Text, Text) Int + +toWfCount :: [LexEntry] -> WordFamilyCount +toWfCount = histogram . map toWf + where + toWf i = (iword i, ifamname i)