diff --git a/GenI.cabal b/GenI.cabal
--- a/GenI.cabal
+++ b/GenI.cabal
@@ -1,5 +1,5 @@
Name: GenI
-Version: 0.17.4
+Version: 0.20
License: GPL
License-file: LICENSE
Author: Carlos Areces and Eric Kow
@@ -33,52 +33,60 @@
examples/promettre/morphinfo,
examples/promettre/suite,
examples/xmg-example/grammar/Arguments.mg,
- examples/xmg-example/grammar/demo-corpus-latin1.txt,
+ examples/xmg-example/grammar/demo-corpus-utf8.txt,
examples/xmg-example/grammar/Entete.mg,
examples/xmg-example/grammar/Evaluations.mg,
examples/xmg-example/grammar/Misc.mg,
examples/xmg-example/grammar/parse-corpus.sh,
examples/xmg-example/grammar/Sem.mg,
examples/xmg-example/grammar/VerbMorph.mg,
- examples/xmg-example/lexicon/demo-lemma-latin1.lex,
- examples/xmg-example/lexicon/demo-morph-latin1.mph,
+ examples/xmg-example/lexicon/demo-lemma-utf8.lex,
+ examples/xmg-example/lexicon/demo-morph-utf8.mph,
examples/xmg-example/Makefile,
examples/xmg-example/README,
examples/xmg-example/suite,
- etc/macstuff/macosx-app, etc/macstuff/Info.plist, etc/macstuff/wxmac.icns
+ etc/stupidmorph.pl,
+ etc/macstuff/Info.plist,
+ etc/macstuff/wxmac.icns
-extra-source-files: src/EnableGUI.hs
- src/NLP/GenI/SysGeni.lhs
+extra-source-files: src/NLP/GenI/SysGeni.hs
src/NLP/GenI/Test.hs
- src/NLP/GenI/CkyEarley/CkyGui.lhs
- src/NLP/GenI/Simple/SimpleGui.lhs, src/NLP/GenI/Gui.lhs
- src/NLP/GenI/GraphvizShow.lhs, src/NLP/GenI/GuiHelper.lhs
- src/NLP/GenI/Console.hs, src/NLP/GenI/Graphviz.hs
- src/NLP/GenI/BuilderGui.lhs, src/NLP/GenI/unused/Predictors.lhs
- src/NLP/GenI/GraphvizShowPolarity.lhs
+ src/NLP/GenI/Simple/SimpleGui.lhs,
+ src/NLP/GenI/Gui.lhs
+ src/NLP/GenI/GraphvizShow.lhs,
+ 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
Flag gui
description: Build with a graphical user interface
default: False
-Flag splitBase
- description: Choose the new smaller, split-up base package.
-
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,
- binary > 0.2 && < 0.5
- if flag(splitBase)
- Build-depends: base >= 3 && < 4, containers, process
- else
- Build-Depends: base < 3
+ 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
@@ -92,36 +100,33 @@
NLP.GenI.General,
NLP.GenI.GeniParsers,
NLP.GenI.GeniShow,
+ NLP.GenI.GeniVal,
NLP.GenI.Tags,
NLP.GenI.Morphology,
- NLP.GenI.Polarity, NLP.GenI.Automaton,
+ NLP.GenI.OptimalityTheory,
+ NLP.GenI.Polarity,
+ NLP.GenI.PolarityTypes,
+ NLP.GenI.Automaton,
NLP.GenI.Statistics,
NLP.GenI.Builder,
- NLP.GenI.Simple.SimpleBuilder, NLP.GenI.CkyEarley.CkyBuilder,
+ NLP.GenI.Simple.SimpleBuilder,
+ -- NLP.GenI.CkyEarley.CkyBuilder,
NLP.GenI.Geni, NLP.GenI.Configuration
Hs-Source-Dirs: src
Extensions: CPP, Rank2Types, OverlappingInstances, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, ExistentialQuantification, LiberalTypeSynonyms
Ghc-options: -Wall -O2
+ 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
- Ghc-options: -Wall
- Build-Depends: filepath > 1.0 && < 1.2,
- parsec >= 2.1 && < 3,
- QuickCheck >= 1.2 && < 2,
- HUnit >= 1 && < 1.3,
- mtl >= 1.0 && < 1.2,
- binary >= 0.2 && < 0.5
- if flag(splitBase)
- Build-Depends: base >= 3,
- process > 1, directory > 1, containers >= 0.1
- else
- Build-Depends: base < 3
-
+ Ghc-options: -Wall -O2
+ 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.12
else
diff --git a/INSTALL b/INSTALL
--- a/INSTALL
+++ b/INSTALL
@@ -1,17 +1,21 @@
Requirements
------------
- * ghc 6.8 or 6.10
+ * GHC 6.8 or 6.10
* libgmp (for ghc)
- * wxhaskell 0.10 (darcs version for now)
- * wxWidgets 2.8 (for wxhaskell 0.11)
- * graphviz (for GUI)
+GUI requirements
+----------------
+Only needed if you want the graphical interface:
+ * wxWidgets 2.8
+ * wxHaskell 0.11
+ * Graphviz
+
Building GenI
--------------
1. obtain cabal-install
-
-2. cabal configure
- cabal build
- cabal install
+2. run: cabal install
+3. if you want the graphical interface, try
+ cabal install -fgui
+ but ONLY AFTER you succeed in installing the text version :-)
For more details, see http://trac.haskell.org/GenI
diff --git a/NEWS b/NEWS
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,35 @@
+GenI 0.20, 29 Sep 2009
+----------------------
+- NON BACKWARD-COMPATIBLE CHANGES
+
+ * GHC 6.8 or higher now required (GHC 6.10 + Haskell Platform preferred)
+ * Input files now *assumed* to be UTF-8 encoded
+ (output still ISO8859-1; hopefully locale-based in GHC 6.12)
+ * Interface between GenI and morphological realiser now uses a JSON format.
+ * --macros renamed to --schemata (still -m)
+ * Rootfeat optimisation now mandatory (flag no longer recognised)
+
+- NEW FUNCTIONALITY
+
+ * new flag --version now works and reports version from Cabal file
+ * new flag --dump dumps derivation output to stdout in JSON format
+ * new flag --ranking foo ranks outputs according to OT-style constraints expressed in foo
+ * --batchdir now works with --testcase
+ * --batchdir now dumps derivations and statistics in JSON format
+ * --batchdir now works with instructions files
+ * --metrics always expands 'default' to the default metrics
+ (in addition to any other statistics you request)
+
+- QUALITY ASSURANCE
+
+ * Reference manual in docs/genimanual.pdf (make docs)
+ * cabal install -fgui and cabal install produce the same underlying library
+ only the executable is different
+ * Easier GUI installation for MacOS X (application bundles now built
+ automatically; no manual intervention required)
+ * Adopted odd/even convention to distinguish devel builds from stable ones
+ (eg. GenI 0.21.x is devel whereas GenI 0.20.x is stable)
+
GenI 0.17.4, 6 Apr 2009
-----------------------
* GHC 6.6 support
@@ -17,3 +49,32 @@
* Better help text
* Baked-in unit testing (geni --unit-test)
+
+GenI 0.10, 11 Dec 2006
+----------------------
+* Performance much improved after Haskell profiling
+* Pre-compiled grammars option, geniserver (buggy)
+
+GenI 0.9, 8 Dec 2006
+--------------------
+* Switched to new syntax: variables now must be prefixed with '?'
+* Switched from Alex/Happy to Parsec
+* Added API documentation via haddock
+
+GenI 0.8, 16 Sep 2005
+---------------------
+* Support for latin-1 characters using Unicode wxhaskell
+* Added a configure script and an install target in Makefile
+* Changed from use of configuration files to use of command line switches
+* Full configuration GUI
+* Implementation of atomic disjunction
+* --ignore-semantics mode (Jackie Lai)
+
+GenI 0.7, 8 June 2005
+---------------------
+* Upgraded to ghc 6.4, wxwidgets 2.6, wxhaskell 0.9.4
+
+GenI 0.6, 3 May 2005
+---------------------
+* User interface fixes (Window size bugs)
+* Interface with Yannick Parmientier's selection module
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,117 @@
+{-# 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"]
diff --git a/Setup.lhs b/Setup.lhs
deleted file mode 100644
--- a/Setup.lhs
+++ /dev/null
@@ -1,68 +0,0 @@
-#!/usr/bin/env runhaskell
-
-This Cabal setup script is meant to be used with programs that use the
-wxHaskell toolkit. The problem is that on MacOS X, you have to post
-process each GUI with the 'macosx-app' shell script (from wxhaskell) so
-that it actually responds to user input instead of just sitting there
-looking pretty.
-
-> import Control.Monad (foldM_)
-> import System.Cmd
-> import System.Exit
-> import System.Info (os)
->
-> import Distribution.PackageDescription
-> import Distribution.Simple.Setup
-> import Distribution.Simple
-> import Distribution.Simple.LocalBuildInfo
-
-Configure this stuff
---------------------
-Put here the list of executables which contain a GUI. If they all
-contain a GUI (or you don't really care that much), just put Nothing
-
-> mRestrictTo :: Maybe [String]
-> mRestrictTo = Just ["geni"]
-
-Normally, this should just be "macosx-app"
-
-> macosxApp :: String
-> macosxApp = "etc/macstuff/macosx-app"
-
-Nothing to configure from here on
----------------------------------
-Note that we assume anybody running on Darwin is running OS X, probably
-not the right thing to do, but frankly... who runs Darwin anyway? Note
-also that this script is equivalent to the vanilla one if you're running
-on other operating systems.
-
-> main :: IO ()
-> main =
-> do case os of
-> "darwin" -> defaultMainWithHooks (simpleUserHooks { postBuild = macifyHook })
-> _ -> defaultMain
-
-> macifyHook _ _ pkg localb =
-> foldM_ (next $ macify.binPath) ExitSuccess guiExes
-> where
-> allExes = map exeName $ executables pkg
-> guiExes = case mRestrictTo of
-> Nothing -> allExes
-> Just rs -> filter (`elem` rs) allExes
-> next _ x@(ExitFailure _) _ = return x
-> next _ _ b = macify (binPath b)
-> binPath x = buildDir localb /// x /// x
-
-> macify :: FilePath -> IO ExitCode
-> macify x = system $ unwords $ [ "chmod u+x", macosxApp, ";"
-> , macosxApp, x ]
-
-This handly little FilePath concatenation function was stolen from
-darcs. Note that darcs is GPL; if this bothers you, ask David Roundy.
-
-> (///) :: FilePath -> FilePath -> FilePath
-> ""///b = b
-> a///"" = a
-> a///b = a ++ "/" ++ b
-
-
diff --git a/etc/macstuff/Info.plist b/etc/macstuff/Info.plist
--- a/etc/macstuff/Info.plist
+++ b/etc/macstuff/Info.plist
@@ -7,7 +7,7 @@
CFBundleExecutable
geni
CFBundleGetInfoString
- GenI unstable 0.8
+ GenI
CFBundleIconFile
wxmac.icns
CFBundleIdentifier
@@ -15,22 +15,22 @@
CFBundleInfoDictionaryVersion
6.0
CFBundleLongVersionString
- 0.8, (c) 2005 LORIA
+ (c) 2005-2009 LORIA
CFBundleName
GenI
CFBundlePackageType
APPL
CFBundleShortVersionString
- 0.8
+ 0
CFBundleSignature
????
CFBundleVersion
- 0.8
+ 0
CSResourcesFileMapped
LSRequiresCarbon
NSHumanReadableCopyright
- Copyright 2005 LORIA
+ Copyright 2005-2009 LORIA
diff --git a/etc/macstuff/macosx-app b/etc/macstuff/macosx-app
deleted file mode 100644
--- a/etc/macstuff/macosx-app
+++ /dev/null
@@ -1,114 +0,0 @@
-#!/bin/sh
-icnsfile=etc/macstuff/wxmac.icns
-infofile=etc/macstuff/Info.plist
-bundlename=GenI
-rezcomp="/Developer/Tools/Rez -t APPL Carbon.r $rezfile -o"
-
-#------------------------------------------------------------------------
-# Helper script to create a MacOS X application from a binary.
-# Hacked up with lots of GenI-specific stuff.
-# Meant to be run from the bin directory directly.
-#
-# Daan Leijen and Arthur Baars.
-#
-# Copyright (c) 2003,2004 Daan Leijen, Arthur Baars
-#------------------------------------------------------------------------
-
-# $Id: macosx-app-template,v 1.4 2005/04/29 14:16:51 dleijen Exp $
-arg=""
-
-# variables
-program=""
-verbose="yes"
-
-
-# Parse command-line arguments
-while : ; do
- # put optional argument in the $arg variable
- case "$1" in
- -*=*) arg=`echo "$1" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
- *) arg= ;;
- esac
-
- # match on the arguments
- case "$1" in
- "") break;;
- -\?|--help)
- echo "usage:"
- echo " macosx-app [options] "
- echo ""
- echo "options: [defaults in brackets]"
- echo " --help | -? show this information"
- echo " --verbose | -v be verbose"
- echo ""
- exit 1;;
- -v|--verbose)
- verbose="yes";;
- -*) echo "error: Unknown option \"$1\". Use \"--help\" to show valid options." 1>&2
- echo "" 1>&2
- exit 2;;
- *) if test "$program"; then
- echo "error: [program] is specified twice. Use \"--help\" to show valid options." 1>&2
- echo ""1>&2
- exit 2
- fi
- program="$1";;
- esac
- shift
-done
-
-# default program
-if test -z "$program"; then
- echo "error: you need to specify a program. Use \"--help\" to show valid options." 1>&2
- echo "" 1>&2
- exit 2
-fi
-
-# show when verbose is true.
-show()
-{
- if test "$verbose" = "yes"; then
- echo "$1"
- fi
-}
-
-# link with default resources
-# this is neccesary only to run the GUI from the command line
-if test "$rezcomp"; then
- show "creating resource:"
- show " > $rezcomp $program"
- $rezcomp $program
-fi
-
-# create a bundle
-bundle="$program.app/Contents"
-
-# create bundle directories
-show "creating app directories:"
-show " - $program.app"
-mkdir -p $program.app
-show " - $bundle"
-mkdir -p $bundle
-show " - $bundle/MacOS"
-mkdir -p $bundle/MacOS
-show " - $bundle/Resources"
-mkdir -p $bundle/Resources
-
-cp -f $program $bundle/MacOS/
-
-# copy the icon
-cp -f ${icnsfile} $bundle/Resources
-
-# package info
-show "creating package info:"
-show " - $bundle/PkgInfo"
-echo -n "APPL????" > $bundle/PkgInfo
-
-# create program information file
-cp ${infofile} $bundle/Info.plist
-
-# tell finder that there's an icon
-/Developer/Tools/SetFile -a C $bundle
-
-show "done."
-show ""
diff --git a/etc/stupidmorph.pl b/etc/stupidmorph.pl
new file mode 100644
--- /dev/null
+++ b/etc/stupidmorph.pl
@@ -0,0 +1,85 @@
+:
+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/demo/README b/examples/demo/README
--- a/examples/demo/README
+++ b/examples/demo/README
diff --git a/examples/ej/lexicon b/examples/ej/lexicon
--- a/examples/ej/lexicon
+++ b/examples/ej/lexicon
diff --git a/examples/ej/suite b/examples/ej/suite
--- a/examples/ej/suite
+++ b/examples/ej/suite
diff --git a/examples/xmg-example/Makefile b/examples/xmg-example/Makefile
--- a/examples/xmg-example/Makefile
+++ b/examples/xmg-example/Makefile
@@ -7,8 +7,8 @@
GRAMMAR_RAW_MG:=$(GRAMMAR_DIR)/$(GRAMMAR).mg
LEXICON_DIR:=lexicon
-FULL_LEXICON_PREFIX:=demo-lemma-latin1
-MORPH_PREFIX:=demo-morph-latin1
+FULL_LEXICON_PREFIX:=demo-lemma-utf8
+MORPH_PREFIX:=demo-morph-utf8
MACROS_FILE:=macros.mac
@@ -20,7 +20,7 @@
GENI_MORPH:=$(LEXICON_DIR)/$(MORPH_PREFIX).gmorph
GENI_SUITE:=suite
-GENI_OPTIMISATIONS:='pol f-sem f-root'
+GENI_OPTIMISATIONS:='pol f-sem'
GENI_LEX_FLAGS:=-l $(GENI_LEXICON) -s $(GENI_SUITE)
ifdef ENABLE_MORPH
diff --git a/examples/xmg-example/grammar/demo-corpus-latin1.txt b/examples/xmg-example/grammar/demo-corpus-latin1.txt
deleted file mode 100644
--- a/examples/xmg-example/grammar/demo-corpus-latin1.txt
+++ /dev/null
@@ -1,6 +0,0 @@
-Jean aime Marie.
-Jean est appelé par Marie.
-Marie aime Jean.
-Marie appelle.
-Jean qui appelle aime Marie.
-ils appellent.
diff --git a/examples/xmg-example/grammar/demo-corpus-utf8.txt b/examples/xmg-example/grammar/demo-corpus-utf8.txt
new file mode 100644
--- /dev/null
+++ b/examples/xmg-example/grammar/demo-corpus-utf8.txt
@@ -0,0 +1,6 @@
+Jean aime Marie.
+Jean est appelé par Marie.
+Marie aime Jean.
+Marie appelle.
+Jean qui appelle aime Marie.
+ils appellent.
diff --git a/examples/xmg-example/lexicon/demo-lemma-latin1.lex b/examples/xmg-example/lexicon/demo-lemma-latin1.lex
deleted file mode 100644
--- a/examples/xmg-example/lexicon/demo-lemma-latin1.lex
+++ /dev/null
@@ -1,113 +0,0 @@
-include macros.mac
-
-*ENTRY: aimer
-*CAT: v
-*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient]
-*ACC: 1
-*FAM: n0Vn1
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> aux = avoir
-anc -> aux-refl = -
-*COANCHORS:
-
-*ENTRY: aimer
-*CAT: v
-*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient]
-*ACC: 1
-*FAM: n0Vn1
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> aux = etre
-anc -> aux-refl = +
-*COANCHORS:
-
-*ENTRY: appeler
-*CAT: v
-*SEM: unaryRel[theta1=agent,rel=appeler]
-*ACC: 1
-*FAM: n0V
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> aux = avoir
-anc -> aux-refl = -
-*COANCHORS:
-
-*ENTRY: appeler
-*CAT: v
-*SEM: binaryRel[theta1=agent,rel=appeler,theta2=patient]
-*ACC: 1
-*FAM: n0Vn1
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> aux = avoir
-anc -> aux-refl = -
-*COANCHORS:
-
-*ENTRY: etre
-*CAT: v
-*SEM:
-*ACC: 1
-*FAM: Copule
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-*COANCHORS:
-
-*ENTRY: il
-*CAT: cl
-*SEM: basicProperty[rel=il]
-*ACC: 1
-*FAM: Clitic
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-*COANCHORS:
-
-*ENTRY: jean
-*CAT: n
-*SEM: basicProperty[rel=jean]
-*ACC: 1
-*FAM: propername
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> gen = m
-anc -> det = +
-*COANCHORS:
-
-*ENTRY: marie
-*CAT: n
-*SEM: basicProperty[rel=marie]
-*ACC: 1
-*FAM: propername
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-anc -> gen = f
-anc -> det = +
-*COANCHORS:
-
-*ENTRY: par
-*CAT: p
-*SEM:
-*ACC: 1
-*FAM: void
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-*COANCHORS:
-
-*ENTRY: qui
-*CAT: c
-*SEM:
-*ACC: 1
-*FAM: void
-*FILTERS: []
-*EX: {}
-*EQUATIONS:
-*COANCHORS:
diff --git a/examples/xmg-example/lexicon/demo-lemma-utf8.lex b/examples/xmg-example/lexicon/demo-lemma-utf8.lex
new file mode 100644
--- /dev/null
+++ b/examples/xmg-example/lexicon/demo-lemma-utf8.lex
@@ -0,0 +1,113 @@
+include macros.mac
+
+*ENTRY: aimer
+*CAT: v
+*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient]
+*ACC: 1
+*FAM: n0Vn1
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> aux = avoir
+anc -> aux-refl = -
+*COANCHORS:
+
+*ENTRY: aimer
+*CAT: v
+*SEM: binaryRel[theta1=agent,rel=aimer,theta2=patient]
+*ACC: 1
+*FAM: n0Vn1
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> aux = etre
+anc -> aux-refl = +
+*COANCHORS:
+
+*ENTRY: appeler
+*CAT: v
+*SEM: unaryRel[theta1=agent,rel=appeler]
+*ACC: 1
+*FAM: n0V
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> aux = avoir
+anc -> aux-refl = -
+*COANCHORS:
+
+*ENTRY: appeler
+*CAT: v
+*SEM: binaryRel[theta1=agent,rel=appeler,theta2=patient]
+*ACC: 1
+*FAM: n0Vn1
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> aux = avoir
+anc -> aux-refl = -
+*COANCHORS:
+
+*ENTRY: etre
+*CAT: v
+*SEM:
+*ACC: 1
+*FAM: Copule
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+*COANCHORS:
+
+*ENTRY: il
+*CAT: cl
+*SEM: basicProperty[rel=il]
+*ACC: 1
+*FAM: Clitic
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+*COANCHORS:
+
+*ENTRY: jean
+*CAT: n
+*SEM: basicProperty[rel=jean]
+*ACC: 1
+*FAM: propername
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> gen = m
+anc -> det = +
+*COANCHORS:
+
+*ENTRY: marie
+*CAT: n
+*SEM: basicProperty[rel=marie]
+*ACC: 1
+*FAM: propername
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+anc -> gen = f
+anc -> det = +
+*COANCHORS:
+
+*ENTRY: par
+*CAT: p
+*SEM:
+*ACC: 1
+*FAM: void
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+*COANCHORS:
+
+*ENTRY: qui
+*CAT: c
+*SEM:
+*ACC: 1
+*FAM: void
+*FILTERS: []
+*EX: {}
+*EQUATIONS:
+*COANCHORS:
diff --git a/examples/xmg-example/lexicon/demo-morph-latin1.mph b/examples/xmg-example/lexicon/demo-morph-latin1.mph
deleted file mode 100644
--- a/examples/xmg-example/lexicon/demo-morph-latin1.mph
+++ /dev/null
@@ -1,24 +0,0 @@
-aime aimer [pos = v; mode = ind; pers = 1; num = sg;]
-aime aimer [pos = v; mode = ind; pers = 3; num = sg;]
-aiment aimer [pos = v; mode = ind; pers = 3; num = pl;]
-aimé aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = m;]
-aimée aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = f;]
-appelle appeler [pos = v; mode = ind; pers = 1; num = sg;]
-appelle appeler [pos = v; mode = ind; pers = 3; num = sg;]
-appellent appeler [pos = v; mode = ind; pers = 3; num = pl;]
-appelé appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = m;]
-appelée appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = f;]
-elle il [pos = cl; refl = -; pers = 3; gen = f; num = sg;]
-elle lui [pos = cl; refl = -; pers = 3; gen = f; num = sg;]
-elle moi [pos = n; gen = f; num = sg;]
-elles il [pos = cl; refl = -; pers = 3; gen = f; num = pl;]
-elles lui [pos = cl; refl = -; pers = 3; gen = f; num = pl;]
-elles moi [pos = n; pers = 3; gen = f; num = pl]
-est etre [pos = v; mode = ind; pers = 3; num = sg;]
-es etre [pos = v; mode = ind; pers = 2; num = sg;]
-il il [pos = cl; refl = -; pers = 3; gen = m; num = sg;]
-ils il [pos = cl; refl = -; pers = 3; gen = m; num = pl;]
-jean jean [pos = n; det = +; gen = m; num = sg;]
-marie marie [pos = n; pers = 3; gen = f; num = sg;]
-par par [pos = p;]
-qui qui [pos = c;]
diff --git a/examples/xmg-example/lexicon/demo-morph-utf8.mph b/examples/xmg-example/lexicon/demo-morph-utf8.mph
new file mode 100644
--- /dev/null
+++ b/examples/xmg-example/lexicon/demo-morph-utf8.mph
@@ -0,0 +1,24 @@
+aime aimer [pos = v; mode = ind; pers = 1; num = sg;]
+aime aimer [pos = v; mode = ind; pers = 3; num = sg;]
+aiment aimer [pos = v; mode = ind; pers = 3; num = pl;]
+aimé aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = m;]
+aimée aimer [pos = v; mode = ppart; pp-num = sg; pp-gen = f;]
+appelle appeler [pos = v; mode = ind; pers = 1; num = sg;]
+appelle appeler [pos = v; mode = ind; pers = 3; num = sg;]
+appellent appeler [pos = v; mode = ind; pers = 3; num = pl;]
+appelé appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = m;]
+appelée appeler [pos = v; mode = ppart; pp-num = sg; pp-gen = f;]
+elle il [pos = cl; refl = -; pers = 3; gen = f; num = sg;]
+elle lui [pos = cl; refl = -; pers = 3; gen = f; num = sg;]
+elle moi [pos = n; gen = f; num = sg;]
+elles il [pos = cl; refl = -; pers = 3; gen = f; num = pl;]
+elles lui [pos = cl; refl = -; pers = 3; gen = f; num = pl;]
+elles moi [pos = n; pers = 3; gen = f; num = pl]
+est etre [pos = v; mode = ind; pers = 3; num = sg;]
+es etre [pos = v; mode = ind; pers = 2; num = sg;]
+il il [pos = cl; refl = -; pers = 3; gen = m; num = sg;]
+ils il [pos = cl; refl = -; pers = 3; gen = m; num = pl;]
+jean jean [pos = n; det = +; gen = m; num = sg;]
+marie marie [pos = n; pers = 3; gen = f; num = sg;]
+par par [pos = p;]
+qui qui [pos = c;]
diff --git a/examples/xmg-example/suite b/examples/xmg-example/suite
--- a/examples/xmg-example/suite
+++ b/examples/xmg-example/suite
diff --git a/src/EnableGUI.hs b/src/EnableGUI.hs
deleted file mode 100644
--- a/src/EnableGUI.hs
+++ /dev/null
@@ -1,38 +0,0 @@
--- this is just to get the GUI running on my mac, no big deal
--- note: for Observe.lhs: -fglasgow-exts -cpp -package concurrent
-
-module EnableGUI(enableGUI) where
-
-import Data.Int
-import Foreign
-import qualified Main as Main2
-
-{-
-import Posix
-import Concurrent
-import Control.Exception
-catchCtrlC = do
- main_thread <- myThreadId
- installHandler sigINT (Catch (hupHandler main_thread)) Nothing
- where
- hupHandler :: ThreadId -> IO ()
- hupHandler main_thread
- = throwTo main_thread (ErrorCall "Control-C")
--}
-
-main = do (enableGUI >> Main2.main)
-
-type ProcessSerialNumber = Int64
-
-foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16
-foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO ()
-foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO ()
-foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO ()
-foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO ()
-
-enableGUI = alloca $ \psn -> do
- getCurrentProcess psn
- cgsDefaultConnection
- cpsEnableForegroundOperation psn
- cpsSignalAppReady psn
- cpsSetFrontProcess psn
diff --git a/src/MainGeni.lhs b/src/MainGeni.lhs
--- a/src/MainGeni.lhs
+++ b/src/MainGeni.lhs
@@ -28,19 +28,35 @@
\ignore{
\begin{code}
+import Control.Applicative ((<$>))
import Data.IORef(newIORef)
-import System.Environment(getArgs)
+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 (treatStandardArgs, processInstructions,
- hasFlagP, BatchDirFlg(..), DisableGuiFlg(..), FromStdinFlg(..),
+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)
-#ifndef DISABLE_GUI
-import NLP.GenI.Gui(guiGeni)
+#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}
@@ -66,18 +82,40 @@
\begin{code}
main :: IO ()
main = do
- args <- getArgs
- confArgs <- treatStandardArgs args >>= processInstructions
+ pname <- getProgName
+ args <- getArgs
+ confArgs <- forceGuiFlag <$> (processInstructions =<< treatArgs optionsForStandardGenI args)
let pst = emptyProgState confArgs
pstRef <- newIORef pst
- let batch = hasFlagP BatchDirFlg confArgs
- console = hasFlagP DisableGuiFlg confArgs
- fromstdin = hasFlagP FromStdinFlg confArgs
- regression = hasFlagP RegressionTestModeFlg confArgs
- unit = hasFlagP RunUnitTestFlg confArgs
- if (fromstdin || console || batch || regression || unit)
- then consoleGeni pstRef
- else guiGeni pstRef
+ 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
diff --git a/src/NLP/GenI/Automaton.hs b/src/NLP/GenI/Automaton.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/Automaton.hs
@@ -0,0 +1,136 @@
+-- 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.
+
+
+-- TODO: I'd love to reuse some other library out there, but Leon P. Smith's
+-- Automata library requires us to know before-hand the size of our alphabet,
+-- Maybe HaLeX?
+
+-- | This module provides a simple, naive implementation of nondeterministic
+-- finite automata (NFA).
+--
+-- The transition function consists of a 'Map', but there are also accessor
+-- function which help you query the automaton without worrying about how
+-- it's implemented.
+--
+-- 1. The states are a list of lists, not just a simple flat list as
+-- you might expect. This allows you to optionally group your
+-- states into \"columns\" which is something we use in the
+-- GenI polarity automaton optimisation.
+--
+-- 2. We model the empty an empty transition as the transition on
+-- @Nothing@. All other transitions are @Just@ something.
+module NLP.GenI.Automaton
+ ( NFA(..),
+ finalSt,
+ addTrans, lookupTrans,
+ automatonPaths, automatonPathSets,
+ numStates, numTransitions )
+where
+
+import qualified Data.Map as Map
+import Data.Maybe (catMaybes)
+
+import NLP.GenI.General (combinations)
+
+
+-- | Note: you can define the final state either by setting 'isFinalSt'
+-- to @Just f@ where @f@ is some function or by putting them in
+-- 'finalStList'
+data NFA st ab = NFA
+ { startSt :: st
+ , isFinalSt :: Maybe (st -> Bool) -- ^ 'finalSt' will use this if defined
+ , finalStList :: [st] -- ^ can be ignored if 'isFinalSt' is defined
+ --
+ , transitions :: Map.Map st (Map.Map st [Maybe ab])
+ -- ^ there can be more than one transition between any two states
+ -- and a transition could be the empty symbol
+ , states :: [[st]] -- ^ if you don't care about grouping states into columns
+ -- you can just dump everything in one big list
+ }
+
+-- | 'finalSt' returns all the final states of an automaton
+finalSt :: NFA st ab -> [st]
+finalSt aut =
+ case isFinalSt aut of
+ Nothing -> finalStList aut
+ Just fn -> concatMap (filter fn) (states aut)
+
+-- | 'lookupTrans' @aut st1 ab@ returns the states that @st1@ transitions
+-- to via @a@.
+lookupTrans :: (Ord ab, Ord st) => NFA st ab -> st -> (Maybe ab) -> [st]
+lookupTrans aut st ab = Map.keys $ Map.filter (elem ab) subT
+ where subT = Map.findWithDefault Map.empty st (transitions aut)
+
+addTrans :: (Ord ab, Ord st) =>
+ NFA st ab
+ -> st -- ^ from state
+ -> Maybe ab -- ^ transition
+ -> st -- ^ to state
+ -> NFA st ab
+addTrans aut st1 ab st2 =
+ aut { transitions = Map.insert st1 newSubT oldT }
+ where oldT = transitions aut
+ oldSubT = Map.findWithDefault Map.empty st1 oldT
+ newSubT = Map.insertWith (++) st2 [ab] oldSubT
+
+-- | Returns all possible paths through an automaton from the
+-- start state to any dead-end.
+--
+-- Each path is represented as a list of labels.
+--
+-- We assume that the automaton does not have any loops
+-- in it.
+automatonPaths :: (Ord st, Ord ab) => (NFA st ab) -> [[ab]]
+automatonPaths aut = concatMap combinations $ map (filter (not.null)) $ automatonPathSets aut
+
+-- | The set of all bundled paths. A bundled path is a sequence of
+-- states through the automaton from the start state to any dead
+-- end. Any two neighbouring states can have more than one
+-- possible transition between them, so the bundles can multiply
+-- out to a lot of different possible paths.
+--
+-- The output is a list of lists of lists:
+--
+-- * Each item in the outer list is a bundled path through the
+-- automaton, i.e. without distinguishing between the possible
+-- transitions from any two neighbouring states
+--
+-- * Each item in the middle list is represents the set of
+-- transitions between two given neighbouring states
+--
+-- * Each item in the inner list represents a transition
+-- between two given states
+automatonPathSets :: (Ord st, Ord ab) => (NFA st ab) -> [[ [ab] ]]
+automatonPathSets aut = helper (startSt aut)
+ where
+ transFor st = Map.toList `fmap` Map.lookup st (transitions aut)
+ -- all the states you can get to from @st@ (and how to get there)
+ -- (one item per state)
+ helper st = maybe [] (concatMap next) $ transFor st
+ next (st2, mtr) =
+ case helper st2 of
+ [] -> [[labels]]
+ res -> map (labels :) res
+ where labels = catMaybes mtr
+
+numStates :: NFA st ab -> Int
+numStates = sum . (map length) . states
+
+numTransitions :: NFA st ab -> Int
+numTransitions = sum . (map subTotal) . (Map.elems) . transitions
+ where subTotal = sum . (map length) . (Map.elems)
diff --git a/src/NLP/GenI/Automaton.lhs b/src/NLP/GenI/Automaton.lhs
deleted file mode 100644
--- a/src/NLP/GenI/Automaton.lhs
+++ /dev/null
@@ -1,140 +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{Automaton}
-\label{cha:Automaton}
-
-\begin{code}
-module NLP.GenI.Automaton
- ( NFA(..),
- finalSt,
- addTrans, lookupTrans,
- automatonPaths, automatonPathSets,
- numStates, numTransitions )
-where
-
-import qualified Data.Map as Map
-import Data.Maybe (catMaybes)
-
-import NLP.GenI.General (combinations)
-\end{code}
-
-This module provides a simple, naive implementation of nondeterministic
-finite automata (NFA). The transition function consists of a Map, but
-there are also accessor function which help you query the automaton
-without worrying about how it's implemented.
-
-\begin{enumerate}
-\item The states are a list of lists, not just a simple flat list as
- you might expect. This allows you to optionally group your
- states into ``columns'' (which is something we use in the
- GenI polarity automaton optimisation). If you don't want
- columns, you can just make one big group out of all your states.
-\item We model the empty an empty transition as the transition on
- Nothing. All other transitions are Just something.
-\item I'd love to reuse some other library out there, but Leon P. Smith's
- Automata library requires us to know before-hand the size of our alphabet,
- which is highly unacceptable for this task.
-\end{enumerate}
-
-\begin{code}
--- | Note: there are two ways to define the final states.
--- 1. you may define them as a list of states in finalStList
--- 2. you may define them via the isFinalSt function
--- The state list is ignored if you define 'isFinalSt'
-data NFA st ab = NFA
- { startSt :: st
- , isFinalSt :: Maybe (st -> Bool)
- , finalStList :: [st]
- --
- , transitions :: Map.Map st (Map.Map st [Maybe ab])
- -- see chapter comments about list of list
- , states :: [[st]]
- }
-\end{code}
-
-% ----------------------------------------------------------------------
-\section{Building automata}
-% ----------------------------------------------------------------------
-
-\fnlabel{finalSt} returns all the final states of an automaton
-
-\begin{code}
-finalSt :: NFA st ab -> [st]
-finalSt aut =
- case isFinalSt aut of
- Nothing -> finalStList aut
- Just fn -> concatMap (filter fn) (states aut)
-\end{code}
-
-\fnlabel{lookupTrans} takes an automaton, a state \fnparam{st1} and an
-element \fnparam{ab} of the alphabet; and returns the state that
-\fnparam{st1} transitions to via \fnparam{a}, if possible.
-
-\begin{code}
-lookupTrans :: (Ord ab, Ord st) => NFA st ab -> st -> (Maybe ab) -> [st]
-lookupTrans aut st ab = Map.keys $ Map.filter (elem ab) subT
- where subT = Map.findWithDefault Map.empty st (transitions aut)
-\end{code}
-
-\begin{code}
-addTrans :: (Ord ab, Ord st) => NFA st ab -> st -> Maybe ab -> st -> NFA st ab
-addTrans aut st1 ab st2 =
- aut { transitions = Map.insert st1 newSubT oldT }
- where oldT = transitions aut
- oldSubT = Map.findWithDefault Map.empty st1 oldT
- newSubT = Map.insertWith (++) st2 [ab] oldSubT
-\end{code}
-
-% ----------------------------------------------------------------------
-\section{Exploiting automata}
-% ----------------------------------------------------------------------
-
-\fnlabel{automatonPaths} returns all possible paths through an
-automaton. Each path is represented as a list of labels.
-
-We assume that the automaton does not have any loops
-in it. Maybe it would still work if there were loops, with lazy
-evaluation, but I haven't had time to think this through, so only
-try it unless you're feeling adventurous.
-
-FIXME: we should write some unit tests and quickchecks for this
-\begin{code}
-automatonPaths :: (Ord st, Ord ab) => (NFA st ab) -> [[ab]]
-automatonPaths aut = concatMap combinations $ map (filter (not.null)) $ automatonPathSets aut
-
--- | Not quite the set of all paths, but the sets of all transitions
---- FIXME: explain later
-automatonPathSets :: (Ord st, Ord ab) => (NFA st ab) -> [[ [ab] ]]
-automatonPathSets aut = helper (startSt aut)
- where
- transFor st = Map.lookup st (transitions aut)
- helper st = case transFor st of
- Nothing -> []
- Just subT -> concat [ (next (catMaybes tr) st2) | (st2, tr) <- Map.toList subT ]
- next tr st2 = case helper st2 of
- [] -> [[tr]]
- res -> map (tr :) res
-\end{code}
-
-\begin{code}
-numStates, numTransitions :: NFA st ab -> Int
-numStates = sum . (map length) . states
-numTransitions = sum . (map subTotal) . (Map.elems) . transitions
- where subTotal = sum . (map length) . (Map.elems)
-\end{code}
-
diff --git a/src/NLP/GenI/Btypes.lhs b/src/NLP/GenI/Btypes.lhs
--- a/src/NLP/GenI/Btypes.lhs
+++ b/src/NLP/GenI/Btypes.lhs
@@ -23,15 +23,16 @@
low-level and primitive (well, with the exception of feature structure
unification, that is).
+\ignore{
\begin{code}
-{-# GHC_OPTIONS -fglasgow-exts #-}
--- {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
+{-# 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(..),
+ Pred, Flist, AvPair(..), GeniVal(..),
Lexicon, ILexEntry(..), MorphLexEntry, Macros, Sem, LitConstr, SemInput, Subst,
emptyLE, emptyGNode, emptyMacro,
@@ -51,7 +52,7 @@
showFlist, showPairs, showAv,
-- Other functions
- Replacable(..), replaceOneAsMap,
+ replace, DescendGeniVal(..), replaceList,
Collectable(..), Idable(..),
alphaConvert, alphaConvertById,
fromGConst, fromGVar,
@@ -59,25 +60,24 @@
-- Polarities
- -- Tests
- prop_unify_anon, prop_unify_self, prop_unify_sym
) where
-\end{code}
-\ignore{
-\begin{code}
+
-- import Debug.Trace -- for test stuff
-import Control.Monad (liftM)
import Data.List
-import Data.Maybe (fromMaybe, isJust, mapMaybe)
+import Data.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 Test.QuickCheck hiding (collect) -- needed for testing via ghci
-import NLP.GenI.General(map', filterTree, listRepNode, snd3, geniBug, comparing)
+import Data.Generics.PlateDirect
+
+import NLP.GenI.General(filterTree, listRepNode, snd3, geniBug)
+import NLP.GenI.GeniVal
+
--instance Show (IO()) where
-- show _ = ""
\end{code}
@@ -111,14 +111,26 @@
data Ptype = Initial | Auxiliar | Unspecified
deriving (Show, Eq, Data, Typeable)
-instance (Replacable a) => Replacable (Ttree a) where
- replaceMap s mt =
- mt { params = replaceMap s (params mt)
- , tree = replaceMap s (tree mt)
- , pinterface = replaceMap s (pinterface mt)
- , psemantics = replaceMap s (psemantics mt) }
- replaceOne = replaceOneAsMap
+instance 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)
@@ -155,14 +167,22 @@
, isempols :: [SemPols] }
deriving (Show, Eq, Data, Typeable)
-instance Replacable ILexEntry where
- replaceMap s i =
- i { iinterface = replaceMap s (iinterface i)
- , iequations = replaceMap s (iequations i)
- , isemantics = replaceMap s (isemantics i)
- , iparams = replaceMap s (iparams i) }
- replaceOne = replaceOneAsMap
+instance 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) .
@@ -185,20 +205,16 @@
\end{code}
% ----------------------------------------------------------------------
-\section{GNode}
+\section{TAG nodes (GNode)}
% ----------------------------------------------------------------------
-A GNode is a single node of a syntactic tree. It has a name (gnname),
-top and bottom feature structures (gup, gdown), a lexeme
-(ganchor, glexeme: False and empty string if n/a), and some flags
-information (gtype, gaconstr).
-
\begin{code}
+-- | A single node of a TAG tree.
data GNode = GN{gnname :: NodeName,
- gup :: Flist,
- gdown :: Flist,
- ganchor :: Bool,
- glexeme :: [String],
+ 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
@@ -206,6 +222,15 @@
}
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)
@@ -235,7 +260,7 @@
-- | Return the value of the "cat" attribute, if available
gCategory :: Flist -> Maybe GeniVal
gCategory top =
- case [ v | (a,v) <- top, a == "cat" ] of
+ case [ v | AvPair "cat" v <- top ] of
[] -> Nothing
[c] -> Just c
_ -> geniBug $ "Impossible case: node with more than one category"
@@ -281,13 +306,10 @@
feature structures
\begin{code}
-instance Replacable GNode where
- replaceOne s gn =
- gn { gup = replaceOne s (gup gn)
- , gdown = replaceOne s (gdown gn) }
- replaceMap s gn =
- gn { gup = replaceMap s (gup gn)
- , gdown = replaceMap s (gdown gn) }
+instance DescendGeniVal GNode where
+ descendGeniVal s gn =
+ gn { gup = descendGeniVal s (gup gn)
+ , gdown = descendGeniVal s (gdown gn) }
\end{code}
% ----------------------------------------------------------------------
@@ -295,14 +317,6 @@
% ----------------------------------------------------------------------
\begin{code}
-instance (Replacable a) => Replacable (Tree a) where
- replaceOne s t = fmap (replaceOne s) t
- replaceMap s t = fmap (replaceMap s) t
-\end{code}
-
-Projector and Update function for Tree
-
-\begin{code}
root :: Tree a -> a
root (Node a _) = a
@@ -341,7 +355,7 @@
\subsection{Substitution and Adjunction}
-This module handles the strictly syntactic part of the TAG substitution and
+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.
@@ -390,43 +404,12 @@
\begin{code}
type Flist = [AvPair]
-type AvPair = (String,GeniVal)
-\end{code}
-
-\subsection{GeniVal}
-
-\begin{code}
-data GeniVal = GConst [String]
- | GVar !String
- | GAnon
- deriving (Eq,Ord, Data, Typeable)
-
-instance Show GeniVal where
- show (GConst x) = concat $ intersperse "|" x
- show (GVar x) = '?':x
- show GAnon = "?_"
-
-isConst :: GeniVal -> Bool
-isConst (GConst _) = True
-isConst _ = False
-
-isVar :: GeniVal -> Bool
-isVar (GVar _) = True
-isVar _ = False
-
-isAnon :: GeniVal -> Bool
-isAnon GAnon = True
-isAnon _ = False
-
--- | (assumes that it's a GConst!)
-fromGConst :: GeniVal -> [String]
-fromGConst (GConst x) = x
-fromGConst x = error ("fromGConst on " ++ show x)
+data AvPair = AvPair { avAtt :: String
+ , avVal :: GeniVal }
+ deriving (Ord, Eq, Data, Typeable)
--- | (assumes that it's a GVar!)
-fromGVar :: GeniVal -> String
-fromGVar (GVar x) = x
-fromGVar x = error ("fromGVar on " ++ show x)
+instance Biplate AvPair GeniVal where
+ biplate (AvPair a v) = plate AvPair |- a |* v
\end{code}
\subsection{Collectable}
@@ -461,14 +444,14 @@
collect (GVar v) s = Set.insert v s
collect _ s = s
-instance Collectable (String,GeniVal) where
- collect (_,b) = collect b
+instance Collectable AvPair where
+ collect (AvPair _ b) = collect b
instance Collectable GNode where
collect n = (collect $ gdown n) . (collect $ gup n)
\end{code}
-\subsection{Replacable}
+\subsection{DescendGeniVal}
\label{sec:replacable}
\label{sec:replacements}
@@ -477,74 +460,34 @@
making a type class out of it.
\begin{code}
-class Replacable a where
- replace :: Subst -> a -> a
- replace = replaceMap
- replaceMap :: Map.Map String GeniVal -> a -> a
-
- replaceOne :: (String,GeniVal) -> a -> a
-
- -- | Here it is safe to say (X -> Y; Y -> Z) because this would be crushed
- -- down into a final value of (X -> Z; Y -> Z)
- replaceList :: [(String,GeniVal)] -> a -> a
- replaceList = replaceMap . foldl update Map.empty
- where
- update m (s1,s2) = Map.insert s1 s2 $ Map.map (replaceOne (s1,s2)) m
-
--- | Default implementation for replaceOne but not a good idea for the
--- core stuff; which is why it is not a typeclass default
-replaceOneAsMap :: Replacable a => (String, GeniVal) -> a -> a
-replaceOneAsMap s = replaceMap (uncurry Map.singleton s)
-
-instance (Replacable a => Replacable (Maybe a)) where
- replaceMap s = liftM (replaceMap s)
- replaceOne s = liftM (replaceOne s)
\end{code}
-GeniVal is probably the simplest thing you would one to apply a
-substitution on
-
-\begin{code}
-instance Replacable GeniVal where
- replaceMap m v@(GVar v_) = {-# SCC "replaceMap" #-} Map.findWithDefault v v_ m
- replaceMap _ v = {-# SCC "replaceMap" #-} v
-
- replaceOne (s1, s2) (GVar v_) | v_ == s1 = {-# SCC "replaceOne" #-} s2
- replaceOne _ v = {-# SCC "replaceOne" #-} v
-\end{code}
-
Substitution on list consists of performing substitution on
each item. Each item, is independent of the other,
of course.
\begin{code}
-instance (Replacable a => Replacable [a]) where
- replaceMap s = {-# SCC "replaceMap" #-} map' (replaceMap s)
- replaceOne s = {-# SCC "replaceOne" #-} map' (replaceOne s)
-\end{code}
+instance DescendGeniVal a => DescendGeniVal (Map.Map k a) where
+ descendGeniVal s = {-# SCC "descendGeniVal" #-} Map.map (descendGeniVal s)
-Substitution on an attribute/value pairs consists of ignoring
-the attribute and performing substitution on the value.
+instance DescendGeniVal AvPair where
+ descendGeniVal s (AvPair a v) = {-# SCC "descendGeniVal" #-} AvPair a (descendGeniVal s v)
-\begin{code}
-instance Replacable AvPair where
- replaceMap s (a,v) = {-# SCC "replaceMap" #-} (a, replaceMap s v)
- replaceOne s (a,v) = {-# SCC "replaceOne" #-} (a, replaceOne s v)
+instance DescendGeniVal a => DescendGeniVal (String, a) where
+ descendGeniVal s (n,v) = {-# SCC "descendGeniVal" #-} (n,descendGeniVal s v)
-instance Replacable (String, ([String], Flist)) where
- replaceMap s (n,(a,v)) = {-# SCC "replaceMap" #-} (n,(a, replaceMap s v))
- replaceOne s (n,(a,v)) = {-# SCC "replaceOne" #-} (n,(a, replaceOne s v))
+instance DescendGeniVal ([String], Flist) where
+ descendGeniVal s (a,v) = {-# SCC "descendGeniVal" #-} (a, descendGeniVal s v)
\end{code}
\subsection{Idable}
-An Idable is something that can be mapped to a unique id.
-You might consider using this to implement Ord, but I won't.
-Note that the only use I have for this so far (20 dec 2005)
-is in alpha-conversion.
-
\begin{code}
+-- | 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}
@@ -556,22 +499,22 @@
why we want this.
\begin{code}
-alphaConvertById :: (Collectable a, Replacable a, Idable a) => a -> a
+alphaConvertById :: (Collectable a, DescendGeniVal a, Idable a) => a -> a
alphaConvertById x = {-# SCC "alphaConvertById" #-}
alphaConvert ('-' : (show . idOf $ x)) x
-alphaConvert :: (Collectable a, Replacable a) => String -> a -> a
+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 replaceMap subst x
+ in replace subst x
\end{code}
\begin{code}
-- | Sort an Flist according with its attributes
sortFlist :: Flist -> Flist
-sortFlist = sortBy (comparing fst)
+sortFlist = sortBy (compare `on` avAtt)
showFlist :: Flist -> String
showFlist f = "[" ++ showPairs f ++ "]"
@@ -580,7 +523,10 @@
showPairs = unwords . map showAv
showAv :: AvPair -> String
-showAv (y,z) = y ++ ":" ++ show z
+showAv (AvPair y z) = y ++ ":" ++ show z
+
+instance Show AvPair where
+ show = showAv
\end{code}
% ----------------------------------------------------------------------
@@ -594,8 +540,14 @@
type Sem = [Pred]
type LitConstr = (Pred, [String])
type SemInput = (Sem,Flist,[LitConstr])
-type Subst = Map.Map String GeniVal
+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
@@ -612,9 +564,8 @@
A replacement on a predicate is just a replacement on its parameters
\begin{code}
-instance Replacable Pred where
- replaceMap s (h, n, lp) = (replaceMap s h, replaceMap s n, replaceMap s lp)
- replaceOne s (h, n, lp) = (replaceOne s h, replaceOne s n, replaceOne s lp)
+instance DescendGeniVal Pred where
+ descendGeniVal s (h, n, lp) = (descendGeniVal s h, descendGeniVal s n, descendGeniVal s lp)
\end{code}
\begin{code}
@@ -716,7 +667,7 @@
\end{code}
% --------------------------------------------------------------------
-\subsection{Unification}
+\subsection{Feature structure unification}
\label{sec:fs_unification}
% --------------------------------------------------------------------
@@ -765,224 +716,42 @@
\fs{\it cat:np\\ \it case:nom\\ \it number:3\\},
\end{quotation}
-\fnlabel{unifyFeat} is an implementation of feature structure
-unification. It makes the following assumptions:
-
-\begin{itemize}
-\item Features are ordered
-
-\item The Flists do not share variables!!!
-
- More precisely, if the two Flists have the same variable, they
- will have the same value. Though this behaviour may not be
- desirable, we don't really care because we never encounter the
- situation (see page \pageref{par:lexSelection}).
-\end{itemize}
-
\begin{code}
-unifyFeat :: (Monad m) => Flist -> Flist -> m (Flist, Subst)
+-- | 'unifyFeat' 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) = alignFeat f1 f2
+ let (att, val1, val2) = unzip3 $ alignFeat f1 f2
in att `seq`
do (res, subst) <- unify val1 val2
- return (zip att res, subst)
-\end{code}
-
-\fnlabel{alignFeat}
-
-The less trivial case is when neither list is empty. If we are looking
-at the same attribute, then we transfer control to the helper function.
-Otherwise, we remove the (alphabetically) smaller att-val pair, add it
-to the results, and move on. This only works if the lists are
-alphabetically sorted beforehand!
-
-\begin{code}
-alignFeat :: Flist -> Flist -> ([String], [GeniVal], [GeniVal])
-alignFeat [] [] = ([], [], [])
-
-alignFeat [] ((f,v):x) =
- case alignFeat [] x of
- (att, left, right) -> (f:att, GAnon:left, v:right)
-
-alignFeat x [] =
- case alignFeat [] x of
- (att, left, right) -> (att, right, left)
-
-alignFeat fs1@((f1, v1):l1) fs2@((f2, v2):l2)
- | f1 == f2 = case alignFeat l1 l2 of
- (att, left, right) -> (f1:att, v1:left, v2:right)
- | f1 < f2 = case alignFeat l1 fs2 of
- (att, left, right) -> (f1:att, v1:left, GAnon:right)
- | f1 > f2 = case alignFeat fs1 l2 of
- (att, left, right) -> (f2:att, GAnon:left, v2:right)
- | otherwise = error "Feature structure unification is badly broken"
-\end{code}
-
-\subsection{Unification}
-
-\fnlabel{unify} performs unification on two lists of GeniVal. If
-unification succeeds, it returns \verb!Just (r,s)! where \verb!r! is
-the result of unification and \verb!s! is a list of substitutions that this
-unification results in.
-
-Notes:
-\begin{itemize}
-\item there may be multiple results because of disjunction
-\item we need to return \verb!r! because of anonymous variables
-\item the lists need not be same length; we just assume you want
- the longer of the two
-\end{itemize}
-
-The core unification algorithm follows these rules in order:
-
-\begin{enumerate}
-\item if either h1 or h2 are anonymous, we add the other to the result,
- and we don't add any replacements.
-\item if h1 is a variable then we replace it by h2,
- regardless of whether or not h2 is a variable
-\item if h2 is a variable then we replace it by h1
-\item if neither h1 and h2 are variables, but they match, we arbitarily
- add one of them to the result, but we don't add any replacements.
-\item if neither are variables and they do \emph{not} match, we fail
-\end{enumerate}
-
-\begin{code}
-unify :: (Monad m) => [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
-unify [] l2 = {-# SCC "unification" #-} return (l2, Map.empty)
-unify l1 [] = {-# SCC "unification" #-} return (l1, Map.empty)
-unify (h1:t1) (h2:t2) | h1 == h2 = {-# SCC "unification" #-} unifySansRep h1 t1 t2
-unify (GAnon:t1) (h2:t2) = {-# SCC "unification" #-} unifySansRep h2 t1 t2
-unify (h1:t1) (GAnon:t2) = {-# SCC "unification" #-} unifySansRep h1 t1 t2
-unify (h1@(GVar _):t1) (h2:t2) = {-# SCC "unification" #-} unifyWithRep h1 h2 t1 t2
-unify (h1:t1) (h2@(GVar _):t2) = {-# SCC "unification" #-} unifyWithRep h2 h1 t1 t2
--- special cases for efficiency only
-unify ((GConst [_]):_) ((GConst [_]):_) = {-# SCC "unification" #-}
- fail "unification failure"
--- end special efficiency-only cases
-unify ((GConst h1v):t1) ((GConst h2v):t2) = {-# SCC "unification" #-}
- case h1v `intersect` h2v of
- [] -> fail "unification failure"
- newH -> unifySansRep (GConst newH) t1 t2
-{-# INLINE unifySansRep #-}
-{-# INLINE unifyWithRep #-}
-unifySansRep :: (Monad m) => GeniVal -> [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
-unifySansRep x2 t1 t2 = {-# SCC "unification" #-}
- do (res,subst) <- unify t1 t2
- return (x2:res, subst)
-
-unifyWithRep :: (Monad m) => GeniVal -> GeniVal -> [GeniVal] -> [GeniVal] -> m ([GeniVal], Subst)
-unifyWithRep (GVar h1) x2 t1 t2 = {-# SCC "unification" #-}
- let s = (h1,x2)
- t1_ = replaceOne s t1
- t2_ = replaceOne s t2
- ustep = unify t1_ t2_
- in s `seq` t1_ `seq` t2_ `seq` ustep `seq`
- (ustep >>= \(res,subst) -> return (x2:res, prependToSubst s subst))
-unifyWithRep _ _ _ _ = geniBug "unification error"
-\end{code}
+ return (zipWith AvPair att res, subst)
-\begin{code}
--- | Note that the first Subst is assumed to come chronologically
--- before the second one; so merging @{ X -> Y }@ and @{ Y -> 3 }@
--- should give us @{ X -> 3; Y -> 3 }@;
+-- | '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.
--
--- See 'prependToSubst' for a warning!
-mergeSubst :: Subst -> Subst -> Subst
-mergeSubst sm1 sm2 = Map.foldWithKey (curry prependToSubst) sm2 sm1
+-- The two feature structures must be sorted for this to work
+alignFeat :: Flist -> Flist -> [(String,GeniVal,GeniVal)]
+alignFeat f1 f2 = alignFeatH f1 f2 []
--- | Add to variable replacement to a 'Subst' that logical comes before
--- the other stuff in it. So for example, if we have @Y -> foo@
--- and we want to insert @X -> Y@, we notice that, in fact, @Y@ has
--- already been replaced by @foo@, so we add @X -> foo@ instead
---
--- Note that it is undefined if you try to append something like
--- @Y -> foo@ to @Y -> bar@, because that would mean that unification
--- is broken
-prependToSubst :: (String,GeniVal) -> Subst -> Subst
-prependToSubst (v, gr@(GVar r)) sm
- | isJust $ Map.lookup v sm = geniBug $ "prependToSubst: Eric broke unification. Prepending " ++ v ++ " twice."
- | otherwise = Map.insert v gr2 sm
- where gr2 = fromMaybe gr $ Map.lookup r sm
-prependToSubst (v, gr) sm = Map.insert v gr sm
+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}
-\subsubsection{Unification tests} The unification algorithm should satisfy
-the following properties:
-Unifying something with itself should always succeed
-
-\begin{code}
-prop_unify_self :: [GeniVal] -> Property
-prop_unify_self x =
- (all qc_not_empty_GConst) x ==>
- case unify x x of
- Nothing -> False
- Just unf -> (fst unf == x)
-\end{code}
-
-Unifying something with only anonymous variables should succeed.
-
-\begin{code}
-prop_unify_anon :: [GeniVal] -> Bool
-prop_unify_anon x =
- case (unify x y) of
- Nothing -> False
- Just unf -> (fst unf == x)
- where --
- y = take (length x) $ repeat GAnon
-\end{code}
-
-Unification should be symmetrical. We can't guarantee these if there
-are cases where there are variables in the same place on both sides, so we
-normalise the sides so that this doesn't happen.
-
-\begin{code}
-prop_unify_sym :: [GeniVal] -> [GeniVal] -> Property
-prop_unify_sym x y =
- let u1 = (unify x y) :: Maybe ([GeniVal],Subst)
- u2 = unify y x
- --
- notOverlap (GVar _, GVar _) = False
- notOverlap _ = True
- in (all qc_not_empty_GConst) x &&
- (all qc_not_empty_GConst) y &&
- all (notOverlap) (zip x y) ==> u1 == u2
-\end{code}
-
-\ignore{
-\begin{code}
--- Definition of Arbitrary GeniVal for QuickCheck
-newtype GTestString = GTestString String
-newtype GTestString2 = GTestString2 String
-
-fromGTestString :: GTestString -> String
-fromGTestString (GTestString s) = s
-
-fromGTestString2 :: GTestString2 -> String
-fromGTestString2 (GTestString2 s) = s
-
-instance Arbitrary GTestString where
- arbitrary =
- oneof $ map (return . GTestString) $
- [ "a", "apple" , "b", "banana", "c", "carrot", "d", "durian"
- , "e", "eggplant", "f", "fennel" , "g", "grape" ]
- coarbitrary = error "no implementation of coarbitrary for GTestString"
-
-instance Arbitrary GTestString2 where
- arbitrary =
- oneof $ map (return . GTestString2) $
- [ "X", "Y", "Z", "H", "I", "J", "P", "Q", "R", "S", "T", "U" ]
- coarbitrary = error "no implementation of coarbitrary for GTestString2"
-
-instance Arbitrary GeniVal where
- arbitrary = oneof [ return $ GAnon,
- liftM (GVar . fromGTestString2) arbitrary,
- liftM (GConst . nub . sort . map fromGTestString) arbitrary ]
- coarbitrary = error "no implementation of coarbitrary for GeniVal"
-
-qc_not_empty_GConst :: GeniVal -> Bool
-qc_not_empty_GConst (GConst []) = False
-qc_not_empty_GConst _ = True
-\end{code}
-}
diff --git a/src/NLP/GenI/BtypesBinary.hs b/src/NLP/GenI/BtypesBinary.hs
--- a/src/NLP/GenI/BtypesBinary.hs
+++ b/src/NLP/GenI/BtypesBinary.hs
@@ -48,6 +48,11 @@
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.lhs b/src/NLP/GenI/Builder.lhs
--- a/src/NLP/GenI/Builder.lhs
+++ b/src/NLP/GenI/Builder.lhs
@@ -42,36 +42,44 @@
module NLP.GenI.Builder
where
-import Control.Monad.State
+import Control.Applicative ( (<$>), (<*>) )
+import Control.Monad.State.Strict
import Data.Bits ( (.&.), (.|.), bit, xor )
-import Data.List ( (\\), maximum )
+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, hasFlagP, Params,
+ ( getListFlagP, getFlagP, Params,
+ DetectPolaritiesFlg(..),
ExtraPolaritiesFlg(..), MetricsFlg(..),
- IgnoreSemanticsFlg(..), RootFeatureFlg(..),
- polarised )
+ RootFeatureFlg(..),
+ Optimisation(..), hasOpt,
+ )
import NLP.GenI.General (geniBug, BitVector, multiGroupByFM, fst3, snd3, thd3)
import NLP.GenI.Btypes
( ILexEntry, SemInput, Sem, Pred, showPred, showSem,
- Flist, gtype, GType(Subs, Foot),
- Collectable(collect), alphaConvertById,
+ 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,
- mergeMetrics, addIntMetrics,
queryMetrics, queryIntMetric,
addMetric, emptyStats,
)
-import NLP.GenI.Tags ( TagElem(idname,tsemantics,ttree), setTidnums, TagDerivation )
+import NLP.GenI.Tags ( TagElem(idname,tsemantics,ttree), setTidnums, TagDerivation, DerivationStep(..) )
\end{code}
}
@@ -103,7 +111,7 @@
, unpack :: st -> [Output]
, partial :: st -> [Output] }
-type Output = (UninflectedSentence, Derivation)
+type Output = (LemmaPlusSentence, Derivation)
type Derivation = TagDerivation
\end{code}
@@ -131,10 +139,18 @@
only requirement being that each one, naturally enough, is unique.
\begin{code}
-type UninflectedWord = (String, Flist)
-type UninflectedSentence = [ UninflectedWord ]
-type UninflectedDisjunction = ([String], Flist)
-type SentenceAut = NFA Int UninflectedWord
+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}
@@ -168,11 +184,13 @@
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 = polarised config
+ isPol = hasOpt Polarised config
-- polarity optimisation (if enabled)
- autstuff = buildAutomaton seminput cand rootFeat extraPol
+ autstuff = buildAutomaton polsToDetect rootFeat extraPol seminput cand
(_, seedAut, aut, sem2) = autstuff
autpaths = map concat $ automatonPathSets aut
combosPol = if isPol then autpaths else [cand]
@@ -192,7 +210,7 @@
-- | Equivalent to 'id' unless the input contains an empty or uninstatiated
-- semantics
unlessEmptySem :: Input -> Params -> a -> a
-unlessEmptySem input config =
+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 ]
@@ -200,7 +218,7 @@
unInstSemErr = "The following trees have an uninstantiated semantics: " ++ (unwords unInstSemCands)
semanticsErr = (if null nullSemCands then "" else nullSemErr ++ "\n") ++
(if null unInstSemCands then "" else unInstSemErr)
- in if (null semanticsErr || hasFlagP IgnoreSemanticsFlg config)
+ in if null semanticsErr
then id
else error semanticsErr
\end{code}
@@ -209,6 +227,24 @@
\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
@@ -290,7 +326,7 @@
fromUniConst _ = fail "not a unique constant" -- we don't actually expect this failure msg to be used
getIdx :: Flist -> [GeniVal]
-getIdx fs = [ v | (a,v) <- fs, a == "idx" ]
+getIdx fs = [ v | AvPair "idx" v <- fs ]
ts_iafFailure :: [String] -> [Pred] -> String
ts_iafFailure is sem = "index accesibility failure -" ++ (unwords is) ++ "- blocked: " ++ showSem sem
@@ -378,9 +414,6 @@
\subsection{Statistics}
\begin{code}
-addCounters :: Statistics -> Statistics -> Statistics
-addCounters = mergeMetrics addIntMetrics
-
modifyStats :: (Metric -> Metric) -> BuilderState st ()
modifyStats fn = lift $ modify $ updateMetrics fn
@@ -400,9 +433,9 @@
\begin{code}
initStats :: Params -> Statistics
initStats pa =
- let identifyMs :: [String] -> [Metric]
- identifyMs ["default"] = identifyMs defaultMetricNames
- identifyMs ms = map namedMetric ms
+ 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
@@ -449,6 +482,19 @@
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)
@@ -477,4 +523,40 @@
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/CkyEarley/CkyBuilder.lhs b/src/NLP/GenI/CkyEarley/CkyBuilder.lhs
deleted file mode 100644
--- a/src/NLP/GenI/CkyEarley/CkyBuilder.lhs
+++ /dev/null
@@ -1,1244 +0,0 @@
-% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
-%
-% This program is free software; you can redistribute it and/or
-% modify it under the terms of the GNU General Public License
-% as published by the Free Software Foundation; either version 2
-% of the License, or (at your option) any later version.
-%
-% This program is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with this program; if not, write to the Free Software
-% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-\chapter{Cky builder}
-\label{cha:CkyBuilder}
-
-GenI currently has three backends, SimpleBuilder (chapter
-\ref{cha:SimpleBuilder}) the CKY and Earley which are both in this
-module. This backend does not attempt to build derived trees at all.
-We construct packed derivation trees using the CKY/Earley algorithm for
-TAGs, and at the very end, we unpack the results directly into an
-automaton. No derived trees here!
-
-\begin{code}
-{-# OPTIONS_GHC -fglasgow-exts #-}
--- {-# LANGUAGE LiberalTypeSynonyms #-}
-module NLP.GenI.CkyEarley.CkyBuilder
- ( -- builder
- ckyBuilder, earleyBuilder,
- CkyStatus(..),
- -- chart item
- CkyItem(..), ChartId,
- ciAdjDone, ciRoot,
- extractDerivations,
- -- automaton stuff (for the graphical debugger)
- mJoinAutomata, mAutomatonPaths, emptySentenceAut, unpackItemToAuts,
- --
- bitVectorToSem, findId,
- )
-where
-\end{code}
-
-\ignore{
-\begin{code}
-
-import Control.Monad
- (unless, foldM)
-
-import Control.Monad.State
- (State, gets, get, put, modify, runState, execStateT )
-import Data.Bits ( (.&.), (.|.) )
-import Data.List ( delete, find, span, (\\), intersect, union )
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Maybe (catMaybes, mapMaybe, maybeToList)
-import Data.Tree
-
-import NLP.GenI.Btypes
- ( unify, collect
- , Flist
- , Replacable(..), Subst
- , GNode(..), GType(Subs, Foot, Other)
- , GeniVal(GVar), fromGVar
- , Ptype(Auxiliar)
- , root, foot
- , unifyFeat, mergeSubst )
-
-import NLP.GenI.Automaton
- ( NFA(NFA, transitions, states), isFinalSt, finalSt, finalStList, startSt, addTrans, automatonPaths )
-import qualified NLP.GenI.Builder as B
-import NLP.GenI.Builder
- ( SentenceAut, incrCounter, num_iterations, chart_size,
- SemBitMap, semToBitVector, bitVectorToSem, defineSemanticBits,
- (>-->), DispatchFilter,
- semToIafMap, IafAble(..), IafMap, fromUniConst, getIdx,
- recalculateAccesibility, iafBadSem, ts_iafFailure
- )
-import NLP.GenI.Configuration ( Params, isIaf )
-import NLP.GenI.General
- ( fst3, combinations, treeLeaves, BitVector, geniBug )
-import NLP.GenI.Tags
- ( TagElem, tidnum, ttree, tsemantics, ttype,
- ts_tbUnificationFailure, TagSite(TagSite), detectSites
- )
-import NLP.GenI.Statistics ( Statistics )
-
--- -- Debugging stuff
--- import Data.List ( intersperse )
--- import Debug.Trace
--- import General ( showBitVector )
--- import Tags ( idname )
---
--- ckyShow name item chart =
--- let showChart = show $ length chart
--- pad s n = s ++ (take (n - length s) $ repeat ' ')
--- in concat $ intersperse "\t" $
--- [ pad name 10, showChart
--- , pad (idname $ ciSourceTree item) 10
--- , pad (showItemSem item) 5
--- , show $ ciNode item ]
---
--- showItems = unlines . (map showItem)
--- showItem i = (idname.ciSourceTree) i ++ " " ++ show (ciNode i) ++ " " ++ (showItemSem i)
--- showItemSem = (showBitVector 5) . ciSemantics
-\end{code}
-}
-
-\section{Implementing the Builder interface}
-
-\begin{code}
-type CkyBuilder = B.Builder CkyStatus CkyItem Params
-
-ckyBuilder, earleyBuilder :: CkyBuilder
-ckyBuilder = ckyOrEarleyBuilder False
-earleyBuilder = ckyOrEarleyBuilder True
-
-ckyOrEarleyBuilder :: Bool -> CkyBuilder
-ckyOrEarleyBuilder isEarley = B.Builder
- { B.init = initBuilder isEarley
- , B.step = generateStep isEarley
- , B.stepAll = B.defaultStepAll (ckyOrEarleyBuilder isEarley)
- , B.finished = null.theAgenda
- , B.unpack = \s -> concatMap (unpackItem s) $ theResults s
- , B.partial = const [] -- FIXME: not implemented
- }
-\end{code}
-
-The rest of the builder interface is implemented below. I just
-wanted to put the front-end functions up on top.
-
-% --------------------------------------------------------------------
-\section{Key types}
-% --------------------------------------------------------------------
-
-\subsection{CkyState and CkyStatus}
-
-This terminology might be a bit confusing: \verb!CkyState! is just a
-\verb!BuilderState! monad parameterised over \verb!CkyStatus!. So,
-status contains the actual data and state handles all the monadic stuff.
-
-\begin{code}
-type CkyState a = B.BuilderState CkyStatus a
-
-data CkyStatus = S
- { theAgenda :: Agenda
- , theChart :: Chart
- , theTrash :: Trash
- , tsemVector :: BitVector -- the semantics in bit vector form
- , theIafMap :: IafMap -- for index accessibility filtering
- , gencounter :: Integer
- , genconfig :: Params
- , theRules :: [CKY_InferenceRule]
- , theDispatcher :: CkyItem -> CkyState (Maybe CkyItem)
- , theResults :: [CkyItem]
- , genAutCounter :: Integer -- allocation of node numbers
- }
-
-type Agenda = [CkyItem]
-type Chart = [CkyItem]
-type Trash = [CkyItem]
-\end{code}
-
-Note the theTrash is not actually essential to the operation of the
-generator; it is for pratical debugging of grammars. Instead of
-trees dissapearing off the face of the debugger; they go into the
-trash where the user can inspect them and try to figure out why they
-went wrong.
-
-\subsubsection{CkyState getters and setters}
-
-\begin{code}
-addToAgenda :: CkyItem -> CkyState ()
-addToAgenda te = do
- modify $ \s -> s{ theAgenda = te : (theAgenda s) }
-
-addToResults :: CkyItem -> CkyState ()
-addToResults te = do
- modify $ \s -> s{ theResults = te : (theResults s) }
-
-updateAgenda :: Agenda -> CkyState ()
-updateAgenda a = do
- modify $ \s -> s{ theAgenda = a }
-
-addToChart :: CkyItem -> CkyState ()
-addToChart te = do
- modify $ \s -> s { theChart = te : (theChart s) }
- incrCounter chart_size 1
-
-addToTrash :: CkyItem -> String -> CkyState ()
-addToTrash item err = do
- let item2 = item { ciDiagnostic = err:(ciDiagnostic item) }
- modify $ \s -> s { theTrash = item2 : (theTrash s) }
-\end{code}
-
-\subsection{Chart items}
-
--- TODO: decide if we want this to be an instant of Replacable
-\begin{code}
-data CkyItem = CkyItem
- { ciNode :: GNode
- -- things which should never change
- , ciSourceTree :: TagElem
- , ciOrigVariables :: [GeniVal]
- --
- , ciPolpaths :: BitVector
- , ciSemantics :: BitVector
- , ciAdjPoint :: Maybe ChartId
- -- | the semantics of the item when it was first initialised
- , ciInitialSem :: BitVector
- -- | unique identifier for this item
- , ciId :: ChartId
- -- names of the sisters of this node in its tree
- , ciRouting :: RoutingMap
- -- used by the next leaf rule (if active)
- , ciPayload :: [CkyItem]
- -- a list of genivals which were variables when the node was
- -- first initialised
- , ciVariables :: [GeniVal]
- -- we keep a SemBitMap strictly to help display the semantics
- , ciSemBitMap :: SemBitMap
- -- what side of the spine are we on? (left if initial tree: no spine)
- , ciTreeSide :: TreeSide
- -- if there are things wrong with this item, what?
- , ciDiagnostic :: [String]
- -- what is the set of the ways you can produce this item?
- , ciDerivation :: [ ChartOperation ]
- -- what indices are accesible/inaccesible from this item?
- , ciAccesible :: [ String ] -- it's acc/inacc/undetermined
- , ciInaccessible :: [ String ] -- that's why you want both
- , ciSubstnodes :: [ TagSite ] -- only used for iaf
- }
-
-type ChartId = Integer
-
--- | note that the order is always active item, followed by passive item
-data ChartOperation = SubstOp ChartId ChartId
- | AdjOp ChartId ChartId
- | NullAdjOp ChartId
- | KidsToParentOp [ChartId]
- | InitOp
- deriving Show -- for debugging
-
-type ChartOperationConstructor = ChartId -> ChartId -> ChartOperation
-
-ciRoot, ciFoot, ciSubs, ciAdjDone, ciAux, ciInit, ciComplete :: CkyItem -> Bool
-ciRoot i = (gnname.ciNode) i == (gnname.root.ttree.ciSourceTree) i
-ciFoot i = (gtype.ciNode) i == Foot
-ciSubs i = (gtype.ciNode) i == Subs
-ciAdjDone = gaconstr.ciNode
-ciComplete i = (not.ciSubs $ i) && ciAdjDone i
-ciAux i = (ttype.ciSourceTree) i == Auxiliar
-ciInit = not.ciAux
-
-data TreeSide = LeftSide | RightSide | OnTheSpine
- deriving (Eq)
-
-ciLeftSide, ciRightSide, ciOnTheSpine :: CkyItem -> Bool
-ciLeftSide i = ciTreeSide i == LeftSide
-ciRightSide i = ciTreeSide i == RightSide
-ciOnTheSpine i = ciTreeSide i == OnTheSpine
-
-
--- basically, an inverted tree
--- from node name to a list of its sisters on the left,
--- a list of its sisters on the right, its parent
-type RoutingMap = Map.Map String ([String], [String], GNode)
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Initialisation}
-% --------------------------------------------------------------------
-
-\begin{code}
-initBuilder :: Bool -> B.Input -> Params -> (CkyStatus, Statistics)
-initBuilder isEarley input config =
- let (sem, _, _) = B.inSemInput input
- bmap = defineSemanticBits sem
- cands = concatMap (initTree isEarley bmap) $ B.inCands input
- dispatchFn = ckyDispatch (isIaf config)
- initS = S
- { theAgenda = []
- , theChart = []
- , theTrash = []
- , theResults = []
- , theRules = map fst ckyRules
- , tsemVector = semToBitVector bmap sem
- , theIafMap = semToIafMap sem
- , theDispatcher = dispatchFn
- , gencounter = 0
- , genAutCounter = 0
- , genconfig = config }
- in B.unlessEmptySem input config $
- runState (execStateT (mapM dispatchFn cands) initS) (B.initStats config)
-\end{code}
-
-\subsection{Initialising a chart item}
-\label{fn:cky:initTree}
-
-\begin{code}
-initTree :: Bool -> SemBitMap -> (TagElem,BitVector) -> [CkyItem]
-initTree ordered bmap tepp@(te,_) =
- let semVector = semToBitVector bmap (tsemantics te)
- createItem l n = item
- { ciSemantics = semVector
- , ciInitialSem = semVector
- , ciSemBitMap = bmap
- , ciRouting = decompose te
- , ciVariables = map GVar $ Set.toList $ collect te Set.empty
- , ciAccesible = iafNewAcc item
- } where item = leafToItem l tepp n
- --
- (left,right) = span (\n -> gtype n /= Foot) $ treeLeaves $ ttree te
- items = map (createItem True) left ++ map (createItem False) right
- in if ordered
- then foldr (\i p -> [i { ciPayload = p }]) [] items
- else items
-
-leafToItem :: Bool
- -- ^ is it on the left of the foot node? (yes if there is none)
- -> (TagElem, BitVector)
- -- ^ what tree does it belong to
- -> GNode
- -- ^ the leaf to convert
- -> CkyItem
-leafToItem left (te,pp) node = CkyItem
- { ciNode = node
- , ciSourceTree = te
- , ciPolpaths = pp
- , ciSemantics = 0 -- to be set
- , ciInitialSem = 0 -- to be set
- , ciId = -1 -- to be set
- , ciRouting = Map.empty -- to be set
- , ciOrigVariables = [] -- to be set
- , ciVariables = [] -- to be set
- , ciPayload = [] -- to be set
- , ciAdjPoint = Nothing
- , ciSemBitMap = Map.empty
- , ciTreeSide = spineSide
- , ciDiagnostic = []
- , ciAccesible = [] -- to be set
- , ciInaccessible = []
- , ciSubstnodes = (fst3.detectSites.ttree) te
- , ciDerivation = [ InitOp ] }
- where
- spineSide | left = LeftSide
- | gtype node == Foot = OnTheSpine
- | otherwise = RightSide
-
--- | explode a TagElem tree into a bottom-up routing map
-decompose :: TagElem -> RoutingMap
-decompose te = helper (ttree te) Map.empty
- where
- helper :: Tree GNode -> RoutingMap -> RoutingMap
- helper (Node _ []) smap = smap
- helper (Node p kidNodes) smap =
- let kids = [ gnname x | (Node x _) <- kidNodes ]
- addKid k = Map.insert k (left, right, p)
- where (left, right') = span (/= k) kids
- right = if null right' then [] else tail right'
- smap2 = foldr addKid smap kids
- in -- recurse to add routing info for child nodes
- foldr helper smap2 kidNodes
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Generate}
-% --------------------------------------------------------------------
-
-Each iteration of the surface realisation step involves picking an item
-off the agenda, applying all the relevant inference rules to it, and
-dispatching the results. Lather, rinse, repeat. At some point we just
-run out of things on the agenda and stop.
-
-Well, ok, there are ways that this thing could loop infinitely: for
-example, having null semantic lexical items would be a very bad thing.
-
-\begin{code}
-generateStep :: Bool -> CkyState ()
-generateStep isEarley =
- do -- this check may seem redundant with generate, but it's needed
- -- to protect against a user who calls generateStep on a finished
- -- state
- isFinished <- gets finished
- unless (isFinished) (generateStep2 isEarley)
-
-generateStep2 :: Bool -> CkyState ()
-generateStep2 isEarley =
- do st <- get
- -- incrGeniter 1
- agendaItem <- selectAgendaItem
- -- try the inference rules
- let chart = theChart st
- apply rule = rule agendaItem chart
- results = map apply (theRules st)
- -- see comments below about ordered substitution
- releasePayload = not (null results) || ciComplete agendaItem
- payload = if releasePayload && isEarley
- then ciPayload agendaItem else []
- -- put all newly generated items into the right pigeon-holes
- -- trace (concat $ zipWith showRes ckyRules results) $
- let dispatcher = theDispatcher st
- mapM dispatcher $ payload ++ (concat results)
- addToChart agendaItem
- incrCounter num_iterations 1
- return ()
-
-selectAgendaItem :: CkyState CkyItem
-selectAgendaItem = do
- a <- gets theAgenda
- updateAgenda (tail a)
- return (head a)
-
-finished :: CkyStatus -> Bool
-finished = null.theAgenda
-\end{code}
-
-% --------------------------------------------------------------------
-\section{CKY Rules}
-% --------------------------------------------------------------------
-
-Our surface realiser is defined by a set of inference rules. Since we are
-using an agenda-based algorithm, we define our inference rules to take two
-arguments: the agenda item and the entire chart. It is up to the inference
-rule to filter the chart for the items which can combine with the agenda item.
-If a rule is not applicable, it should simply return the empty list.
-
-\begin{code}
-type InferenceRule a = a -> [a] -> [a]
-type CKY_InferenceRule = InferenceRule CkyItem
-
-instance Show CKY_InferenceRule where
- show _ = "cky inference rule"
-\end{code}
-
-% FIXME: diagram and comment
-
-\begin{code}
-ckyRules :: [ (CKY_InferenceRule, String) ]
-ckyRules =
- [ (parentRule, "parent")
- , (substRule , "subst")
- , (nonAdjunctionRule, "nonAdj")
- , (activeAdjunctionRule, "actAdjRule")
- , (passiveAdjunctionRule, "psvAdjRule") ]
-
-parentRule, substRule, nonAdjunctionRule, activeAdjunctionRule, passiveAdjunctionRule :: CKY_InferenceRule
-
--- | CKY non adjunction rule - creates items in which
--- we do not apply any adjunction
--- this rule also doubles as top
-nonAdjunctionRule item _ =
- let node = ciNode item
- node2 = node { gaconstr = True }
- in if gtype node /= Other || ciAdjDone item then []
- else [ item { ciNode = node2
- , ciPayload = []
- , ciDerivation = [ NullAdjOp $ ciId item ] } ]
-\end{code}
-
-\subsection{Parent rule}
-
-WARNING: unproven code below! There is a piece of code floating around
-here which attempts to make the parent rule go a little bit faster and
-could eventually be used to replace \verb!ciSubsts! altogether. But
-somebody needs to sit down and prove that this is correct first.
-
-The basic problem is that you've got some child nodes from a tree and
-you want to know if you can use them to climb up to the parent node.
-Consider for instance the tree $(P:?X L:?X R:?X)$, that is a
-simple tree with two child nodes with a shared variable $?X$ on all
-nodes. Your two jobs are to
-\begin{enumerate}
-\item Make sure that the assignments of $?X$ do not conflict, for
-example, if in your instance of $L$, you have $?X \leftarrow a$ and in
-$R$, you have $?X \leftarrow b$, that would be bad and you should rule
-it out.
-\item Propagate any assignments of $?X$ up to the parent node.
-\end{enumerate}
-
-A naïve ``safe'' solution then seems to be that you have to unify
-together all instances of the child nodes: that is, in the example
-above, you need to unify $L$ with $R$'s idea of what $L$ is and vice
-versa, and then somehow propaagate everything up. Keep in mind that
-this is not the same thing as unifying $L$ with $R$ (why on earth would
-you want to do something like that?). I don't like this solution,
-because I get the impression that it makes us do a lot of unification
-for nothing.
-
-Ok, so how do we go about making this cheaper to perform? Here is what
-I ended up implementing: in the initialisation phase, you collect a set
-of open variables for each tree. This is the initial value of
-\verb!ciVariables!. Now, whenever you do anything with a chart item,
-for example, unifying some feature structure because of adjunction, you
-take care to also apply the variable replacements to the
-\verb!ciVariables! list. This way, it always contains the
-latest values for what were the open variables of the original tree.
-When you apply the parent rule, so goes the unproven idea, all you have
-to do is unify \verb!ciVariables! for all the child nodes. In order
-to propagate this to the parent node, you have to remember what the
-original values for \verb!ciVariables! was and use that to create a
-new replacements list. Let's work this out with a concrete example:
-
-\begin{enumerate}
-\item You've got the source tree in figure
-\ref{fig:variableCollection-01-04} with two open variables, $?X$ and
-$?Y$.
-\item Substitution into one of the nodes gives you the replacement
-$?Y \leftarrow b$
-\item Our first application of the parent rule: we climb up to the next
-node, rather trivially here since there is only one child
-\item This parent node $L$ receives adjunction, which sets the variable
-$?X \leftarrow a$
-\item (figure \ref{fig:variableCollection-05-06}) Independently of all
-this, we substitute something into the other side of the tree. This
-sets $?X \leftarrow c$. We don't know yet that this is a conflict with
-the previous step because we haven't tried applying the parent rule yet.
-\item But when we try to apply the parent rule here between the child
-$L$ and this version of the child $R$, we get a failure because their
-two instances of \verb!ciVariables! fail to unify ($a \neq c$).
-\item (figure \ref{fig:variableCollection-07-09}) We've seen what failure
-looks like, so let's try for success. Say we had substituted something
-different into $R$ and as a result, we get the assignement $?X
-\leftarrow b$.
-\item This time, unification between the \verb!ciVariables! from the
-children $L$ and $R$ actually succeeds, so we allow the parent rule
-to apply.
-\item Notice that the same \verb!ciVariables! unification mechanism
-also propagates up the assignemnt $?Y \leftarrow a$
-\end{enumerate}
-
-\begin{figure}
-\begin{center}
-\includegraphics[scale=0.5]{images/variableCollection-01-04}
-\caption{Variable collections example (part 1/3)}
-\label{fig:variableCollection-01-04}
-\end{center}
-\end{figure}
-\begin{figure}
-\begin{center}
-\includegraphics[scale=0.5]{images/variableCollection-05-06}
-\caption{Variable collections example (part 2/3)}
-\label{fig:variableCollection-05-06}
-\end{center}
-\end{figure}
-\begin{figure}
-\begin{center}
-\includegraphics[scale=0.5]{images/variableCollection-07-09}
-\caption{Variable collections example (part 3/3)}
-\label{fig:variableCollection-07-09}
-\end{center}
-\end{figure}
-
-\begin{code}
--- | CKY parent rule
-parentRule item chart | ciComplete item =
- do (leftS,rightS,p) <- maybeToList $ Map.lookup (gnname node) (ciRouting item)
- let mergePoints kids =
- case mapMaybe ciAdjPoint (item:kids) of
- [] -> Nothing
- [x] -> Just x
- _ -> error "multiple adjunction points in parentRule?!"
- combine par kids = do
- let unifyOnly (x, _) y = maybeToList $ unify x y
- -- IMPORTANT! This blocks the parent rule from applying
- -- if the child variables don't unify.
- (newVars, _) <- foldM unifyOnly (ciVariables item, Map.empty) $
- map ciVariables kids
- let newSubsts = Map.fromList $ zip (map fromGVar $ ciOrigVariables item) newVars
- newSide | all ciLeftSide kids = LeftSide
- | all ciRightSide kids = RightSide
- | any ciOnTheSpine kids = OnTheSpine
- | otherwise = geniBug $ "parentRule: Weird situtation involving tree sides"
- newItem = item
- { ciNode = replace newSubsts par
- , ciAdjPoint = mergePoints kids
- , ciVariables = newVars
- , ciTreeSide = newSide
- , ciDerivation = [ KidsToParentOp $ map ciId kids ]
- , ciPayload = []
- , ciSubstnodes = foldr intersect (ciSubstnodes item) $ map ciSubstnodes kids
- -- does union make sense?
- , ciAccesible = foldr union (ciAccesible item) $ map ciAccesible kids
- , ciInaccessible = foldr union (ciInaccessible item) $ map ciInaccessible kids
- }
- return $ foldr combineVectors newItem kids
- let leftMatches = map matches leftS
- rightMatches = map matches rightS
- allMatches = leftMatches ++ ([item] : rightMatches)
- -- trace (" relevant chart: (" ++ (show $ length relChart) ++ ") " ++ showItems relChart) $
- -- trace (" routing info: " ++ show (s,p,r)) $
- -- trace (" matches: (" ++ (show $ length allMatches) ++ ") " ++ (concat $ intersperse "-\n" $ map showItems allMatches)) $
- combinations allMatches >>= combine p
- where
- node = ciNode item
- sourceOf = tidnum.ciSourceTree
- --
- relevant c = (sourceOf c == sourceOf item) && ciComplete c
- -- make sure the semantics only overlap in the initial parts
- && (ciSemantics c) .&. (ciSemantics item) == (ciInitialSem item)
- relChart = filter relevant chart
- --
- matches :: String -> [CkyItem]
- matches sis = [ c | c <- relChart, (gnname.ciNode) c == sis ]
-parentRule _ _ = [] -- if this rule is not applicable to the item at hand
-\end{code}
-
-\subsection{Substitution}
-
-The substitution rule has two variants: either the agenda item is active,
-meaning it is a root node and is trying to subsitute into something; or it
-is passive, meaning that is a substitution node waiting to receive
-substitution on something.
-
-\begin{code}
--- | CKY subst rules
-substRule item chart = catMaybes $
- if ciSubs item
- then [ attemptSubst item r | r <- chart, compatibleForSubstitution r item ]
- else [ attemptSubst s item | s <- chart, compatibleForSubstitution item s ]
-
--- | unification for substitution
-attemptSubst :: CkyItem -> CkyItem -> Maybe CkyItem
-attemptSubst sItem rItem | ciSubs sItem =
- do let rNode = ciNode rItem
- sNode = ciNode sItem
- (up, down, subst) <- unifyGNodes sNode (ciNode rItem)
- let newNode = rNode { gnname = gnname sNode
- , gup = up, gdown = down }
- newItem = combineWithSubst newNode subst rItem sItem
- return $ newItem
-attemptSubst _ _ = error "attemptSubst called on non-subst node"
-
--- | return True if the first item may be substituted into the second
--- as long as unification and all the nasty details work out
-compatibleForSubstitution :: CkyItem -- ^ active item
- -> CkyItem -- ^ passive item
- -> Bool
-compatibleForSubstitution a p =
- ciRoot a && ciComplete a && ciInit a
- && ciSubs p
- && compatible a p
-\end{code}
-
-\subsection{Adjunction}
-
-As with substitution, the adjunction rule has two variants: either the agenda
-item is active, meaning it is the root node of an auxliary tree is trying
-to adjoin into something; or it is passive, meaning it is a node which is
-waiting to receive adjunction.
-
-Note that unlike the substitution rule, we have to split these two variants
-into two actual rules. This is because we also want auxiliary tree nodes
-to be able to receive adjunction and not just perform it!
-
-\begin{code}
--- | CKY adjunction rule: note - we need this split into two rules because
--- both variants could fire at the same time, for example, the passive variant
--- to adjoin into the root of an auxiliary tree, and the active variant because
--- it is an aux tree itself and it wants to adjoin somewhere
-activeAdjunctionRule item chart | ciRoot item && ciAux item =
- mapMaybe (\p -> attemptAdjunction p item)
- [ p | p <- chart, compatibleForAdjunction item p ]
-activeAdjunctionRule _ _ = [] -- if not applicable
-
--- | CKY adjunction rule: we're just a regular node, minding our own business
--- looking for an auxiliary tree to adjoin into us
-passiveAdjunctionRule item chart =
- mapMaybe (attemptAdjunction item)
- [ a | a <- chart, compatibleForAdjunction a item ]
-
-attemptAdjunction :: CkyItem -> CkyItem -> Maybe CkyItem
-attemptAdjunction pItem aItem | ciRoot aItem && ciAux aItem =
- -- trace ("try adjoining " ++ (showItem aItem) ++ " into " ++ (showItem pItem)) $
- do let aRoot = ciNode aItem
- aFoot = (foot.ttree.ciSourceTree) aItem-- could be pre-computed?
- pNode = ciNode pItem
- (newTop, _ , subst) <- unifyPair (gup pNode, gdown pNode)
- (gup aRoot, gdown aFoot)
- let newNode = pNode { gaconstr = False, gup = newTop, gdown = [] }
- newItem = combineWith AdjOp newNode subst aItem pItem
- return newItem
-attemptAdjunction _ _ = error "attemptAdjunction called on non-aux or non-root node"
-
--- | return True if the first item may be adjoined into the second
--- as long as unification and all the nasty details work out
-compatibleForAdjunction :: CkyItem -- ^ active item
- -> CkyItem -- ^ passive item
- -> Bool
-compatibleForAdjunction a p =
- ciAux a && ciRoot a && ciAdjDone a
- && (gtype.ciNode) p == Other && (not.ciAdjDone) p
- && compatible a p
-\end{code}
-
-\subsection{Helpers for inference rules}
-
-\begin{code}
-isLexeme :: GNode -> Bool
-isLexeme = not.null.glexeme
-
--- | return True if the chart items may be combined with each other; for now, this
--- consists of a semantic check
-compatible :: CkyItem -> CkyItem -> Bool
-compatible a b = ( (ciSemantics a) .&. (ciSemantics b) ) == 0
- && ( (ciPolpaths a) .|. (ciPolpaths b) ) /= 0
-\end{code}
-
-To factorise the construction of new items, we provide two functions for combining
-two chart items. \fnreflite{combineVectors} merely combines the easy stuff (the
-semantic bit maps and the polarity paths). \fnreflite{combineWith} does the
-heavier stuff like the list of open variables and the derivation for the new item.
-The reason we expose \fnreflite{combineVectors} as a separate function is because
-the \fnreflite{kidsToParentsRule} needs it.
-
-\begin{code}
-combineVectors :: CkyItem -> CkyItem -> CkyItem
-combineVectors a b =
- b { ciSemantics = (ciSemantics a) .|. (ciSemantics b)
- , ciPolpaths = (ciPolpaths a) .&. (ciPolpaths b)
- , ciSemBitMap = ciSemBitMap a }
-
-combineWithSubst :: GNode -> Subst -> CkyItem -> CkyItem -> CkyItem
-combineWithSubst node subst a p =
- newPassive { ciAccesible = (ciAccesible a) `union` (ciAccesible p)
- , ciInaccessible = (ciInaccessible a) `union` (ciInaccessible p)
- , ciSubstnodes = newCiSubstnodes }
- where newCiSubstnodes = [ t | t@(TagSite x _ _ _) <- ciSubstnodes p, x /= gnname node ]
- newPassive = combineWith SubstOp node subst a p
-
-combineWith :: ChartOperationConstructor -- ^ how did we get the new item?
- -> GNode -> Subst -> CkyItem -> CkyItem -> CkyItem
-combineWith operation node subst active passive =
- combineVectors active $
- passive { ciNode = node
- , ciPayload = []
- , ciVariables = replace subst (ciVariables passive)
- , ciDerivation = [ operation (ciId active) (ciId passive) ] }
-\end{code}
-
-\paragraph{unifyTagNodes} performs feature structure unification
-on TAG nodes. First we try unification on the top node. We
-propagate any results from that unification and proceed to trying
-unification on the bottom nodes. If succesful, we return the
-results of both unifications and a list of substitutions to
-propagate. Otherwise we return Nothing.
-
-\begin{code}
-unifyGNodes :: GNode -> GNode -> Maybe (Flist, Flist, Subst)
-unifyGNodes g1 g2 =
- unifyPair (gupdown g1) (gupdown g2)
- where gupdown n = (gup n, gdown n)
-
-unifyPair :: (Flist, Flist) -> (Flist, Flist) -> Maybe (Flist, Flist, Subst)
-unifyPair (t1, b1) (t2, b2) =
- do (newTop, subst1) <- unifyFeat t1 t2
- (newBot, subst2) <- unifyFeat (replace subst1 b1) (replace subst1 b2)
- return (newTop, newBot, mergeSubst subst1 subst2)
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Dispatching new chart items}
-% --------------------------------------------------------------------
-
-We use the generic dispatch mechanism described in section \ref{sec:dispatch}.
-
-\begin{code}
-type CKY_DispatchFilter = DispatchFilter CkyState CkyItem
-
-ckyDispatch :: Bool -- ^ index accessibility filtering
- -> CKY_DispatchFilter
-ckyDispatch iaf =
- dispatchTbFailure >--> dispatchRedundant >--> dispatchResults >-->
- (if iaf then dispatchIafFailure >--> dispatchToAgenda
- else dispatchToAgenda)
-
-dispatchToAgenda, dispatchRedundant, dispatchResults, dispatchTbFailure :: CKY_DispatchFilter
-
--- | Trivial dispatch filter: always put the item on the agenda and return
--- Nothing
-dispatchToAgenda item =
- do addToAgenda item
- return Nothing
-
--- | If the item can merge with another, merge it with the equivalent
--- item and return Nothing.
--- If the item is indeed unique, return (Just $ setId item)
-dispatchRedundant item =
- do st <- get
- let chart = theChart st
- mergeEquivItems o =
- let equiv = canMerge o item
- in (equiv, if equiv then mergeItems o item else o)
- (isEq, newChart) = unzip $ map mergeEquivItems chart
- --
- if or isEq
- then -- trace (ckyShow "-> merge" item []) $
- do put ( st {theChart = newChart} )
- return Nothing
- else do s <- get
- let counter = gencounter s
- put $ s { gencounter = counter + 1 }
- return $ Just $ item { ciId = counter }
-
--- | If it is a result, put the item in the results list.
--- Otherwise, return (Just unmodified)
-dispatchResults item =
- do st <- get
- let synComplete = ciInit item && ciRoot item && ciAdjDone item
- semComplete = tsemVector st == ciSemantics item
- --
- if (synComplete && semComplete )
- then -- trace ("isResult " ++ showItem item) $
- addToResults item >> return Nothing
- else return $ Just item
-
--- | This filter requires another inversion in thinking. It suceeds
--- if tb unification fails by dispatching to the trash and returning
--- Nothing. If tb unification suceeds, it returns (Just newItem),
--- where newItem has its top and bottom nodes unified.
-dispatchTbFailure itemRaw =
- case tbUnify itemRaw of
- Nothing ->
- do addToTrash itemRaw ts_tbUnificationFailure
- return Nothing
- Just item -> return $ Just item
-
-tbUnify :: CkyItem -> Maybe CkyItem
--- things for which tb unification is not relevant
-tbUnify item | ciFoot item = return item
-tbUnify item | (not.ciAdjDone) item = return item
--- ok, here, we should do tb unification
-tbUnify item =
- do let node = ciNode item
- (newTop, sub1) <- unifyFeat (gup node) (gdown node)
- -- it's not enough if t/b unification succeeds by itself
- -- we also have to check that these unifications propagate alright
- let origVars = ciOrigVariables item
- treeVars = ciVariables item
- nodeVars = replace sub1 origVars
- (newVars, _) <- unify treeVars nodeVars
- return $ item
- { ciNode = node { gup = newTop, gdown = [] }
- , ciVariables = newVars }
-\end{code}
-
-% --------------------------------------------------------------------
-\subsection{Equivalence classes}
-\label{sec:cky:merging}
-% --------------------------------------------------------------------
-
-\fnlabel{canMerge} returns true if two chart items are allowed to merge.
-We do not allow items to merge when they are not "complete", because that
-would complicate things like the right sister rule.
-
-\begin{code}
-canMerge :: CkyItem -> CkyItem -> Bool
-canMerge c1 c2 = ciComplete c1 && ciComplete c2 && stuff c1 == stuff c2
- where stuff x = ( ciNode x, ciSourceTree x, ciSemantics x, ciPolpaths x )
-\end{code}
-
-\fnlabel{mergeItems} combines two chart items into one, with the
-assumption being that you have already determined that they can be
-merged. Information from the second ``slave'' item is merged
-into information from the first ``master'' item.
-
-\begin{code}
-mergeItems :: CkyItem -> CkyItem -> CkyItem
-mergeItems master slave =
- master { ciDerivation = ciDerivation master ++ (ciDerivation slave) }
-\end{code}
-
-Note that we do not perform index accesibility filtering on auxiliary
-trees. What we're after here is delayed substitution, meaning that we
-don't do any substitution until the adjunctions are done. If an
-auxiliary tree has substitution nodes, this puts us in the paradoxical
-situation where we're trying to delay a substitution which we need in
-order to perform an adjunction.
-
-Consider for example, the semantics \texttt{john(j) ask(e1 j e2) go(e2
-j w) where(w)} which we intend to realise as \natlang{John asks where to
-go}. Depending on your grammar, one conceivable way to realise this is
-as an initial tree for ``to go'', and an auxiliary tree for ``asks'' (a
-sentential modifier). You plug ``where'' into ``to go'' to get ``where
-to go'' and ``John'' into ``asks''. This gives you an auxiliary tree
-``John asks'' which adjoins into another tree ``where to go''. Now the
-problem is that if you enable iaf on auxiliary trees, you're not going
-to be able to construct the ``John asks'' tree because it thinks that
-by doing so, you have sealed off access to the \texttt{j} index in
-\texttt{go(e2 j w)}. Conclusion: iaf on auxiliary trees is a no-no.
-
-\begin{code}
-instance IafAble CkyItem where
- iafAcc = ciAccesible
- iafInacc = ciInaccessible
- iafSetAcc a i = i { ciAccesible = a }
- iafSetInacc a i = i { ciInaccessible = a }
- iafNewAcc i =
- concatMap fromUniConst $ replaceList r $
- concat [ getIdx u | (TagSite _ u _ _) <- ciSubstnodes i ]
- where r = zip (map fromGVar $ ciOrigVariables i)
- (ciVariables i)
-
-dispatchIafFailure :: CkyItem -> CkyState (Maybe CkyItem)
-dispatchIafFailure item | ciAux item = return $ Just item
-dispatchIafFailure itemRaw =
- do s <- get
- let bmap = ciSemBitMap item
- item = recalculateAccesibility itemRaw
- badSem = iafBadSem (theIafMap s) bmap (tsemVector s) ciSemantics item
- inAcc = iafInacc item
- if badSem == 0
- then -- can't dispatch, but that's good!
- -- (note that we return the item with its iaf criteria updated)
- return $ Just item
- else do addToTrash item (ts_iafFailure inAcc $ bitVectorToSem bmap badSem)
- return Nothing
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Unpacking the chart}
-% --------------------------------------------------------------------
-
-\begin{code}
-unpackItem :: CkyStatus -> CkyItem -> [B.Output]
-unpackItem st it =
- zip (mAutomatonPaths $ uncurry mJoinAutomata $ unpackItemToAuts st it)
- (repeat [])
-
-type SentenceAutPairMaybe = (Maybe SentenceAut, Maybe SentenceAut)
-
-unpackItemToAuts :: CkyStatus -> CkyItem
- -- left and right automata
- -> SentenceAutPairMaybe
-unpackItemToAuts st item =
- case map aut derivations of
- [] -> (Nothing, Nothing)
- (a:as) -> foldr pairUnion a as
- where
- pairUnion (l1,r1) (l2,r2) = (mUnionAutomata l1 l2, mUnionAutomata r1 r2)
- derivations = ciDerivation item
- retrieve = findIdOrBug st
- -- these are fleshed out in the paragraphs below
- aut (KidsToParentOp k) = unpackKidsToParentOp st $ map retrieve k
- aut (NullAdjOp p) = unpackNullAdjOp st $ retrieve p
- aut (SubstOp a p) = unpackSubstOp st (retrieve a) (retrieve p)
- aut (AdjOp a p) = unpackAdjOp st (retrieve a) (retrieve p)
- aut InitOp = unpackInitOp st item
-\end{code}
-
-\paragraph{Leaf nodes}
-
-\begin{code}
-unpackInitOp :: CkyStatus -> CkyItem -> SentenceAutPairMaybe
-unpackInitOp _ item =
- let node = ciNode item
- -- we have to add a transition for each choice in the lexical
- -- atomic disjunction
- lexAut = foldr (\l a -> addTrans a 0 (via l) 1) iAut (glexeme node)
- via l = Just (l, gup node)
- iAut = emptySentenceAut { startSt = 0
- , finalStList = [1]
- , states = [[0,1]]}
- in if isLexeme node
- then case ciTreeSide item of
- LeftSide -> (Just lexAut, Nothing)
- RightSide -> (Nothing, Just lexAut)
- OnTheSpine -> (Nothing, Nothing)
- else (Nothing, Nothing)
-
-emptySentenceAut :: SentenceAut
-emptySentenceAut =
- NFA { startSt = (-1)
- , isFinalSt = Nothing
- , finalStList = []
- , transitions = Map.empty
- , states = [[]] }
-\end{code}
-
-\paragraph{Null adjunction} is a trivial case; we just propagate the automaton upwards.
-
-\begin{code}
-unpackNullAdjOp :: CkyStatus -> CkyItem -> SentenceAutPairMaybe
-unpackNullAdjOp st psv = unpackItemToAuts st psv
-\end{code}
-
-\paragraph{Substitution} would be as simple as null adjunction, were it
-not for auxiliary trees. When dealing with an auxiliary tree, we need
-to be careful which side of the spine we substitute into. For those of
-you not so familiar with TAG, the spine is the path from root node to
-the foot node of an auxiliary tree.
-
-If we're on the left side of the spine, we propagate into the left
-automaton. Likewise, we propagate into the right autamaton if we're on
-the right side of the spine. If we're trying to substitute \emph{into}
-the spine, we're in trouble.
-
-\begin{code}
-unpackSubstOp :: CkyStatus -> CkyItem -> CkyItem -> SentenceAutPairMaybe
-unpackSubstOp st act psv =
- case ciTreeSide psv of
- LeftSide -> (actAut, Nothing)
- RightSide -> (Nothing, actAut)
- OnTheSpine -> geniBug $ "Tried to substitute on the spine!"
- where actAut = fst $ unpackItemToAuts st act
-\end{code}
-
-\paragraph{Adjunction} involves joining the left sides of both items
-together as well as the right side. This is probably best explained
-with a picture:
-
-FIXME: insert figure
-
-\begin{code}
-unpackAdjOp :: CkyStatus -> CkyItem -> CkyItem -> SentenceAutPairMaybe
-unpackAdjOp st act psv =
- let (actL, actR) = unpackItemToAuts st act
- (psvL, psvR) = unpackItemToAuts st psv
- newAutL = mJoinAutomata actL psvL
- newAutR = mJoinAutomata psvR actR
- newAut = mJoinAutomata newAutL newAutR
- in case ciTreeSide psv of
- LeftSide -> (newAut, Nothing)
- RightSide -> (Nothing, newAut)
- OnTheSpine -> (newAutL, newAutR)
-\end{code}
-
-\paragraph{The kids to parents rule} is complicated because of auxiliary
-trees. As usual, there are three cases:
-
-\begin{itemize}
-\item On the left of the spine: we concatenate all the left
- automata of the kids
-\item On the right of the spine: we concatenate all the right
- automata of the kids
-\item On the spine itself: we concatenate all the left automata
- of the stuff on the left of the spine and propagate that
- as our left side. Similarly, we concatenate all the right
- automata of the stuff on the right of the spine and send
- that up the right side.
-\end{itemize}
-
-\begin{code}
-unpackKidsToParentOp :: CkyStatus -> [CkyItem] -> SentenceAutPairMaybe
-unpackKidsToParentOp st kids =
- let (bef, aft) = span (not.ciOnTheSpine) kids
- (befL, befR) = unzip $ map (unpackItemToAuts st) bef
- concatAut_ theLast auts = foldr mJoinAutomata theLast auts
- concatAut = concatAut_ Nothing
- in case aft of
- -- two cases in one! (we expect one of these to be Nothing)
- -- we're either on the left or the right of the spine
- [] -> ( concatAut befL, concatAut befR )
- -- we are on the spine: we attach the left automaton of the
- -- spinal child to the other left automata and likewise,
- -- its right automaton to the rest of the right automata
- (spi:aft2) ->
- let (spiL, spiR) = unpackItemToAuts st spi
- (_ , aftR) = unzip $ map (unpackItemToAuts st) aft2
- in ( concatAut_ spiL befL, concatAut (spiR:aftR) )
-\end{code}
-
-\subsection{Core automaton stuff}
-
-Note: you might be tempted to move this code to the generic Automaton library.
-In order to do this, you will have to introduce a geniric notion of
-state-renaming to the library. I didn't want to bother with any of that.
-
-\begin{code}
-mUnionAutomata :: Maybe SentenceAut -> Maybe SentenceAut -> Maybe SentenceAut
-mUnionAutomata Nothing mAut2 = mAut2
-mUnionAutomata mAut1 Nothing = mAut1
-mUnionAutomata (Just aut1) (Just aut2) = Just $ unionAutomata aut1 aut2
-
--- | Merge two sentence automata together. This essentially calculates the
--- union of the two automata and "pinches" their final states together.
--- FIXME: could be much more sophisticated and produce smaller automata!
-unionAutomata :: SentenceAut -> SentenceAut -> SentenceAut
-unionAutomata aut1 rawAut2 =
- let -- rename all the states in aut2 so that they don't overlap
- aut1Max = foldr max (-1) $ concat $ states aut1
- aut2 = incrStates (1 + aut1Max) rawAut2
- -- make the start state of the new automaton also transition
- -- everything that the from the start state of aut2 transitions to
- t1 = transitions aut1
- t2 = transitions aut2
- aut2Start = startSt aut2
- addAut2Trans = Map.unionWith (++) $ Map.findWithDefault Map.empty aut2Start t2
- newT1 = Map.adjust addAut2Trans (startSt aut1) t1
- newT2 = Map.delete aut2Start t2
- in aut1 { states = [ delete aut2Start $ concat $ states aut1 ++ states aut2 ]
- , transitions = Map.union newT1 newT2
- , isFinalSt = do -- in the Maybe Monad
- f1 <- isFinalSt aut1
- f2 <- isFinalSt aut2
- return $ \s -> f1 s || f2 s
- , finalStList = finalStList aut1 ++ finalStList aut2 }
-\end{code}
-
-It's important not to confuse \fnreflite{joinAutomata} with
-\fnreflite{unionAutomata}. Joining automata is basically concatenation,
-putting the second automaton after the first one.
-Interestingly, their implementations have a lot in common.
-FIXME: it might be worth refactoring the two.
-
-\begin{code}
-mJoinAutomata :: Maybe SentenceAut -> Maybe SentenceAut -> Maybe SentenceAut
-mJoinAutomata Nothing mAut2 = mAut2
-mJoinAutomata mAut1 Nothing = mAut1
-mJoinAutomata (Just aut1) (Just aut2) = Just $ joinAutomata aut1 aut2
-
--- | Concatenate two sentence automata. This merges the final state of the
--- first automaton into the initial state of the second automaton.
-joinAutomata :: SentenceAut -> SentenceAut -> SentenceAut
-joinAutomata aut1 rawAut2 =
- let -- rename all the states in aut2 so that they don't overlap
- aut1Max = (maximum.concat.states) aut1
- aut2 = incrStates (1 + aut1Max) rawAut2
- -- replace all transitions to aut1's final st by
- -- transitions to aut2's start state
- aut1Final = finalSt aut1
- aut2Start = startSt aut2
- t1 = transitions aut1
- t2 = transitions aut2
- updateKey k m = case Map.lookup k m of
- Nothing -> m
- Just v -> Map.insert aut2Start v (Map.delete k m)
- replaceFinal (f,t) = (f, foldr updateKey t aut1Final)
- newT1 = Map.fromList $ map replaceFinal $ Map.toList t1
- newStates1 = map (\\ aut1Final) $ states aut1
- --
- in aut1 { states = [ concat $ newStates1 ++ states aut2 ]
- , transitions = Map.union newT1 t2
- , isFinalSt = isFinalSt aut2
- , finalStList = finalStList aut2 }
-
-incrStates :: Int -> SentenceAut -> SentenceAut
-incrStates prefix aut =
- let -- increment a state
- addP_s = (prefix +)
- -- increment all the states involved in a transition
- addP_t (st,l) = (addP_s st, Map.mapKeys addP_s l)
- in aut { startSt = addP_s (startSt aut)
- , states = map (map addP_s) $ states aut
- , transitions = Map.fromList $ map addP_t $
- Map.toList $ transitions aut
- , finalStList = map addP_s $ finalStList aut }
-
-mAutomatonPaths :: (Ord st, Ord ab) => Maybe (NFA st ab) -> [[ab]]
-mAutomatonPaths Nothing = []
-mAutomatonPaths (Just x) = automatonPaths x
-\end{code}
-
-\subsection{Item history}
-
-We don't ever really need to calculate the derivation tree for an item.
-Don't get me wrong, we certainly calculate something which looks a lot
-like a derivation tree and contains more or less the same stuff, but not
-a derivation tree per se.
-
-On the otherhand, debugging the generator is \emph{much} easier if you
-can get a graphical representation for an item. This is like a
-derivation tree with way too much detail. We calculate a tree-like
-representation of the history of inference rule applications for this
-item.
-
-Note that because of equivalence classes, an item can be seen as having
-more than one derivation. We abstract around this fact simply by
-implementing the function with a \verb!List! monad.
-
-\begin{code}
--- | Returns all the derivations trees for this item: note that this is
--- not a TAG derivation tree but a history of inference rule applications
--- in tree form
-extractDerivations :: CkyStatus -> CkyItem -> [ Tree (ChartId, String) ]
-extractDerivations st item =
- do chartOp <- ciDerivation item
- case chartOp of
- KidsToParentOp kids ->
- do kidTrees <- mapM treeFor kids
- createNode "kids" kidTrees
- SubstOp act psv ->
- do actTree <- treeFor act
- let psvTree = Node (psv, "subst") [ actTree ]
- createNode "subst-finish" [psvTree]
- AdjOp act psv ->
- do actTree <- treeFor act
- let psvTree = Node (psv, "adj") [ actTree ]
- createNode "adj-finish" [psvTree]
- NullAdjOp psv ->
- do psvTree <- treeFor psv
- createNode "no-adj" [psvTree]
- InitOp -> createNode "init" []
- where
- createNode op kids =
- return $ Node (ciId item, op) kids
- treeFor i =
- case findId st i of
- Nothing -> geniBug $ "derivation for item " ++ (show $ ciId item)
- ++ "points to non-existent item " ++ (show i)
- Just x -> extractDerivations st x
-\end{code}
-
-\subsection{Helpers for unpacking}
-
-\begin{code}
-findId :: CkyStatus -> ChartId -> Maybe CkyItem
-findId st i = find (\x -> ciId x == i) $ theChart st ++ (theAgenda st) ++ (theResults st) ++ (theTrash st)
-
--- | The same as 'findId' but calls 'geniBug' if not found
-findIdOrBug :: CkyStatus -> ChartId -> CkyItem
-findIdOrBug st i =
- case findId st i of
- Nothing -> geniBug $ "Cannot find item in chart with id " ++ (show i)
- Just x -> x
-\end{code}
-
-\section{Optimisations}
-
-\paragraph{Earley-style derivation}
-
-The idea is that we to perform substitutions in a fixed order so that we avoid
-generating a lot of useless chart items that aren't going to be used in a final
-result anyway.
-
-We implement this in two places. In the initialisation phase, (page
-\pageref{fn:cky:initTree}), we avoid placing all the leaf items onto the
-agenda. Instead, we make each leaf node point to the next leaf, as
-with a singly linked list, and put the head of that list on the agenda.
-The second part of this is implemented below as an inference rule which
-takes only complete items (i.e. items for which there is no need to
-perform substitution) and releases their payload.
-
-Note that in order for this to work, we also had to introduce a
-restriction into chart item merging (page \pageref{sec:cky:merging})
-that no two items may merge if they are not complete in the same sense
-as this inference rule. Otherwise, we'd have to think find a way to
-make sure that payloads get released correctly (which might not be as
-hard as I first thought).
-
-
diff --git a/src/NLP/GenI/CkyEarley/CkyGui.lhs b/src/NLP/GenI/CkyEarley/CkyGui.lhs
deleted file mode 100644
--- a/src/NLP/GenI/CkyEarley/CkyGui.lhs
+++ /dev/null
@@ -1,456 +0,0 @@
-% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
-%
-% This program is free software; you can redistribute it and/or
-% modify it under the terms of the GNU General Public License
-% as published by the Free Software Foundation; either version 2
-% of the License, or (at your option) any later version.
-%
-% This program is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with this program; if not, write to the Free Software
-% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-\chapter{CKY Gui}
-
-\begin{code}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module NLP.GenI.CkyEarley.CkyGui where
-\end{code}
-
-\ignore{
-\begin{code}
-import Graphics.UI.WX hiding (when)
-
-import qualified Control.Monad as Monad
-import Control.Monad (liftM)
-
-import Data.IORef
-import Data.List (intersperse, findIndex, sort)
-import qualified Data.Map as Map
-import Data.Maybe (listToMaybe, catMaybes)
-import Data.Tree
-
-import NLP.GenI.Statistics (Statistics)
-
-import NLP.GenI.Automaton
- ( NFA(states, transitions, startSt, finalStList)
- , addTrans )
-import qualified NLP.GenI.Builder as B
-import qualified NLP.GenI.BuilderGui as BG
-import NLP.GenI.Btypes ( GNode, gnname )
-
-import NLP.GenI.CkyEarley.CkyBuilder
- ( ckyBuilder, earleyBuilder, CkyStatus, CkyItem(..), ChartId
- , ciRoot, ciAdjDone
- , bitVectorToSem, findId
- , extractDerivations
- , theResults, theAgenda, theChart, theTrash
- , emptySentenceAut, mJoinAutomata, mAutomatonPaths
- , unpackItemToAuts,
- )
-import NLP.GenI.Configuration ( Params(..) )
-
-import NLP.GenI.Geni
- ( ProgStateRef, runGeni, GeniResult )
-import NLP.GenI.General ( boundsCheck, geniBug )
-import NLP.GenI.GuiHelper
- ( messageGui, toSentence
- , debuggerPanel, DebuggerItemBar
- , addGvHandler, modifyGvParams
- , GraphvizGuiSt(gvitems, gvsel, gvparams), GvIO, setGvSel
- , graphvizGui, newGvRef, setGvDrawables,
- )
-
-import NLP.GenI.Tags ( idname, tsemantics, ttree, TagElem )
-
-import NLP.GenI.Graphviz
- ( GraphvizShow(..), gvNode, gvEdge, gvSubgraph, gvUnlines, gvShowTree
- , gvNewline
- , GraphvizShowNode(..) )
-\end{code}
-}
-
-% --------------------------------------------------------------------
-\section{Interface}
-% --------------------------------------------------------------------
-
-\begin{code}
-ckyGui, earleyGui :: BG.BuilderGui
-ckyGui = ckyOrEarleyGui False
-earleyGui = ckyOrEarleyGui True
-
-ckyOrEarleyGui :: Bool -> BG.BuilderGui
-ckyOrEarleyGui isEarley = BG.BuilderGui {
- BG.resultsPnl = resultsPnl builder
- , BG.debuggerPnl = ckyDebuggerTab builder }
- where builder = if isEarley then earleyBuilder else ckyBuilder
-
-resultsPnl :: B.Builder CkyStatus CkyItem Params -> ProgStateRef -> Window a -> IO ([GeniResult], Statistics, Layout)
-resultsPnl builder pstRef f =
- do (sentences, stats, st) <- runGeni pstRef builder
- (lay, _, _) <- realisationsGui pstRef f (theResults st)
- return (sentences, stats, lay)
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Results}
-\label{sec:cky_results_gui}
-% --------------------------------------------------------------------
-
-\begin{code}
--- | Browser for the results (if there are any)
-realisationsGui :: ProgStateRef -> (Window a) -> [CkyItem]
- -> GvIO CkyDebugParams (Maybe CkyItem)
-realisationsGui _ f [] =
- do m <- messageGui f "No results found"
- gvRef <- newGvRef initCkyDebugParams [] ""
- return (m, gvRef, return ())
-realisationsGui _ f resultsRaw =
- do let tip = "result"
- results = map Just resultsRaw
- labels = map (toSentence.ciSourceTree) resultsRaw
- gvRef <- newGvRef initCkyDebugParams labels tip
- setGvDrawables gvRef results
- graphvizGui f "cky-results" gvRef
-\end{code}
-
-\begin{code}
-data CkyDebugParams =
- CkyDebugParams { debugShowFeats :: Bool
- , debugShowFullDerv :: Bool
- , debugShowSourceTree :: Bool
- , debugWhichDerivation :: Int
- , debugNodeChoice :: [ChartId] }
-
-initCkyDebugParams :: CkyDebugParams
-initCkyDebugParams =
- CkyDebugParams { debugShowFeats = False
- , debugShowFullDerv = False
- , debugShowSourceTree = False
- , debugWhichDerivation = 0
- , debugNodeChoice = [] }
-
--- would be nice if Haskell sugared this kind of stuff for us
-setDebugShowFeats, setDebugShowFullDerv, setDebugShowSourceTree :: Bool -> CkyDebugParams -> CkyDebugParams
-setDebugShowFeats b x = x { debugShowFeats = b }
-setDebugShowFullDerv b x = x { debugShowFullDerv = b }
-setDebugShowSourceTree b x = x { debugShowSourceTree = b }
-
-setDebugWhichDerivation :: Int -> CkyDebugParams -> CkyDebugParams
-setDebugWhichDerivation w x = x { debugWhichDerivation = w }
-
-clearDebugNodeChoice :: CkyDebugParams -> CkyDebugParams
-clearDebugNodeChoice x = x { debugNodeChoice = [] }
-
-pushDebugNodeChoice :: ChartId -> CkyDebugParams -> CkyDebugParams
-pushDebugNodeChoice w x = x { debugNodeChoice = w:(debugNodeChoice x) }
-
-popDebugNodeChoice :: CkyDebugParams -> Maybe (ChartId, CkyDebugParams)
-popDebugNodeChoice x =
- case debugNodeChoice x of
- [] -> Nothing
- (h:t) -> Just (h, x { debugNodeChoice = t })
-
-ckyDebuggerTab :: B.Builder CkyStatus CkyItem Params
- -> (Window a) -> Params -> B.Input -> String -> IO Layout
-ckyDebuggerTab builder = debuggerPanel builder initCkyDebugParams stateToGv ckyItemBar
- where
- stateToGv :: CkyStatus -> [(Maybe (CkyStatus,CkyItem), String)]
- stateToGv st =
- let agenda = section "AGENDA" $ theAgenda st
- trash = section "TRASH" $ theTrash st
- chart = section "CHART" $ theChart st
- results = section "RESULTS" $ theResults st
- --
- section n i = hd : (map tlFn i)
- where hd = (Nothing, "___" ++ n ++ "___")
- tlFn x = (Just (st,x), labelFn x)
- showPaths = const ""
- {- if (polarised $ genconfig st)
- then (\t -> " (" ++ showPolPaths t ++ ")")
- else const "" -}
- gorn i = case gornAddressStr (ttree $ ciSourceTree i) (ciNode i) of
- Nothing -> geniBug "A chart item claims to have a node which is not in its tree"
- Just x -> x
- isComplete i = ciRoot i && ciAdjDone i
- -- try displaying as an automaton, or if all else fails, the tree sentence
- fancyToSentence ci =
- let mergedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts st ci
- boringSentence = toSentence $ ciSourceTree ci
- in case mAutomatonPaths mergedAut of
- [] -> boringSentence
- (h:_) -> unwords $ map fst $ h
- labelFn i = unwords [ completeStr ++ idStr ++ gornStr
- , fancyToSentence i
- , "/" ++ (idname $ ciSourceTree i)
- , showPaths i
- ]
- where idStr = show $ ciId i
- completeStr = if isComplete i then ">" else ""
- gornStr = if isComplete i then "" else " g" ++ (gorn i)
- in agenda ++ chart ++ results ++ trash
-
-ckyItemBar :: DebuggerItemBar CkyDebugParams (CkyStatus, CkyItem)
-ckyItemBar f gvRef updaterFn =
- do ib <- panel f []
- -- select derivation
- derTxt <- staticText ib []
- derChoice <- choice ib [ tooltip := "Select a derivation" ]
- jumpBtn <- button ib [ text := "Go to node" ]
- unjumpBtn <- button ib [ text := "Pop back" ]
- jumpChoice <- choice ib [ tooltip := "Jump to item." ]
- let onDerChoice =
- do sel <- get derChoice selection
- modifyGvParams gvRef (setDebugWhichDerivation sel)
- gvSt <- readIORef gvRef
- -- update the list of jump choices
- case Map.lookup (gvsel gvSt) (gvitems gvSt) of
- Just (Just (s,c)) -> do
- let t = selectedDerivation (gvparams gvSt) s c
- nodes = map show $ sort $ derivationNodes t
- set jumpChoice [ items := nodes, selection := 0 ]
- updaterFn
- _ -> return ()
- set derChoice [ on select := onDerChoice ]
- -- show features
- detailsChk <- checkBox ib [ text := "features"
- , enabled := False, checked := False ]
- fullDervChk <- checkBox ib [ text := "full derivation"
- , checked := False ]
- srcTreeChk <- checkBox ib [ text := "src tree"
- , checked := False ]
- let setChkBoxUpdater box setter =
- set box [ on command := do isChecked <- get box checked
- modifyGvParams gvRef $ setter isChecked
- updaterFn ]
- setChkBoxUpdater detailsChk setDebugShowFeats
- setChkBoxUpdater fullDervChk setDebugShowFullDerv
- setChkBoxUpdater srcTreeChk setDebugShowSourceTree
- -- make detailsChk conditioned on srcTreeChk
- set srcTreeChk [ on command :~ \x -> x >> do
- isChecked <- get srcTreeChk checked
- set detailsChk [ enabled := isChecked ]
- ]
- -- add a handler for when an item is selected:
- -- update the list of derivations to choose from
- let updateDerTxt t = set derTxt [ text := "Deriviations (" ++ t ++ ")" ]
- handler gvSt =
- do case Map.lookup (gvsel gvSt) (gvitems gvSt) of
- Just (Just (s,c)) ->
- do let derivations = extractDerivations s c
- dervLabels = zipWith (\n _ -> show n) ([1..]::[Int]) derivations
- set derChoice [ enabled := True, items := dervLabels, selection := 0 ]
- onDerChoice
- updateDerTxt $ show $ length derivations
- _ ->
- do set derChoice [ enabled := False, items := [] ]
- updateDerTxt "n/a"
- addGvHandler gvRef handler
- -- call the handler to react to the first selection
- handler `liftM` readIORef gvRef
- -- pushing and popping between nodes
- let jumpToNode jmpTo =
- do gvSt <- readIORef gvRef
- let chartItems = Map.elems $ gvitems gvSt
- case findIndex isJmpTo chartItems of
- Nothing -> geniBug $ "Was asked to see node " ++ (show jmpTo) ++ ", which is not in the list"
- Just x ->
- do setGvSel gvRef x
- modifyGvParams gvRef (setDebugWhichDerivation 0)
- readIORef gvRef >>= handler
- updaterFn
- where isJmpTo Nothing = False
- isJmpTo (Just (_,x)) = ciId x == jmpTo
- set jumpBtn [ on command := do
- gvSt <- readIORef gvRef
- case Map.lookup (gvsel gvSt) (gvitems gvSt) of
- Just (Just x) -> modifyGvParams gvRef (pushDebugNodeChoice $ (ciId.snd) x)
- _ -> return ()
- jmpSel <- get jumpChoice selection
- jmpItms <- get jumpChoice items
- let jmpTo = (read $ jmpItms !! jmpSel)
- jumpToNode jmpTo ]
-
- set unjumpBtn [ on command := do
- gvSt <- readIORef gvRef
- case popDebugNodeChoice (gvparams gvSt) of
- Nothing -> return ()
- Just (x,gvParam) -> do modifyGvParams gvRef (const gvParam)
- jumpToNode x ]
- --
- return $ hfloatCentre $ container ib $ column 0 $
- [ row 5
- [ label "Show...", widget fullDervChk, widget srcTreeChk, widget detailsChk ]
- , row 5
- [ widget derTxt, widget derChoice
- , hspace 5, label "Node", widget jumpChoice, widget jumpBtn, widget unjumpBtn ] ]
-\end{code}
-
-\section{Helper code}
-
-\begin{code}
-
-gornAddressStr :: Tree GNode -> GNode -> Maybe String
-gornAddressStr t target =
- (concat . intersperse "." . map show) `liftM` gornAddress t target
-
-gornAddress :: Tree GNode -> GNode -> Maybe [Int]
-gornAddress tr target = reverse `liftM` helper [] tr
- where
- helper current (Node x _) | (gnname x == gnname target) = Just current
- helper current (Node _ l) = listToMaybe $ catMaybes $
- zipWith (\c t -> helper (c:current) t) [1..] l
-
-
-selectedDerivation :: CkyDebugParams -> CkyStatus -> CkyItem -> Tree (ChartId, String)
-selectedDerivation f s c =
- let derivations = extractDerivations s c
- whichDer = debugWhichDerivation f
- in if boundsCheck whichDer derivations
- then derivations !! whichDer
- else geniBug $ "Bounds check failed on derivations selector:\n"
- ++ "Selected derivation: " ++ (show whichDer) ++ "\n"
- ++ "Bounds: 0 to " ++ (show $ length derivations - 1)
-
-derivationNodes :: Tree (ChartId, String) -> [ChartId]
-derivationNodes = (map fst).flatten
-
--- | Remove na and subst or adj completion links
-thinDerivationTree :: Tree (ChartId, String) -> Tree (ChartId, String)
-thinDerivationTree =
- let thinlst = ["no-adj", "subst", "adj" ]
- helper n@(Node _ []) = n
- -- this is made complicated for fancy highlighting to work
- helper (Node (i,op) [k]) | op `elem` thinlst = (Node (i,op2) k2)
- where (Node (_,op2) k2) = helper k
- helper (Node x kids) = (Node x $ map helper kids)
- in helper
-
-instance GraphvizShow CkyDebugParams (CkyStatus, CkyItem) where
- graphvizLabel f (_,c) = graphvizLabel f c
- graphvizParams f (_,c) = graphvizParams f c
- graphvizShowAsSubgraph f p (s,c) =
- let color_ x = ("color", x)
- label_ x = ("label", x)
- style_ x = ("style", x)
- arrowtail_ x = ("arrowtail", x)
- --
- substColor = color_ "blue"
- adjColor = color_ "red"
- --
- edgeParams (_ ,"no-adj") = [ label_ "na" ]
- edgeParams (_, "kids" ) = []
- edgeParams (_, "init" ) = [ label_ "i" ]
- edgeParams (_, "subst" ) = [ substColor ]
- edgeParams (_, "adj" ) = [ adjColor ]
- edgeParams (_, "subst-finish") = [ substColor, style_ "bold" , arrowtail_ "normal" ]
- edgeParams (_, "adj-finish") = [ adjColor , style_ "dashed, bold", arrowtail_ "normal" ]
- edgeParams (_, k) = [ ("label", "UNKNOWN: " ++ k) ]
- --
- whichDer = debugWhichDerivation f
- showFullDer = debugShowFullDerv f
- showSrcTree = debugShowSourceTree f
- showTree i t = gvSubgraph $ gvShowTree edgeParams (s,showFullDer, [ciId c]) prfx t
- where prfx = p ++ "t" ++ (show i)
- gvDerv = showTree whichDer $ if showFullDer then t else thinDerivationTree t
- where t = selectedDerivation f s c
- --
- joinedAut = uncurry mJoinAutomataUsingHole $ unpackItemToAuts s c
- gvAut = graphvizShowAsSubgraph () (p ++ "aut") joinedAut
- --
- showFeats = debugShowFeats f
- treeParams = unlines $ graphvizParams showFeats $ ciSourceTree c
- -- FIXME: will have to make this configurable, maybe, show aut, show tree? radio button?
- in "\n// ------------------- derivations --------------------------\n"
- ++ treeParams ++ "node [ shape = plaintext, peripheries = 0 ]\n"
- ++ gvDerv
- ++ "\n// ------------------- automata (joined) ------------------------\n"
- ++ gvSubgraph gvAut
- ++ if showSrcTree
- then ("\n// ------------------- elementary tree --------------------------\n"
- ++ treeParams ++ graphvizShowAsSubgraph f p c)
- else ""
-
-instance GraphvizShowNode (CkyStatus,Bool,[ChartId]) (ChartId, String) where
- graphvizShowNode (st,showFullDerv,highlight) prefix (theId,_) =
- let idStr = show theId
- treename i = " (" ++ ((idname.ciSourceTree) i) ++ ")"
- txt = case findId st theId of
- Nothing -> ("???" ++ idStr)
- Just i -> idStr ++ " " ++ (show.ciNode) i
- ++ (if showFullDerv then treename i else "")
- custom = if theId `elem` highlight then [ ("fontcolor","red") ] else []
- in gvNode prefix txt custom
-
-instance GraphvizShow CkyDebugParams CkyItem where
- graphvizLabel f ci =
- graphvizLabel (debugShowFeats f, nullHlter) (toTagElem ci) ++
- gvNewline ++ (gvUnlines $ ciDiagnostic ci)
-
- graphvizShowAsSubgraph f prefix ci =
- let showFeats = debugShowFeats f
- hlter n = (n, if (gnname n) == (gnname $ ciNode ci)
- then Just "red" else Nothing)
- in graphvizShowAsSubgraph (showFeats,hlter) (prefix ++ "tree") $ toTagElem ci
-
-nullHlter :: GNode -> (GNode, Maybe String)
-nullHlter a = (a,Nothing)
-
-toTagElem :: CkyItem -> TagElem
-toTagElem ci =
- te { ttree = ttree te
- , tsemantics = bitVectorToSem (ciSemBitMap ci) (ciSemantics ci) }
- where te = ciSourceTree ci
-
--- FIXME: this is largely copy-and-pasted from Polarity.lhs
--- it should be refactored later
-instance GraphvizShow () B.SentenceAut where
- graphvizShowAsSubgraph _ prefix aut =
- let st = (concat.states) aut
- ids = map (\x -> prefix ++ show x) ([0..]::[Int])
- -- map which permits us to assign an id to a state
- stmap = Map.fromList $ zip st ids
- lookupFinal x = Map.findWithDefault "error_final" x stmap
- in -- final states should be a double-edged ellispse
- "node [ shape = ellipse, peripheries = 2 ]; "
- ++ (unlines $ map lookupFinal $ finalStList aut)
- -- any other state should be an ellipse
- ++ "node [ shape = ellipse, peripheries = 1 ]\n"
- -- draw the states and transitions
- ++ (concat $ zipWith gvShowState ids st)
- ++ (concat $ zipWith (gvShowTrans aut stmap) ids st )
-
-type SentenceAutState = Int
-
-gvShowState :: String -> SentenceAutState -> String
-gvShowState stId st = gvNode stId (show st) []
-
-gvShowTrans :: B.SentenceAut -> Map.Map SentenceAutState String
- -> String -> SentenceAutState -> String
-gvShowTrans aut stmap idFrom st =
- let -- outgoing transition labels from st
- trans = Map.findWithDefault Map.empty st $ transitions aut
- -- returns the graphviz dot command to draw a labeled transition
- drawTrans (stTo,x) = case Map.lookup stTo stmap of
- Nothing -> drawTrans' ("id_error_" ++ (show stTo)) x
- Just idTo -> drawTrans' idTo x
- drawTrans' idTo x = gvEdge idFrom idTo (drawLabel x) []
- drawLabel labels = gvUnlines $ map fst $ catMaybes labels
- in unlines $ map drawTrans $ Map.toList trans
-\end{code}
-
-\begin{code}
--- | join two automata, inserting a ".." transition between them
-mJoinAutomataUsingHole :: Maybe B.SentenceAut -> Maybe B.SentenceAut -> Maybe B.SentenceAut
-mJoinAutomataUsingHole aut1 Nothing = aut1
-mJoinAutomataUsingHole aut1 aut2 =
- mJoinAutomata aut1 $ mJoinAutomata (Just holeAut) aut2
- where holeAut = addTrans emptyA 0 (Just ("..",[])) 1
- emptyA = emptySentenceAut { startSt = 0, finalStList = [1], states = [[0,1]] }
-\end{code}
diff --git a/src/NLP/GenI/Configuration.lhs b/src/NLP/GenI/Configuration.lhs
--- a/src/NLP/GenI/Configuration.lhs
+++ b/src/NLP/GenI/Configuration.lhs
@@ -21,26 +21,26 @@
{-# LANGUAGE ExistentialQuantification #-}
module NLP.GenI.Configuration
( Params(..), GrammarType(..), BuilderType(..), Instruction, Flag
- -- flags
+ -- * flags
, BatchDirFlg(..)
+ , DetectPolaritiesFlg(..)
, DisableGuiFlg(..)
+ , DumpDerivationFlg(..)
, EarlyDeathFlg(..)
, ExtraPolaritiesFlg(..)
, FromStdinFlg(..)
, HelpFlg(..)
- , IgnoreSemanticsFlg(..)
, InstructionsFileFlg(..)
, LexiconFlg(..)
, MacrosFlg(..)
- , MaxTreesFlg(..)
, MetricsFlg(..)
, MorphCmdFlg(..)
, MorphInfoFlg(..)
- , MorphLexiconFlg(..)
, NoLoadTestSuiteFlg(..)
, OptimisationsFlg(..)
, OutputFileFlg(..)
, PartialFlg(..)
+ , RankingConstraintsFlg(..)
, RegressionTestModeFlg(..)
, RootFeatureFlg(..)
, RunUnitTestFlg(..)
@@ -51,16 +51,15 @@
, TimeoutFlg(..)
, TracesFlg(..)
, VerboseModeFlg(..)
+ , VersionFlg(..)
, ViewCmdFlg(..)
--
, mainBuilderTypes
- , getFlagP, getListFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt, polarised
+ , getFlagP, getListFlagP, setFlagP, hasFlagP, deleteFlagP, hasOpt
, getFlag, setFlag, hasFlag
, Optimisation(..)
- , rootcatfiltered, semfiltered
- , isIaf
, emptyParams, defineParams
- , treatArgs, treatStandardArgs, treatArgsWithParams, treatStandardArgsWithParams
+ , treatArgs, treatArgsWithParams, usage, basicSections, optionsSections
, processInstructions
, optionsForStandardGenI
, optionsForBasicStuff, optionsForOptimisation, optionsForMorphology, optionsForInputFiles
@@ -78,20 +77,22 @@
\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.Exit ( exitFailure, exitWith, ExitCode(..) )
+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 ( GeniVal(GConst), Flist, showFlist, )
+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}
}
@@ -121,13 +122,6 @@
hasOpt :: Optimisation -> Params -> Bool
hasOpt o p = maybe False (elem o) $ getFlagP OptimisationsFlg p
-polarised, isIaf :: Params -> Bool
-rootcatfiltered, semfiltered :: Params -> Bool
-polarised = hasOpt Polarised
-isIaf = hasOpt Iaf
-semfiltered = hasOpt SemFiltered
-rootcatfiltered = hasOpt RootCatFiltered
-
hasFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Bool
deleteFlagP :: (Typeable f, Typeable x) => (x -> f) -> Params -> Params
setFlagP :: (Eq f, Show f, Show x, Typeable f, Typeable x) => (x -> f) -> x -> Params -> Params
@@ -145,8 +139,11 @@
builderType = SimpleBuilder,
grammarType = GeniHand,
geniFlags = [ Flag ViewCmdFlg "ViewTAG"
- , Flag RootFeatureFlg defaultRootFeat ]
+ , Flag DetectPolaritiesFlg (readPolarityAttrs defaultPolarityAttrs)
+ , Flag RootFeatureFlg (readRF defaultRootFeat)
+ ]
}
+ where readRF = parseFlagWithParsec "default root feature" geniFeats
\end{code}
% --------------------------------------------------------------------
@@ -158,7 +155,10 @@
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]
@@ -167,7 +167,12 @@
++ -- FIXME: weird mac stuff
[ Option ['p'] [] (reqArg WeirdFlg id "CMD") "" ]
-optionsSections :: [(String,[OptDescr Flag],[String])]
+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, [])
@@ -178,7 +183,6 @@
, ("Morphology", optionsForMorphology, [])
, ("User interface", optionsForUserInterface, [])
, ("Batch processing", optionsForTesting, [])
- , ("Miscellaneous", nubBySwitches $ optionsForIgnoreSem, [])
]
where
example = [ "Example:"
@@ -190,17 +194,7 @@
nubBySwitches :: [OptDescr a] -> [OptDescr a]
nubBySwitches = nubBy (\x y -> getSwitches x == getSwitches y)
-\end{code}
-\subsection{Essential arguments}
-
-See also section \ref{sec:optimisations} for more details on
-optimisations.
-
-% FIXME: what would be great is some special processing of the
-% code below so that the documentation writes itself
-
-\begin{code}
-- GetOpt wrappers
noArg :: forall f . (Eq f, Show f, Typeable f)
=> (() -> f) -> ArgDescr Flag
@@ -227,14 +221,12 @@
-- Parsing command line arguments
-- -------------------------------------------------------------------
-usage :: Bool -- ^ advanced
+-- | Print out a GenI-style usage message with options divided into sections
+usage :: [OptSection] -- ^ options
+ -> String -- ^ prog name
-> String
-usage adv =
- let header = "Usage: geni [OPTION...]\n"
- tweakBasic (x,y,z) = (x,y,z ++ ["See geni --help for more details"])
- sections = if adv
- then optionsSections
- else map tweakBasic $ take 1 optionsSections
+usage sections pname =
+ let header = "Usage: " ++ pname ++ " [OPTION...]\n"
body = unlines $ map usageSection sections
in header ++ body
@@ -245,40 +237,19 @@
bar = replicate 72 '='
mcomments = if null comments then [] else "\n" ++ unlines comments
-treatStandardArgs :: [String] -> IO Params
-treatStandardArgs argv = treatStandardArgsWithParams argv emptyParams
-
-treatStandardArgsWithParams :: [String] -> Params -> IO Params
-treatStandardArgsWithParams = treatArgsWithParams optionsForStandardGenI
-
treatArgs :: [OptDescr Flag] -> [String] -> IO Params
treatArgs options argv = treatArgsWithParams options argv emptyParams
treatArgsWithParams :: [OptDescr Flag] -> [String] -> Params -> IO Params
treatArgsWithParams options argv initParams =
case getOpt Permute options argv of
- (os,_,[] )
- | hasFlag HelpFlg os ->
- do putStrLn $ usage True
- exitWith ExitSuccess
- | hasFlag DisableGuiFlg os
- && notHasFlag TestCaseFlg os
- && notHasFlag RegressionTestModeFlg os
- && notHasFlag BatchDirFlg os
- && notHasFlag FromStdinFlg os ->
- do putStrLn $ "GenI must either be run in graphical mode, "
- ++ "in regression mode, with a test case specified, with --from-stdin,"
- ++ "or with a batch directory specified"
- exitFailure
- | otherwise ->
- return $ defineParams os initParams
- (_,_,errs) -> ioError (userError $ concat errs ++ usage False)
- where notHasFlag f l = not $ hasFlag f l
+ (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)
- . maybeSetMaxTrees
. (mergeFlagsP OptimisationsFlg)
. (mergeFlagsP MetricsFlg)
$ prms
@@ -295,14 +266,14 @@
else p
fromFlags default_ t fs =
fromMaybe (default_ prms) (getFlag t fs)
- maybeSetMaxTrees p =
- if hasFlagP IgnoreSemanticsFlg p && (not $ hasFlagP MaxTreesFlg p)
- then setFlagP MaxTreesFlg 5 p else p
\end{code}
\section{Options by theme}
\label{sec:fancy_parameters}
+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.
@@ -310,6 +281,7 @@
\subsection{Basic options}
% --------------------------------------------------------------------
+
\begin{code}
optionsForBasicStuff :: [OptDescr Flag]
optionsForBasicStuff =
@@ -323,6 +295,24 @@
\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 =
@@ -333,12 +323,12 @@
, fromStdinOption
, morphInfoOption
, instructionsOption
- , outputOption
+ , rankingOption
, Option [] ["preselected"] (NoArg (Flag GrammarTypeFlg PreAnchored))
"do NOT perform lexical selection - treat the grammar as the selection"
]
-instructionsOption, macrosOption, lexiconOption, tracesOption, outputOption :: OptDescr Flag
+instructionsOption, macrosOption, lexiconOption, tracesOption :: OptDescr Flag
instructionsOption =
Option [] ["instructions"] (reqArg InstructionsFileFlg id "FILE")
@@ -346,7 +336,7 @@
macrosOption =
Option ['m'] ["macros"] (reqArg MacrosFlg id "FILE")
- "macros file FILE (unanchored trees)"
+ "tree schemata file FILE (unanchored trees)"
lexiconOption =
Option ['l'] ["lexicon"] (reqArg LexiconFlg id "FILE")
@@ -356,9 +346,10 @@
Option [] ["traces"] (reqArg TracesFlg id "FILE")
"traces file FILE (list of traces to display)"
-outputOption =
- Option ['o'] ["output"] (reqArg OutputFileFlg id "FILE")
- "output file FILE (stdout if unset)"
+rankingOption :: OptDescr Flag
+rankingOption =
+ Option [] ["ranking"] (reqArg RankingConstraintsFlg id "FILE")
+ "ranking constraints FILE (using Optimality Theory)"
\end{code}
% --------------------------------------------------------------------
@@ -369,9 +360,19 @@
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}
% --------------------------------------------------------------------
@@ -381,7 +382,7 @@
\begin{code}
optionsForUserInterface :: [OptDescr Flag]
optionsForUserInterface =
- [ noguiOption, helpOption
+ [ noguiOption, helpOption, versionOption
, Option [] ["regression"] (noArg RegressionTestModeFlg)
"Run in regression testing mode (needs grammar, etc)"
, Option [] ["unit-tests"] (noArg RunUnitTestFlg)
@@ -390,11 +391,19 @@
"XMG tree-view command"
]
-verboseOption, noguiOption, helpOption :: OptDescr Flag
+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}
@@ -422,19 +431,37 @@
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 :: Flist
-defaultRootFeat =
- [ ("cat" , GConst ["s"])
- , ("inv" , GConst ["-"])
- , ("mode", GConst ["ind","subj"])
- , ("wh" , GConst ["-"])
- ]
+defaultRootFeat :: String
+defaultRootFeat = "[cat:s inv:- mode:ind|subj wh:-]"
\end{code}
\end{includecodeinmanual}
@@ -454,6 +481,9 @@
[ 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:"
@@ -467,16 +497,20 @@
readRF = parseFlagWithParsec "root feature" geniFeats
readPolarities = parseFlagWithParsec "polarity string" geniPolarities
-data Optimisation =
- PolOpts | AdjOpts | Polarised | NoConstraints |
- RootCatFiltered | SemFiltered | Iaf {- one phase only! -}
+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)")
- , (RootCatFiltered , "f-root", "filtering on root node (two-phase only)")
, (Iaf , "i", "index accesibility filtering (one-phase only)")
, (NoConstraints , "nc", "disable semantic constraints (anti-optimisation!)")
]
@@ -492,7 +526,7 @@
polOpts, adjOpts :: [Optimisation]
polOpts = [Polarised]
-adjOpts = [RootCatFiltered, SemFiltered]
+adjOpts = [EarlyNa, SemFiltered]
\end{code}
\begin{code}
@@ -567,24 +601,20 @@
\begin{description}
\item[builder]
- A builder is basically a surface realisation algorithm. Some
- builders do not differ by very much. For example, the Earley and CKY builders
- are more or less the same from GenI's point of view, except with one little
- parameter to tweak.
+ 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 |
- CkyBuilder | EarleyBuilder
+ SimpleBuilder | SimpleOnePhaseBuilder
deriving (Eq, Typeable)
instance Show BuilderType where
show NullBuilder = "null"
show SimpleBuilder = "simple-2p"
show SimpleOnePhaseBuilder = "simple-1p"
- show CkyBuilder = "CKY"
- show EarleyBuilder = "Earley"
optionsForBuilder :: [OptDescr Flag]
optionsForBuilder =
@@ -595,13 +625,11 @@
mainBuilderTypes :: [BuilderType]
mainBuilderTypes =
[ SimpleBuilder, SimpleOnePhaseBuilder
- , CkyBuilder, EarleyBuilder]
+ ]
-- | Hint: compose with (map toLower) to make it case-insensitive
mReadBuilderType :: String -> Maybe BuilderType
mReadBuilderType "null" = Just NullBuilder
-mReadBuilderType "cky" = Just CkyBuilder
-mReadBuilderType "earley" = Just EarleyBuilder
mReadBuilderType "simple" = Just SimpleBuilder
mReadBuilderType "simple-2p" = Just SimpleBuilder
mReadBuilderType "simple-1p" = Just SimpleOnePhaseBuilder
@@ -681,43 +709,11 @@
[ morphInfoOption
, Option [] ["morphcmd"] (reqArg MorphCmdFlg id "CMD")
"morphological post-processor CMD (default: unset)"
- , Option [] ["morphlexicon"] (reqArg MorphLexiconFlg id "FILE")
- "morphological lexicon FILE (default: unset) - overrides morphcmd!"
]
morphInfoOption :: OptDescr Flag
morphInfoOption = Option [] ["morphinfo"] (reqArg MorphInfoFlg id "FILE")
- "morphological lexicon FILE (default: unset)"
-\end{code}
-
-% --------------------------------------------------------------------
-\subsection{Ignore semantics mode}
-% --------------------------------------------------------------------
-
-\begin{description}
-\item[ignoresem] is a special generation mode for systematically
-churning out any sentences that the grammar can produce, without
-using an input semantics. \textbf{Note}: This was implemented by Jackie
-Lai (see patches around 2005-06-16), but has been horribly broken by
-Eric sometime before 2006-08. Please let us know if you actually use
-this thing, so that we can fix it.
-\item[maxtrees] limits ignoresem mode by restricting the size of its
-derivation trees (in number of elementary trees). Otherwise, GenI
-would just spin around exploring an infinite number of sentences.
-If you don't specify a maxtrees under ignoresem mode, we'll use a
-default of 5. Note that maxtrees also works in normal generation
-mode. It could be a useful way of saying ``give me only really
-small sentences''.
-\end{description}
-
-\begin{code}
-optionsForIgnoreSem :: [OptDescr Flag]
-optionsForIgnoreSem =
- [ Option [] ["ignoresem"] (noArg IgnoreSemanticsFlg)
- "ignore all semantic information"
- , Option [] ["maxtrees"] (reqArg MaxTreesFlg read "INT")
- "max tree size INT by number of elementary trees"
- ]
+ "morphological features FILE (default: unset)"
\end{code}
% --------------------------------------------------------------------
@@ -735,6 +731,10 @@
\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
@@ -742,36 +742,53 @@
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 let is0 = case getFlagP TestSuiteFlg config of
- Just ts -> case getFlagP TestCaseFlg config of
- Just c -> [ (ts, Just [c]) ]
- Nothing -> [ (ts, Nothing) ]
- Nothing -> []
- is <- case getFlagP InstructionsFileFlg config of
- Nothing -> return []
- Just f -> instructionsFile `fmap` readFile f
+ 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 instructions = is0 ++ is
- updateInstructions =
+ let updateInstructions =
setFlagP TestInstructionsFlg instructions
- updateTestCase =
- case (listToMaybe instructions >>= snd >>= listToMaybe) of
- Just c -> setFlagP TestCaseFlg c
- Nothing -> id
- updateTestSuite =
- case (fst `fmap` listToMaybe instructions) of
- Just s -> setFlagP TestSuiteFlg s
- Nothing -> id
- updateFlags = updateInstructions . updateTestSuite . updateTestCase
- return $ updateFlags config
+ 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
@@ -833,23 +850,23 @@
FLAG (BatchDirFlg, FilePath)
FLAG (DisableGuiFlg, ())
+FLAG (DetectPolaritiesFlg, (Set.Set PolarityAttr))
+FLAG (DumpDerivationFlg, ())
FLAG (EarlyDeathFlg, ())
-FLAG (ExtraPolaritiesFlg, (Map.Map String Interval))
+FLAG (ExtraPolaritiesFlg, (Map.Map PolarityKey Interval))
FLAG (FromStdinFlg, ())
FLAG (HelpFlg, ())
-FLAG (IgnoreSemanticsFlg, ())
FLAG (InstructionsFileFlg, FilePath)
FLAG (LexiconFlg, FilePath)
FLAG (MacrosFlg, FilePath)
FLAG (TracesFlg, FilePath)
-FLAG (MaxTreesFlg, Int)
FLAG (MetricsFlg, [String])
FLAG (MorphCmdFlg, String)
FLAG (MorphInfoFlg, FilePath)
-FLAG (MorphLexiconFlg, FilePath)
FLAG (OptimisationsFlg, [Optimisation])
FLAG (OutputFileFlg, String)
FLAG (PartialFlg, ())
+FLAG (RankingConstraintsFlg, FilePath)
FLAG (RegressionTestModeFlg, ())
FLAG (RootFeatureFlg, Flist)
FLAG (RunUnitTestFlg, ())
@@ -860,6 +877,7 @@
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
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
@@ -26,74 +26,79 @@
import Data.Maybe ( isJust, fromMaybe )
import System.Directory(createDirectoryIfMissing)
import System.Exit ( exitFailure )
-import System.FilePath ( () )
-import Test.HUnit.Text (runTestTT)
-import qualified Test.HUnit.Base as H
-import Test.HUnit.Base ((@?))
+import System.FilePath ( (), takeFileName )
import NLP.GenI.Btypes
- ( SemInput, showSem
- , TestCase(tcSem, tcName, tcExpected)
+ ( SemInput, TestCase(tcSem, tcName)
)
import qualified NLP.GenI.Btypes as G
import NLP.GenI.General
- ( ePutStrLn, withTimeout, exitTimeout
- , fst3,
+ ( ePutStr, ePutStrLn, withTimeout, exitTimeout
)
import NLP.GenI.Geni
import NLP.GenI.Configuration
( Params
- , BatchDirFlg(..), EarlyDeathFlg(..), FromStdinFlg(..), OutputFileFlg(..)
- , MetricsFlg(..), RegressionTestModeFlg(..), RunUnitTestFlg(..), StatsFileFlg(..)
- , TestCaseFlg(..), TimeoutFlg(..), VerboseModeFlg(..)
- , hasFlagP, getFlagP
+ , BatchDirFlg(..), DumpDerivationFlg(..), EarlyDeathFlg(..), FromStdinFlg(..), OutputFileFlg(..)
+ , MetricsFlg(..), RankingConstraintsFlg(..), StatsFileFlg(..)
+ , TestCaseFlg(..), TestSuiteFlg(..), TestInstructionsFlg(..)
+ , TimeoutFlg(..), VerboseModeFlg(..)
+ , hasFlagP, getListFlagP, getFlagP, setFlagP
, builderType , BuilderType(..)
)
import qualified NLP.GenI.Builder as B
-import NLP.GenI.CkyEarley.CkyBuilder
import NLP.GenI.Simple.SimpleBuilder
-import NLP.GenI.Statistics ( showFinalStats, Statistics )
-import NLP.GenI.Test (runTests)
+import NLP.GenI.Statistics ( Statistics )
+import Text.JSON
+import Text.JSON.Pretty ( render, pp_value )
+
consoleGeni :: ProgStateRef -> IO()
consoleGeni pstRef = do
pst <- readIORef pstRef
- if hasFlagP RunUnitTestFlg (pa pst)
- then runTests
- else do
loadEverything pstRef
case getFlagP TimeoutFlg (pa pst) of
- Nothing -> runSuite pstRef
- Just t -> withTimeout t (timeoutErr t) $ runSuite pstRef
+ Nothing -> runInstructions pstRef
+ Just t -> withTimeout t (timeoutErr t) $ runInstructions pstRef
where
timeoutErr t = do ePutStrLn $ "GenI timed out after " ++ (show t) ++ "s"
exitTimeout
--- | Runs a test suite.
--- We assume that the grammar and target semantics are already
+-- | Runs the tests specified in our instructions list.
+-- We assume that the grammar and lexicon are already
-- loaded into the monadic state.
-- If batch processing is enabled, save the results to the batch output
--- directory with one subdirectory per case.
-runSuite :: ProgStateRef -> IO ()
-runSuite pstRef =
+-- directory with one subdirectory per suite and per case within that suite.
+runInstructions :: ProgStateRef -> IO ()
+runInstructions pstRef =
do pst <- readIORef pstRef
- let suite = tsuite pst
- config = pa pst
- verbose = hasFlagP VerboseModeFlg config
- earlyDeath = hasFlagP EarlyDeathFlg config
- if hasFlagP RegressionTestModeFlg config
- then runRegressionSuite pstRef >> return ()
- else case getFlagP BatchDirFlg config of
- Nothing -> runTestCaseOnly pstRef >> return ()
- Just bdir -> runBatch earlyDeath verbose bdir suite
+ let config = pa pst
+ case getFlagP BatchDirFlg config of
+ Nothing -> runTestCaseOnly pstRef >> return ()
+ Just bdir -> runBatch bdir
where
- runBatch earlyDeath verbose bdir suite =
- if any null $ map tcName suite
- then ePutStrLn "Can't do batch processing. The test suite has cases with no name."
- else do ePutStrLn "Batch processing mode"
- mapM_ (runCase earlyDeath verbose bdir) suite
- runCase earlyDeath verbose bdir (G.TestCase { tcName = n, tcSem = s }) =
- do when verbose $
+ 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
+ -- 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
+ 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 }) =
+ 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"
@@ -101,29 +106,6 @@
ePutStrLn $ "Exiting early because test case " ++ n ++ " failed."
exitFailure
--- | Run a test suite, but in HUnit regression testing mode,
--- treating each GenI test case as an HUnit test. Obviously
--- we need a test suite, grammar, etc as input
-runRegressionSuite :: ProgStateRef -> IO (H.Counts)
-runRegressionSuite pstRef =
- do pst <- readIORef pstRef
- tests <- (mapM toTest) . tsuite $ pst
- runTestTT . (H.TestList) . concat $ tests
- where
- toTest :: G.TestCase -> IO [H.Test] -- ^ GenI test case to HUnit Tests
- toTest tc = -- run the case, and return a test case for each expected result
- do (res , _) <- runOnSemInput pstRef InRegressionTest (tcSem tc)
- let sentences = fst (unzip res)
- name = tcName tc
- semStr = showSem . fst3 . tcSem $ tc
- mainMsg = "for " ++ semStr ++ ", got no results"
- mainCase = H.TestLabel name
- $ H.TestCase $ (not.null $ sentences) @? mainMsg
- subMsg e = "for " ++ semStr ++ ", failed to get (" ++ e ++ ")"
- subCase e = H.TestLabel name
- $ H.TestCase $ (e `elem` sentences) @? subMsg e
- return $ (mainCase :) $ map subCase (tcExpected tc)
-
-- | Run the specified test case, or failing that, the first test
-- case in the suite
runTestCaseOnly :: ProgStateRef -> IO ([GeniResult], Statistics)
@@ -151,7 +133,6 @@
data RunAs = Standalone FilePath FilePath
| PartOfSuite String FilePath
- | InRegressionTest
-- | Runs a case in the test suite. If the user does not specify any test
-- cases, we run the first one. If the user specifies a non-existing
@@ -161,16 +142,16 @@
-> SemInput
-> IO ([GeniResult], Statistics)
runOnSemInput pstRef args semInput =
- do modifyIORef pstRef (\x -> x{ts = semInput})
+ do modifyIORef pstRef (\x -> x{ts = semInput, warnings = []})
pst <- readIORef pstRef
let config = pa pst
- (results', stats) <- case builderType config of
+ 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
- CkyBuilder -> helper ckyBuilder
- EarleyBuilder -> helper earleyBuilder
- let results = sort results'
+ warningsOut <- warnings `fmap` readIORef pstRef
-- create directory if need be
case args of
PartOfSuite n f -> createDirectoryIfMissing False (f n)
@@ -179,18 +160,35 @@
Standalone "" _ -> putStrLn
Standalone f _ -> writeFile f
PartOfSuite n f -> writeFile $ f n "responses"
- InRegressionTest -> const $ return ()
+ 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"
- InRegressionTest -> const $ return ()
- oWrite . unlines . map fst $ results
+ --
+ 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) $
- do soWrite $ "begin stats\n" ++ showFinalStats stats ++ "end"
+ when (isJust $ getFlagP MetricsFlg config) $ soWrite (ppJSON stats)
+ --
return (results, stats)
where
+ ppJSON :: JSON a => a -> String
+ ppJSON = render . pp_value . showJSON
helper builder =
do (results, stats, _) <- runGeni pstRef builder
return (results, stats)
+
diff --git a/src/NLP/GenI/General.hs b/src/NLP/GenI/General.hs
--- a/src/NLP/GenI/General.hs
+++ b/src/NLP/GenI/General.hs
@@ -37,9 +37,7 @@
-- * Triples
fst3, snd3, thd3,
-- * Lists
- equating, comparing,
map',
- wordsBy,
boundsCheck,
isEmptyIntersect,
groupByFM,
@@ -67,7 +65,8 @@
import Control.Monad (liftM)
import Data.Bits (shiftR, (.&.))
import Data.Char (isDigit, isSpace, toUpper, toLower)
-import Data.List (intersect, groupBy, group, sort)
+import Data.Function ( on )
+import Data.List (foldl', intersect, groupBy, group, sort)
import Data.Tree
import System.IO (hPutStrLn, hPutStr, hFlush, stderr)
import qualified Data.Map as Map
@@ -140,7 +139,7 @@
-- around because the characters 1 < 2. To sort alphanumerically, just
-- 'sortBy (comparing toAlphaNum)'
toAlphaNum :: String -> [AlphaNum]
-toAlphaNum = map readOne . groupBy (equating isDigit)
+toAlphaNum = map readOne . groupBy ((==) `on` isDigit)
where
readOne s
| all isDigit s = N (read s)
@@ -163,22 +162,11 @@
-- Lists
-- ----------------------------------------------------------------------
-equating :: Eq b => (a -> b) -> (a -> a -> Bool)
-equating f a b = f a == f b
-
-comparing :: Ord b => (a -> b) -> (a -> a -> Ordering)
-comparing f a b = compare (f a) (f b)
-
-- | A strict version of 'map'
map' :: (a->b) -> [a] -> [b]
map' _ [] = []
map' f (x:xs) = let a = f x in a `seq` (a:(map' f xs))
--- | A generic version of the Data.List.words
--- TODO: replace by version from split
-wordsBy :: (Eq a) => a -> [a] -> [[a]]
-wordsBy c xs = filter (/= [c]) $ groupBy (\x y -> x /= c && y /= c) xs
-
-- | Makes sure that index s is in the bounds of list l.
-- Surely there must be some more intelligent way to deal with this.
boundsCheck :: Int -> [a] -> Bool
@@ -199,7 +187,7 @@
groupByFM fn list =
let addfn x acc key = insertToListMap key x acc
helper acc x = addfn x acc (fn x)
- in foldl helper Map.empty list
+ 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,
@@ -207,8 +195,8 @@
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
+ 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]
@@ -325,7 +313,7 @@
-- | errors specifically in GenI, which is very likely NOT the user's fault.
geniBug :: String -> a
geniBug s = error $ "Bug in GenI!\n" ++ s ++
- "\nPlease file a report on http://wiki.loria.fr/wiki/GenI/Complaints"
+ "\nPlease file a report on http://trac.haskell.org/GenI/newticket"
-- ----------------------------------------------------------------------
-- Intervals
diff --git a/src/NLP/GenI/Geni.lhs b/src/NLP/GenI/Geni.lhs
--- a/src/NLP/GenI/Geni.lhs
+++ b/src/NLP/GenI/Geni.lhs
@@ -25,11 +25,19 @@
involve some messy IO performance tricks.
\begin{code}
-module NLP.GenI.Geni (ProgState(..), ProgStateRef, emptyProgState,
+module NLP.GenI.Geni (
+ -- * main interface
+ ProgState(..), ProgStateRef, emptyProgState,
+ initGeni,
+ runGeni, runGeniWithSelector,
+ GeniResult(..), ResultType(..),
+ -- * helpers
+ lemmaSentenceString, prettyResult,
showRealisations, groupAndCount,
- initGeni, runGeni, runGeniWithSelector, getTraces, GeniResult, Selector,
+ getTraces, Selector,
loadEverything, loadLexicon, loadGeniMacros,
loadTestSuite, loadTargetSemStr,
+ loadRanking, readRanking,
combine,
-- used by auxiliary tools only
@@ -40,38 +48,42 @@
\ignore{
\begin{code}
-import Control.Arrow (first)
+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.ParserCombinators.Parsec
+import Text.JSON
-- import System.Process
import NLP.GenI.General(filterTree, repAllNode,
- equating, groupAndCount, multiGroupByFM,
+ groupAndCount, multiGroupByFM,
geniBug,
repNodeByNode,
- wordsBy,
fst3,
ePutStr, ePutStrLn, eFlush,
)
import NLP.GenI.Btypes
(Macros, MTtree, ILexEntry, Lexicon,
- Replacable(..),
+ replace, replaceList,
Sem, SemInput, TestCase(..), sortSem, subsumeSem, params,
- GeniVal(GConst), fromGVar,
- GNode(ganchor, gnname, gup, gdown, gaconstr, gtype, gorigin), Flist,
+ GeniVal(GConst), fromGVar, AvPair(..),
+ GNode(ganchor, gnname, gup, gdown, gaconstr, gtype, gorigin),
GType(Subs, Other),
isemantics, ifamname, iword, iparams, iequations,
iinterface, ifilters,
@@ -93,9 +105,10 @@
import NLP.GenI.Configuration
( Params, getFlagP, hasFlagP, hasOpt, Optimisation(NoConstraints)
, MacrosFlg(..), LexiconFlg(..), TestSuiteFlg(..), TestCaseFlg(..)
- , MorphInfoFlg(..), MorphCmdFlg(..), MorphLexiconFlg(..)
+ , MorphInfoFlg(..), MorphCmdFlg(..)
+ , RankingConstraintsFlg(..)
, PartialFlg(..)
- , IgnoreSemanticsFlg(..), FromStdinFlg(..), VerboseModeFlg(..)
+ , FromStdinFlg(..), VerboseModeFlg(..)
, NoLoadTestSuiteFlg(..)
, TracesFlg(..)
, grammarType
@@ -106,9 +119,11 @@
import NLP.GenI.GeniParsers (geniMacros, geniTagElems,
geniLexicon, geniTestSuite,
geniTestSuiteString, geniSemanticInput,
- geniMorphInfo, geniMorphLexicon,
+ geniMorphInfo,
+ parseFromFile, runParser, Parser,
)
import NLP.GenI.Morphology
+import NLP.GenI.OptimalityTheory
import NLP.GenI.Statistics (Statistics)
-- import CkyBuilder
@@ -132,14 +147,18 @@
gr :: Macros,
le :: Lexicon,
morphinf :: MorphFn,
- morphlex :: Maybe [(String,String,Flist)],
ts :: SemInput,
-- | names of test case to run
tcase :: String,
-- | name, original string (for gui), sem
tsuite :: [TestCase],
+ -- | OT constraints (optional)
+ ranking :: OtRanking,
-- | simplified traces (optional)
- traces :: [String]
+ traces :: [String],
+ -- | any warnings accumulated during realisation
+ -- (most recent first)
+ warnings :: [String]
}
type ProgStateRef = IORef ProgState
@@ -151,12 +170,17 @@
, gr = []
, le = Map.empty
, morphinf = const Nothing
- , morphlex = 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}
% --------------------------------------------------------------------
@@ -201,11 +225,11 @@
when isNotPreanchored $ loadLexicon pstRef
-- in any case, we have to...
loadMorphInfo pstRef
- when useTestSuite $ loadTestSuite pstRef
- -- the morphological lexicon
- loadMorphLexicon 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,
@@ -214,41 +238,53 @@
an IORef.
\begin{code}
-loadLexicon, loadGeniMacros, loadMorphInfo, loadMorphLexicon, loadTraces :: ProgStateRef -> IO ()
-
+loadLexicon :: ProgStateRef -> IO ()
loadLexicon pstRef =
- do config <- pa `fmap` readIORef pstRef
- let getSem l = if hasFlagP IgnoreSemanticsFlg config
- then [] else isemantics l
+ do let getSem l = isemantics l
sorter l = l { isemantics = (sortSem . getSem) l }
cleanup = mapBySemKeys isemantics . map sorter
- loadThingOrDie LexiconFlg "lexicon" pstRef
+ xs <- loadThingOrDie LexiconFlg "lexicon" pstRef
(parseFromFileOrFail geniLexicon)
- (\l p -> p { le = cleanup l })
+ modifyIORef pstRef (\p -> p { le = cleanup xs })
-- | The macros are stored as a hashing function in the monad.
+loadGeniMacros :: ProgStateRef -> IO ()
loadGeniMacros pstRef =
- loadThingOrDie MacrosFlg "trees" pstRef parser updater
+ do xs <- loadThingOrDie MacrosFlg "trees" pstRef parser
+ modifyIORef pstRef (\p -> p { gr = xs })
where parser = parseFromFileMaybeBinary geniMacros
- updater g p = p { gr = g }
-
-
-- | The results are stored as a lookup function in the monad.
+loadMorphInfo :: ProgStateRef -> IO ()
loadMorphInfo pstRef =
- loadThingOrIgnore MorphInfoFlg "morphological info" pstRef parser updater
+ do xs <- loadThingOrIgnore MorphInfoFlg "morphological info" pstRef parser
+ modifyIORef pstRef (\p -> p { morphinf = readMorph xs } )
where parser = parseFromFileOrFail geniMorphInfo
- updater m p = p { morphinf = readMorph m }
-loadMorphLexicon pstRef =
- loadThingOrIgnore MorphLexiconFlg "morphological lexicon" pstRef parser updater
- where parser = parseFromFileOrFail geniMorphLexicon
- updater m p = p { morphlex = Just m }
-
+loadTraces :: ProgStateRef -> IO ()
loadTraces pstRef =
- loadThingOrIgnore TracesFlg "traces" pstRef
- (\f -> lines `fmap` readFile f)
- (\t p -> p {traces = t})
+ 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}
@@ -263,22 +299,23 @@
\begin{code}
-- | Stores the results in the tcase and tsuite fields
-loadTestSuite :: ProgStateRef -> IO ()
+loadTestSuite :: ProgStateRef -> IO [TestCase]
loadTestSuite pstRef = do
config <- pa `fmap` readIORef pstRef
- unless (hasFlagP IgnoreSemanticsFlg config) $
- let parser f = do
- sem <- parseFromFileOrFail geniTestSuite f
- mStrs <- parseFromFileOrFail geniTestSuiteString f
- return $ zip sem mStrs
- updater s x =
- x { tsuite = map cleanup s
- , tcase = fromMaybe "" $ getFlagP TestCaseFlg config}
- cleanup (tc,str) =
- tc { tcSem = (sortSem sm, sort sr, lc)
- , tcSemString = str }
- where (sm, sr, lc) = tcSem tc
- in loadThingOrDie TestSuiteFlg "test suite" pstRef parser updater
+ 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
@@ -289,8 +326,7 @@
-- | Updates program state the same way as 'loadTestSuite'
loadTargetSemStr :: ProgStateRef -> String -> IO ()
loadTargetSemStr pstRef str =
- do pst <- readIORef pstRef
- if hasFlagP IgnoreSemanticsFlg (pa pst) then return () else parseSem
+ do parseSem
where
parseSem = do
let sem = runParser geniSemanticInput () "" str
@@ -303,38 +339,33 @@
\subsubsection{Helpers for loading files}
\begin{code}
-type UpdateFn a = (a -> ProgState -> ProgState)
-
loadThingOrIgnore, loadThingOrDie :: forall f a . (Eq f, Show f, Typeable f)
=> (FilePath -> f) -- ^ flag
-> String
-> ProgStateRef
-> (FilePath -> IO [a])
- -> UpdateFn [a]
- -> IO ()
-
-loadThing :: FilePath -- ^ file to load
- -> String -- ^ description
- -> ProgStateRef
- -> (FilePath -> IO [a]) -- ^ parsing cmd
- -> UpdateFn [a] -- ^ update fn
- -> IO ()
+ -> IO [a]
-- | Load the file if the relevant option is set, otherwise ignore
-loadThingOrIgnore flag description pstRef parser job =
+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 job
+ 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 job =
+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 job
+ Just f -> loadThing f description pstRef parser
-loadThing filename description pstRef parser job =
+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
@@ -342,7 +373,7 @@
eFlush
theTs <- parser filename
when verbose $ ePutStr $ (show $ length theTs) ++ " entries\n"
- modifyIORef pstRef (job theTs)
+ return theTs
parseFromFileOrFail :: Parser a -> FilePath -> IO a
parseFromFileOrFail p f = parseFromFile p f >>= either (fail.show) (return)
@@ -373,8 +404,23 @@
\end{enumerate}
\begin{code}
-type GeniResult = (String, B.Derivation)
+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
@@ -384,26 +430,22 @@
runGeniWithSelector :: ProgStateRef -> Selector -> B.Builder st it Params -> IO ([GeniResult], Statistics, st)
runGeniWithSelector pstRef selector builder =
- do let run = B.run builder
+ do pst <- readIORef pstRef
+ let config = pa pst
+ run = B.run builder
unpack = B.unpack builder
- getPartial = B.partial builder
- -- step 1
+ -- step 1: lexical selection
initStuff <- initGeniWithSelector pstRef selector
- --
- pst <- readIORef pstRef
- let config = pa pst
- -- step 2
- (finalSt, stats) = run initStuff config
- -- step 3
- uninflected = unpack finalSt
- partial = getPartial finalSt
- -- step 4
- sentences <- if null uninflected && hasFlagP PartialFlg config
- then map (first star) `fmap` finaliseResults pstRef partial
- else finaliseResults pstRef uninflected
- return (sentences, stats, finalSt)
- where star :: String -> String
- star s = '*' : s
+ -- 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}
% --------------------------------------------------------------------
@@ -429,11 +471,11 @@
then p { ts = (fst3 (ts p),[],[]) }
else p)
-- lexical selection
- pstLex <- readIORef pstRef
- (cand, lexonly) <- lexSelector pstLex
+ (cand, lexonly) <- lexSelector pstRef
+ pst <- readIORef pstRef
-- strip morphological predicates
- let (tsem,tres,lc) = ts pstLex
- tsem2 = stripMorphSem (morphinf pstLex) tsem
+ let (tsem,tres,lc) = ts pst
+ tsem2 = stripMorphSem (morphinf pst) tsem
--
let initStuff = B.Input
{ B.inSemInput = (tsem2, tres, lc)
@@ -441,18 +483,33 @@
, B.inCands = map (\c -> (c,-1)) cand
}
return initStuff
-\end{code}
-\begin{code}
--- | 'finaliseResults' for the moment consists only of running the
--- morphological generator, but there could conceivably be more involved.
-finaliseResults :: ProgStateRef -> [B.Output] -> IO [GeniResult]
-finaliseResults pstRef os =
- do mss <- runMorph pstRef ss
- return . concat $ zipWith merge mss ds
+-- | '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
- (ss,ds) = unzip os
- merge ms d = map (\m -> (m,d)) ms
+ 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}
% --------------------------------------------------------------------
@@ -470,9 +527,21 @@
in if null sentences
then "(none)"
else unlines sentencesGrouped
-\end{code}
-\begin{code}
+-- | 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
@@ -489,7 +558,7 @@
-- | We assume the name was constructed by 'combineName'
readPidname :: String -> String
readPidname n =
- case wordsBy ':' n of
+ case wordsBy (== ':') n of
(_:_:p:_) -> p
_ -> geniBug "readPidname or combineName are broken"
\end{code}
@@ -507,9 +576,10 @@
succeed in anchoring it.
\begin{code}
-runLexSelection :: ProgState -> IO ([TagElem], [ILexEntry])
-runLexSelection pst =
- do -- select lexical items first
+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
@@ -518,8 +588,10 @@
-- then anchor these lexical items to trees
let grammar = gr pst
combineWithGr l =
- do let (_, res) = combineList grammar 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)
@@ -529,10 +601,7 @@
[] -> return ()
cs -> mapM_ showWarning . group . sort $ cs
where showWarning [] = geniBug "silly error in Geni.runLexSelection"
- showWarning xs =
- ePutStrLn $
- "Warning: Missing co-anchor '" ++ head xs ++ "'"
- ++ " in " ++ (_outOfFamily $ length xs) ++ "."
+ showWarning xs@(x0:_) = addWarning pstRef $ "Missing co-anchor '" ++ x0 ++ "'" ++ " in " ++ _outOfFamily (length xs) ++ "."
-- print out enrichment errors
{-
unless (null enrichEs) $ do
@@ -578,15 +647,20 @@
hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand
where lsem = isemantics l
missedLex = filter (not.hasTree) lexCand
- unless (null missedSem) $
- ePutStrLn $ "WARNING: no lexical selection for " ++ showSem missedSem
- unless (null missedLex) $
- ePutStrLn $ "WARNING: '" ++ (concat $ intersperse ", " $ map showLex missedLex)
- ++ "' were lexically selected, but are not anchored to"
- ++ " any trees"
+ 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]
@@ -682,10 +756,9 @@
strMsg s = BoringError s
instance Show LexCombineError where
- show (BoringError s) = "Warning: " ++ s
- show (OtherError t l s) =
- "Warning: " ++ s ++ " on " ++ (pidname t) ++ "-" ++ (pfamily t) ++ " (" ++ (showLexeme $ iword l) ++ ")"
- show (EnrichError t l _) = show (OtherError t l "enrichment error")
+ 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
@@ -775,11 +848,18 @@
return (l,e2)
\end{code}
-\subsubsection{CGM Enrichement}
+\subsubsection{Enrichment}
-Enrichment is a concept introduced by the common grammar manifesto
-\cite{kow05CGM}, the idea being that during lexical selection, you sometimes
-want to add feature structures to specific nodes in a tree.
+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:
@@ -832,7 +912,7 @@
-- enrich everything else
foldM (enrichBy l) t2 namedE
where
- toAvPair ((_,_,a),v) = (a,v)
+ toAvPair ((_,_,a),v) = AvPair a v
enrichInterface tx en =
do (i2, isubs) <- unifyFeat [toAvPair en] (pinterface tx)
`catchError` (\_ -> throwError $ ifaceEnrichErr en)
@@ -851,7 +931,7 @@
Nothing -> return t -- to be robust, we accept if the node isn't there
Just a ->
do let tfeat = (if eqTop then gup else gdown) a
- (newfeat, sub) <- unifyFeat [(eqAtt,eqVal)] tfeat
+ (newfeat, sub) <- unifyFeat [AvPair eqAtt eqVal] tfeat
`catchError` (\_ -> throwError enrichErr)
let newnode = if eqTop then a {gup = newfeat}
else a {gdown = newfeat}
@@ -869,7 +949,7 @@
missingCoanchors :: ILexEntry -> MTtree -> [String]
missingCoanchors lexEntry t =
-- list monad
- do eq <- nubBy (equating pathEqName) $ snd $ lexEquations lexEntry
+ do eq <- nubBy ((==) `on` pathEqName) $ snd $ lexEquations lexEntry
let name = pathEqName eq
case seekCoanchor name t of
Nothing -> [name]
@@ -879,8 +959,14 @@
-- or (co-)anchor modifiers
lexEquations :: ILexEntry -> ([PathEqPair], [PathEqPair])
lexEquations =
- partition (nameIs "interface") . map (first parsePathEq) . iequations
- where nameIs n x = pathEqName x == n
+ 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 =
@@ -896,25 +982,25 @@
matchNodeName n = (== n) . gnname
-- | Parse a path equation using the GenI conventions
-parsePathEq :: String -> PathEqLhs
+-- 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) -> (n, True, rejoin r)
- (n:"bot":r) -> (n, False, rejoin r)
- ("top":r) -> ("anchor", True, rejoin r)
- ("bot":r) -> ("anchor", False, rejoin r)
- ("anc":r) -> parsePathEq $ rejoin $ "anchor":r
- ("anchor":r) -> ("anchor", False, rejoin r)
- ("interface":r) -> ("interface", False, rejoin r)
- (n:r) -> unsafePerformIO $ do
- ePutStrLn $ "Warning: Interpreting path equation " ++ e ++
+ 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 ++ "."
- return (n, True, rejoin r)
- _ -> unsafePerformIO $ do
- ePutStrLn $ "Warning: could not interpret path equation " ++ e
- return ("", True, e) -- unknown
+ _ -> Left (err, ("", True, e))
+ where err = "Warning: could not interpret path equation " ++ e
where
- rejoin = concat . (intersperse ".")
+ rejoin = concat . intersperse "."
\end{code}
\subsubsection{Lemanchor mechanism}
@@ -960,7 +1046,7 @@
Just l -> l
lemAnchor :: GNode -> Maybe [String]
lemAnchor n =
- case [ v | (a,v) <- gdown n, a == _lemanchor ] of
+ case [ v | AvPair a v <- gdown n, a == _lemanchor ] of
[GConst l] -> Just l
_ -> Nothing
@@ -990,7 +1076,7 @@
\begin{code}
-- | Only used for instances of GenI where the grammar is compiled
-- directly into GenI.
-type Selector = ProgState -> IO ([TagElem],[ILexEntry])
+type Selector = ProgStateRef -> IO ([TagElem],[ILexEntry])
defaultSelector :: Selector
defaultSelector = runLexSelection
@@ -1010,20 +1096,54 @@
\end{code}
% --------------------------------------------------------------------
-\section{Morphology}
+% Boring utility code
% --------------------------------------------------------------------
+\ignore{
\begin{code}
--- | 'runMorph' inflects a list of sentences if a morphlogical generator
--- has been specified. If not, it returns the sentences as lemmas.
-runMorph :: ProgStateRef -> [[(String,Flist)]] -> IO [[String]]
-runMorph pstRef sentences =
- do pst <- readIORef pstRef
- case morphlex pst of
- Just m -> return (inflectSentencesUsingLex m sentences)
- Nothing -> case getFlagP MorphCmdFlg (pa pst) of
- Nothing -> return $ map sansMorph sentences
- Just cmd -> inflectSentencesUsingCmd cmd sentences
-\end{code}
+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
--- a/src/NLP/GenI/GeniParsers.lhs
+++ b/src/NLP/GenI/GeniParsers.lhs
@@ -15,49 +15,76 @@
% along with this program; if not, write to the Free Software
% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-\chapter{File formats (GeniParsers)}
+\chapter{File formats}
+\label{cha:formats}
\label{cha:GeniParsers}
-This chapter is a description of the file format used by GenI. You
-might also have to look at the LORIA wiki for documentation on this.
-See \url{http://wiki.loria.fr/wiki/GenI/Input_format}. If the
-descriptions here sound a little weird to you, it's likely because
-they used to be source code comments, and are being converted into
-actual documentation.
+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 suite stuff
+ -- * Test suites
geniTestSuite, geniSemanticInput, geniTestSuiteString,
geniDerivations,
toSemInputString,
- -- macros
- geniMacros,
- -- lexicons
- geniLexicon, geniMorphLexicon, geniMorphInfo,
- -- features and polarities
- geniFeats, geniPolarities,
- -- TagElem,
- geniTagElems,
- -- things used by external scripts
- geniSemantics, geniValue, geniWords, geniLanguageDef, tillEof,
+ -- * 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.Map as Map
import qualified Data.Tree as T
-import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec hiding (parseFromFile)
import Text.ParserCombinators.Parsec.Language (emptyDef)
-import Text.ParserCombinators.Parsec.Token (TokenParser,
+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"
@@ -75,102 +102,172 @@
#define BEGIN "begin"
#define END "end"
\end{code}
-}
+\end{includecodeinmanual}
-\section{Test suites}
+\subsection{Lexer}
-The test suite format consists of arbitrarily many test cases:
+For reference, we include the Parsec LanguageDef that we use to implement
+the \geni format.
+\begin{includecodeinmanual}
\begin{code}
-geniTestSuite :: Parser [TestCase]
-geniTestSuite =
- tillEof (many geniTestCase)
+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}
--- | Just the String representations of the semantics
--- in the test suite
-geniTestSuiteString :: Parser [String]
-geniTestSuiteString =
- tillEof (many geniTestCaseString)
+\section{The basics}
--- | This is only used by the script genimakesuite
-geniDerivations :: Parser [TestCaseOutput]
-geniDerivations = tillEof $ many geniOutput
+\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}
-A test case is composed of an optional test id, some semantic input
-\fnref{geniSemanticInput}, followed by any number of sentences
-and optionally followed by a list of outputs.
-The sentences can either be known good sentences (optionally preceded by the
-keyword 'sentence' -- perhaps this should be mandatory one day). The outputs
-are used directly by users. The field is useful for noting what outputs were
-actually produced, say, in a script that generates test suites from GenI
-output. This field doesn't have much use for GenI per se, just its satellite
-scripts.
+\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}
-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
+geniFeats :: Parser Flist
+geniFeats = option [] $ squares $ many geniAttVal
--- 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)
+geniAttVal :: Parser AvPair
+geniAttVal = do
+ att <- identifier "an attribute"; colon
+ val <- geniValue "a GenI value"
+ return $ AvPair att val
+\end{code}
-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)
+\subsection{Semantics}
+\label{sec:geni-semantics}
-withWhite :: Parser a -> Parser a
-withWhite p = p >>= (\a -> whiteSpace >> return a)
+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}).
-geniSentence :: Parser String
-geniSentence = optional (keyword SENTENCE) >> squares geniWords
+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}
-geniWords :: Parser String
-geniWords =
- unwords `fmap` (sepEndBy1 geniWord whiteSpace "a sentence")
+The arguments are space-delimited. Not providing a handle is
+equivalent to providing an anonymous one.
-geniWord :: Parser String
-geniWord = many1 (noneOf "[]\v\f\t\r\n ")
+\begin{SaveVerbatim}{KoweyTmp}
+ ::= "[" * "]"
+ ::= "(" * ")"
+\end{SaveVerbatim}
+\begin{center}
+\fbox{\BUseVerbatim{KoweyTmp}}
+\end{center}
--- | 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
+\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{Semantics}
+\section{Semantic inputs and test suites}
+\label{sec:geni-input-semantics}
-\fnlabel{geniSemanticInput} consists of a semantics, and optionally a
-set of index constraints.
+\subsection{Semantic input}
-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.
+The semantic input can either be provided directly in the graphical interface
+or as part of a test suite.
-Index constraints are represented as feature structures. For more
-details about them, see \fnref{detectIdxConstraints}.
+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 =
@@ -181,7 +278,7 @@
let sem2 = createHandles sem
semlitC2 = [ (s,c) | (s,c) <- zip sem2 litC, (not.null) c ]
return (createHandles sem, idxC, semlitC2)
- where
+ where
-- set all anonymous handles to some unique value
-- this is to simplify checking if a result is
-- semantically complete
@@ -189,7 +286,7 @@
createHandles = zipWith setHandle ([1..] :: [Int])
--
setHandle i (h, pred_, par) =
- let h2 = if h /= GAnon then h
+ let h2 = if h /= GAnon then h
else GConst ["genihandle" ++ (show i)]
in (h2, pred_, par)
--
@@ -232,42 +329,175 @@
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}
-A lexicon is just a whitespace seperated list of lexical entries.
-Each lexical entry is
-\begin{enumerate}
-\item A lemma
-\item The family name of things this lemma anchors to
-\item The interface to the tree. Here's the compicated bit.
- Either you provide :
+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 A list of parameters and an interface, as defined in
- \fnref{geniParams}. The interface is meant to be unified with
- the tree interface.
-\item A feature structure which is to be unifed with the tree interface.
- This is equivalent to the attribute-value pairs above; the only
- difference is that we don't do any parameters, and we use square
- brackets instead of parentheses.
-\item Optionally: a set of path equations for enrichmment.
- This feature structure can consist of
- path equations of the form node.att:val, because they will be
- unified with the entire tree and not just the tree interface. To
- force something to unify with a tree interface in XMG, you should
- supply ``interface.'' as a node name.
+\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}
-\item Optionally: a set of filters. This is to be used in conjunction
- with XMG's SelectTAG. Note that you must explicitly include
- family as an attribute, even if it's already declared in the
- lexical entry.
-\end{enumerate}
+\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 =
+geniLexicalEntry =
do lemma <- (looseIdentifier <|> stringLiteral) "a lemma"
family <- identifier "a tree family"
(pars, interface) <- option ([],[]) $ parens paramsParser
@@ -279,28 +509,157 @@
(sem,pols) <- squares geniLexSemantics
--
return emptyLE { iword = [lemma]
- , ifamname = family
+ , ifamname = family
, iparams = pars
, iinterface = sortFlist interface
, iequations = equations
, ifilters = filters
, isemantics = sem
, isempols = pols }
- where
+ 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{Trees}
+\section{Tree schemata}
-\subsection{Macros}
+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
-A macro library is basically a list of trees.
+\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
@@ -308,26 +667,13 @@
initType, auxType :: Parser Ptype
initType = do { reserved INITIAL ; return Initial }
auxType = do { reserved AUXILIARY ; return Auxiliar }
-\end{code}
-\subsection{Tree definitions}
-
-A tree definition consists of
-\begin{enumerate}
-\item a family name, followed by an optional tree id
-\item the tree parameters/interface as defined in \fnref{geniParams}
-\item (optional) a tree type specification, as parameterised through the
- \fnparam{ttypeP} argument
-\item the tree itself
-\end{enumerate}
-
-\begin{code}
geniTreeDef :: Parser MTtree
geniTreeDef =
do sourcePos <- getPosition
family <- identifier
tname <- option "" $ do { colon; identifier }
- (pars,iface) <- geniParams
+ (pars,iface) <- geniParams
theTtype <- (initType <|> auxType)
theTree <- geniTree
-- sanity checks?
@@ -358,39 +704,9 @@
, ptrace = ptrc
, psemantics = psem
}
-\end{code}
-\subsection{Tree structure}
-
-A tree is recursively defined as a node followed by an optional list of child
-nodes. If there are any child nodes, they appear between curly brackets.
-
-A node consists of
-
-\begin{enumerate}
-\item A node name
-\item (optionally) a node type (anchor, lexeme, foot, subst).
-\item (if node type is lexeme) a lexeme
-\item (optionally) an adjunction constraint
- (Notes: We only know about null adjunction constraints.
- If the node has a type, it is assumed as having
- a null adjunction constraint)
-\end{enumerate}
-
-Example of a tree:
-\begin{verbatim}
-n2 type:subst [cat:np idx:?Agent]![]
-n3[cat:vp idx:?Event]![]
-{
- n4 aconstr:noadj [cat:v idx:?Event]![]
- {
- n5 anchor
- }
-\end{verbatim}
-
-\begin{code}
geniTree :: Parser (T.Tree GNode)
-geniTree =
+geniTree =
do node <- geniNode
kids <- option [] (braces $ many geniTree)
"child nodes"
@@ -404,14 +720,14 @@
return (T.Node node kids)
geniNode :: Parser GNode
-geniNode =
- do name <- identifier
+geniNode =
+ do name <- identifier
nodeType <- option "" ( (keyword TYPE >> typeParser)
<|>
reserved ANCHOR)
lex_ <- if nodeType == LEX
- then (sepBy (stringLiteral<|>identifier) (symbol "|") "some lexemes")
- else return []
+ then (sepBy (stringLiteral<|>identifier) (symbol "|") "some lexemes")
+ else return []
constr <- case nodeType of
"" -> adjConstraintParser
ANCHOR -> adjConstraintParser
@@ -436,27 +752,21 @@
, ganchor = (nodeType == ANCHOR)
, gaconstr = constr
, gorigin = "" }
- where
+ where
typeParser = choice $ map (try.symbol) [ ANCHOR, FOOT, SUBST, LEX ]
adjConstraintParser = option False $ reserved ACONSTR_NOADJ >> return True
topbotParser =
- do top <- geniFeats "top features"
+ do top <- geniFeats "top features"
symbol "!"
bot <- geniFeats "bot features"
return (top,bot)
-\end{code}
-\subsection{TagElem}
-
-For debugging purposes, it is often useful to be able to read TagElem's
-directly. Note that this shares a lot of code with the macros above.
-Hopefully, it is reasonably refactored.
-
-FIXME: note that this is very rudimentary; we do not set id numbers,
-parse polarities. You'll have to call
-some of our helper functions if you want that functionality.
-
-\begin{code}
+-- | 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
@@ -475,43 +785,25 @@
, ttype = theType
, ttree = theTree
, tsemantics = sem }
-\end{code}
-\section{Polarities}
-
-The polarities parser is used for parsing extra polarity input from the
-user. For more information, see chapter \ref{cha:Polarity}.
-
-\begin{code}
-geniPolarities :: Parser (Map.Map String Interval)
-geniPolarities = tillEof $ toMap `fmap` many pol
- where
- toMap = Map.fromListWith (!+!)
- pol = do p <- geniPolarity
- i <- identifier
- return (i,ival p)
-\end{code}
-
-\fnlabel{geniPolarity} associates a numerical value to a polarity symbol,
- that is, '+' or '-'.
-
-\begin{code}
-geniPolarity :: Parser Int
-geniPolarity = option 0 (plus <|> minus)
- where
- plus = do { char '+'; return 1 }
- minus = do { char '-'; return (-1) }
+-- | '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}
-GenI has two types of morphological input.
-
-\paragraph{morphinfo} A morphinfo file associates predicates with
-morphological feature structures. Each morphological entry consists of
-a predicate followed by a feature structuer. For more information, see
-chapter \ref{cha:Morphology}.
+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)]
@@ -524,53 +816,51 @@
return (pred_, feats)
\end{code}
-\paragraph{morphlexicon} A morphological lexicon is a table where each
-entry is an inflected form followed by the lemma and the feature
-structure to which it is associated. The table is whitespace-delimited.
+% ======================================================================
+% everything else
+% ======================================================================
\begin{code}
-geniMorphLexicon :: Parser [MorphLexEntry]
-geniMorphLexicon = tillEof $ many morphLexiconEntry
+-- ----------------------------------------------------------------------
+-- 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)
-morphLexiconEntry :: Parser (String, String, Flist)
-morphLexiconEntry =
- do inflected <- try stringLiteral <|> geniWord
- whiteSpace
- lemma <- try stringLiteral <|> geniWord
- whiteSpace
- feats <- geniFeats
- return (inflected, lemma, feats)
-\end{code}
+-- | '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) }
-\section{Generic GenI stuff}
+-- ----------------------------------------------------------------------
+-- keyword
+-- ----------------------------------------------------------------------
-\subsection{Lexer}
+{-# INLINE keyword #-}
+keyword :: String -> Parser String
+keyword k =
+ do let helper = try $ do { reserved k; colon; return k }
+ helper k ++ ":"
-Some preliminaries about GenI formats in general - comments start with
-\verb!%! There is also the option of using \verb'/* */' for embedded
-comments.
+{-# INLINE keywordSemantics #-}
+keywordSemantics :: Parser String
+keywordSemantics = keyword SEMANTICS
-\begin{code}
+-- ----------------------------------------------------------------------
+-- language def helpers
+-- ----------------------------------------------------------------------
+
lexer :: TokenParser ()
lexer = makeTokenParser geniLanguageDef
-geniLanguageDef :: LanguageDef ()
-geniLanguageDef = emptyDef
- { commentLine = "%"
- , commentStart = "/*"
- , commentEnd = "*/"
- , opLetter = oneOf ""
- , reservedOpNames = [""]
- , reservedNames =
- [ SEMANTICS , SENTENCE, OUTPUT, IDXCONSTRAINTS, TRACE
- , ANCHOR , SUBST , FOOT , LEX , TYPE , ACONSTR_NOADJ
- , INITIAL , AUXILIARY
- , BEGIN , END ]
- , identLetter = identStuff
- , identStart = identStuff
- }
- where identStuff = alphaNum <|> oneOf "_'+-."
-
whiteSpace :: CharParser () ()
whiteSpace = P.whiteSpace lexer
@@ -598,166 +888,22 @@
reserved, symbol :: String -> CharParser () String
reserved s = P.reserved lexer s >> return s
symbol = P.symbol lexer
-\end{code}
-\subsection{Keyword}
-
-A key is nothing simpler than the keyword, followed by a colon.
-We factor this into a seperate function to account for whitespace.
-
-\begin{code}
-{-# INLINE keyword #-}
-keyword :: String -> Parser String
-keyword k =
- do let helper = try $ do { reserved k; colon; return k }
- helper k ++ ":"
-
-{-# INLINE keywordSemantics #-}
-keywordSemantics :: Parser String
-keywordSemantics = keyword SEMANTICS
-\end{code}
-
-\subsection{Feature structures}
-
-Feature structures take the form \verb!val : att! with only
-whitespace to separate each attval pair. See \fnref{geniValue} for
-details about what the values look like.
-
-\begin{code}
-geniFeats :: Parser Flist
-geniFeats = option [] $ squares $ many geniAttVal
-
-geniAttVal :: Parser AvPair
-geniAttVal = do
- att <- identifier "an attribute"; colon
- val <- geniValue "a GenI value"
- return (att, val)
-\end{code}
-
-\fnlabel{geniParams} recognises a list of parameters optionally followed by a
-bang (\verb$!$) and a list of attribute-value pairs. This whole thing is to
-wrapped in the parens.
-
-\textbf{Note:} sometimes people prefer not to use parameters - instead they
-stick to using the interface. This is fine, but they should not forget the
-bang seperator.
-
-\begin{code}
-geniParams :: Parser ([GeniVal], Flist)
-geniParams = parens $ do
- pars <- many geniValue "some parameters"
- interface <- option [] $ do { symbol "!"; many geniAttVal }
- return (pars, interface)
-\end{code}
-
-\subsection{Semantics}
-
-A semantics is simply a list of literals. A literal can take one of two
-forms:
-\begin{verbatim}
- handle:predicate(arguments)
- predicate(arguments)
-\end{verbatim}
-
-The arguments are space-delimited. Not providing a handle is
-equivalent to providing an anonymous one.
-
-\begin{code}
-geniSemantics :: Parser Sem
-geniSemantics =
- do sem <- many (geniLiteral "a literal")
- return (sortSem sem)
-
-geniLiteral :: Parser Pred
-geniLiteral =
- do handle <- option GAnon handleParser "a handle"
- predicate <- geniValue "a predicate"
- pars <- parens (many geniValue) "some parameters"
- --
- return (handle, predicate, pars)
- where handleParser =
- try $ do { h <- geniValue ; char ':' ; return h }
-\end{code}
-
-\subsection{Lexical semantics}
-
-A lexical semantics is almost exactly the same as a regular semantics,
-except that each variable may be preceded by a polarity symbol. When
-we figure out how to automate the detection of lexical semantic
-polarities, we can start using a regular semantics again.
-
-\begin{code}
-geniLexSemantics :: Parser (Sem, [[Int]])
-geniLexSemantics =
- do litpols <- many (geniLexLiteral "a literal")
- return $ unzip litpols
-
-geniLexLiteral :: Parser (Pred, [Int])
-geniLexLiteral =
- do (handle, hpol) <- option (GAnon,0) (handleParser "a handle")
- predicate <- geniValue "a predicate"
- paramsPols <- parens (many geniPolValue) "some parameters"
- --
- let (pars, pols) = unzip paramsPols
- literal = (handle, predicate, pars)
- return (literal, hpol:pols)
- where handleParser =
- try $ do { h <- geniPolValue; colon; return h }
-
-geniPolValue :: Parser (GeniVal, Int)
-geniPolValue =
- do p <- geniPolarity
- v <- geniValue
- return (v,p)
-\end{code}
-
-
-\subsection{Miscellaneous}
-
-\fnlabel{geniValue} is recognised both in feature structures and in the
-GenI semantics.
-
-\begin{enumerate}
-\item As of geni 0.8, variables are prefixed with a question
- mark.
-\item The underscore, \verb!_!, and \verb!?_! are treated as anonymous
- variables.
-\item Atomic disjunctions are seperated with a pipe, \verb!|!. Only
- constants may be separated by atomic disjunction
-\item Anything else is just a constant
-\end{enumerate}
-
-\begin{code}
-geniValue :: Parser GeniVal
-geniValue = ((try $ anonymous) "_ or ?_")
- <|> (constants "a constant or atomic disjunction")
- <|> (variable "a variable")
- where
- question = "?"
- --
- constants :: Parser GeniVal
- constants =
- do c <- sepBy1 (looseIdentifier <|> stringLiteral) (symbol "|")
- return (GConst c)
- variable :: Parser GeniVal
- variable =
- do symbol question
- v <- identifier
- return (GVar v)
- anonymous :: Parser GeniVal
- anonymous =
- do optional $ symbol question
- symbol "_"
- return GAnon
-\end{code}
+-- ----------------------------------------------------------------------
+-- parsec helpers
+-- ----------------------------------------------------------------------
-\begin{code}
tillEof :: Parser a -> Parser a
tillEof p =
do whiteSpace
r <- p
eof
return r
-\end{code}
-
+-- 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.lhs b/src/NLP/GenI/GeniShow.lhs
--- a/src/NLP/GenI/GeniShow.lhs
+++ b/src/NLP/GenI/GeniShow.lhs
@@ -51,7 +51,7 @@
( TagElem, idname,
tsemantics, ttree, tinterface, ttype, ttreename,
)
-import NLP.GenI.Btypes (GeniVal(GConst), AvPair, Ptype(..),
+import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..), Ptype(..),
Ttree(params, pidname, pfamily, pinterface, ptype, tree, psemantics, ptrace),
GNode(..), GType(..),
SemInput, Pred,
@@ -70,7 +70,7 @@
geniShow _ = ""
instance GeniShow AvPair where
- geniShow (a,v) = a ++ ":" ++ geniShow v
+ geniShow (AvPair a v) = a ++ ":" ++ geniShow v
instance GeniShow GeniVal where
geniShow (GConst xs) = concat $ intersperse "|" xs
diff --git a/src/NLP/GenI/GeniVal.hs b/src/NLP/GenI/GeniVal.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/GeniVal.hs
@@ -0,0 +1,309 @@
+-- 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, 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"
+
+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"
+
+qc_not_empty_GConst :: GeniVal -> Bool
+qc_not_empty_GConst (GConst []) = False
+qc_not_empty_GConst _ = True
diff --git a/src/NLP/GenI/GraphvizShow.lhs b/src/NLP/GenI/GraphvizShow.lhs
--- a/src/NLP/GenI/GraphvizShow.lhs
+++ b/src/NLP/GenI/GraphvizShow.lhs
@@ -29,17 +29,19 @@
\ignore{
\begin{code}
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,
+import NLP.GenI.Btypes (GeniVal(GConst), AvPair(..),
GNode(..), GType(..), Flist,
isConst,
showSem,
)
-import NLP.GenI.General (wordsBy)
import NLP.GenI.Graphviz
( gvUnlines, gvNewline
, GraphvizShow(graphvizShowAsSubgraph, graphvizLabel, graphvizParams)
@@ -128,7 +130,7 @@
in stub ++ maybeShow_ " " extra
instance GraphvizShowString () AvPair where
- graphvizShow () (a,v) = a ++ ":" ++ (graphvizShow_ v)
+ graphvizShow () (AvPair a v) = a ++ ":" ++ graphvizShow_ v
instance GraphvizShowString () GeniVal where
graphvizShow () (GConst x) = concat $ intersperse " ! " x
@@ -160,9 +162,7 @@
getGnVal :: (GNode -> Flist) -> String -> GNode -> Maybe GeniVal
getGnVal getFeat attr gn =
- case [ av | av <- getFeat gn, fst av == attr ] of
- [] -> Nothing
- (av:_) -> Just (snd av)
+ listToMaybe [ v | AvPair a v <- getFeat gn, a == attr ]
-- | Apply fn to s if s is not null
maybeShow :: ([a] -> String) -> [a] -> String
@@ -188,15 +188,15 @@
++ (concatMap showHistNode histNodes)
++ (concatMap graphvizShowDerivation' deriv)
where showHistNode n = gvNode (gvDerivationLab n) (label n) []
- label n = case wordsBy ':' n of
+ label n = case wordsBy (== ':') n of
name:fam:tree:_ -> name ++ ":" ++ fam ++ gvNewline ++ tree
_ -> n ++ " (geni/gv ERROR)"
- histNodes = reverse $ nub $ concatMap (\ (_,c,(p,_)) -> [c,p]) deriv
+ histNodes = reverse $ nub $ concatMap (\ (DerivationStep _ c p _) -> [c,p]) deriv
\end{code}
\begin{code}
-graphvizShowDerivation' :: (Char, String, (String, String)) -> String
-graphvizShowDerivation' (substadj, child, (parent,_)) =
+graphvizShowDerivation' :: DerivationStep -> String
+graphvizShowDerivation' (DerivationStep substadj child parent _) =
gvEdge (gvDerivationLab parent) (gvDerivationLab child) "" p
where p = if substadj == 'a' then [("style","dashed")] else []
\end{code}
diff --git a/src/NLP/GenI/Gui.lhs b/src/NLP/GenI/Gui.lhs
--- a/src/NLP/GenI/Gui.lhs
+++ b/src/NLP/GenI/Gui.lhs
@@ -30,8 +30,8 @@
import qualified Data.Map as Map
import Data.IORef
-import Data.List (isPrefixOf, nub, delete, (\\), find)
-import Data.Maybe (isJust)
+import Data.List (isPrefixOf, nub, delete, findIndex)
+import Data.Maybe ( fromMaybe )
import System.Directory
import System.Exit (exitWith, ExitCode(ExitSuccess))
@@ -39,10 +39,12 @@
import qualified NLP.GenI.BuilderGui as BG
import NLP.GenI.Geni
( ProgState(..), ProgStateRef, combine, initGeni
- , loadEverything, loadTestSuite, loadTargetSemStr)
+ , lemmaSentenceString, GeniResult(..), prettyResult
+ , loadEverything, loadTestSuite, loadTargetSemStr
+ , showRealisations )
import NLP.GenI.General (boundsCheck, geniBug, trim, fst3)
-import NLP.GenI.Btypes (ILexEntry(isemantics), TestCase(..), showFlist,)
-import NLP.GenI.Tags (idname, tpolarities, tsemantics, TagElem)
+import NLP.GenI.Btypes (TestCase(..), showFlist,)
+import NLP.GenI.Tags (idname, tpolarities, TagElem)
import NLP.GenI.GeniShow (geniShow)
import NLP.GenI.Configuration
( Params(..), Instruction, hasOpt
@@ -50,29 +52,25 @@
, parseFlagWithParsec
--
, ExtraPolaritiesFlg(..)
- , IgnoreSemanticsFlg(..)
, LexiconFlg(..)
, MacrosFlg(..)
- , MaxTreesFlg(..)
, MorphCmdFlg(..)
, MorphInfoFlg(..)
, OptimisationsFlg(..)
+ , RankingConstraintsFlg(..)
, RootFeatureFlg(..)
, TestSuiteFlg(..)
- , TestCaseFlg(..)
, TestInstructionsFlg(..)
, ViewCmdFlg(..)
--
, Optimisation(..)
, BuilderType(..), mainBuilderTypes )
-import NLP.GenI.GeniParsers
+import NLP.GenI.GeniParsers hiding ( choice, label, tab )
import NLP.GenI.GuiHelper
import NLP.GenI.Polarity
import NLP.GenI.Simple.SimpleGui
-import NLP.GenI.CkyEarley.CkyGui
-
-
+import NLP.GenI.Statistics (Statistics, showFinalStats)
\end{code}
}
@@ -84,12 +82,15 @@
\end{code}
When you first start GenI, you will see this screen:
-[[FIXME:screenshot wanted]]
+\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), twiddle some optimisations and run the realiser. You
-can also opt to run the debugger instead of the realiser; see page
-\pageref{sec:gui:debugger}.
+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 ()
@@ -125,14 +126,12 @@
-- -----------------------------------------------------------------
let config = pa pst
hasSem = hasFlagP TestSuiteFlg config
- ignoreSem = hasFlagP IgnoreSemanticsFlg config
-- Target Semantics
testSuiteChoice <- choice f [ selection := 0, enabled := hasSem ]
tsTextBox <- textCtrl f [ wrap := WrapWord
, clientSize := sz 400 80
, enabled := hasSem
- , text := if ignoreSem
- then "% --ignoresemantics set" else "" ]
+ , text := "" ]
testCaseChoice <- choice f [ selection := 0
, enabled := hasSem ]
-- Box and Frame for files loaded
@@ -153,8 +152,6 @@
[ selection := case builderType config of
SimpleBuilder -> 0
SimpleOnePhaseBuilder -> 1
- CkyBuilder -> 2
- EarleyBuilder -> 3
NullBuilder -> 0 ]
set algoChoiceBox [ on select := toggleAlgo pstRef algoChoiceBox ]
polChk <- optCheckBox Polarised pstRef f
@@ -165,6 +162,10 @@
[ 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"
@@ -173,10 +174,6 @@
[ text := "Semantic filters"
, tooltip := "(2p only) Filter away semantically incomplete structures before adjunction phase"
]
- rootfilterChk <- optCheckBox RootCatFiltered pstRef f
- [ text := "Root filters"
- , tooltip := "(2p only) Filter away non-root structures before adjunction phase"
- ]
extrapolText <- staticText f
[ text := maybe "" showLitePm $ getFlagP ExtraPolaritiesFlg config
, tooltip := "Use the following additional polarities"
@@ -209,7 +206,7 @@
[ dynamic $ row 5 [ label "Extra: ", widget extrapolText ] ] ]
, dynamic $ widget useSemConstraintsChk
, dynamic $ widget semfilterChk
- , dynamic $ widget rootfilterChk
+ , dynamic $ widget earlyNaChk
, dynamic $ widget iafChk
]
set f [layout := column 5 [ gramsemBox
@@ -225,20 +222,14 @@
, clientSize := sz 525 325
, on closing := exitWith ExitSuccess
]
-\end{code}
-\subsection{Configuration}
-
-Most of the optimisations are availalable as checkboxes. Note the following
-point about anti-optimisations: An anti-optimisation disables a default
-behaviour which is assumed to be ``optimisation''. But of course we don't
-want to confuse the GUI user, so we confuse the programmer instead:
-Given an anti-optimisation DisableFoo, we have a check box UseFoo. If UseFoo
-is checked, we remove DisableFoo from the list; if it is unchecked, we add
-it to the list. This is the opposite of the default behaviour, but the
-result, I hope, is intuitive for the user.
-
-\begin{code}
+-- 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
@@ -282,17 +273,14 @@
modopt = if idOrNot isChecked then (o:) else delete o
newopts = nub.modopt $ getListFlagP OptimisationsFlg config
modifyIORef pstRef (\x -> x{pa = setFlagP OptimisationsFlg newopts (pa x)})
-\end{code}
-% --------------------------------------------------------------------
-\section{Loading files}
-% --------------------------------------------------------------------
-
-\paragraph{readConfig} is used to update the graphical interface after
-you run the \fnref{configGui}. It is also called when you first launch
-the GUI
+-- --------------------------------------------------------------------
+-- Loading files
+-- --------------------------------------------------------------------
-\begin{code}
+-- | '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 =
@@ -326,21 +314,15 @@
loadTestSuiteAndRefresh :: (Textual a, Selecting b, Selection b, Items b String)
=> Window w -> ProgStateRef -> Instruction -> a -> b -> IO ()
loadTestSuiteAndRefresh f pstRef (suitePath,mcs) tsBox caseChoice =
- do modifyIORef pstRef $ \pst ->
- pst { pa = setFlagP TestSuiteFlg suitePath
- $ deleteFlagP TestCaseFlg -- shouldn't change anything
- $ pa pst }
- catch
- (loadTestSuite pstRef)
- (\e -> errorDialog f ("Error reading test suite " ++ suitePath) (show e))
+ 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
- filterCases =
- case mcs of
- Nothing -> id
- Just cs -> filter (\c -> tcName c `elem` cs)
- suiteCases = filterCases suite
+ 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)
@@ -349,11 +331,12 @@
++ (show n) ++ ". " ++ t
tcaseLabels = zipWith numfn [1..] suiteCaseNames
-- we select the first case in cases_, if available
- let fstInCases _ [] = 0
- fstInCases n (x:xs) =
- if (x == theCase) then n else fstInCases (n+1) xs
- caseSel = if null theCase then 0
- else fstInCases 0 suiteCaseNames
+ 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
----------------------------------------------------
@@ -361,11 +344,11 @@
geniShow $ toSemInputString si str
let onTestCaseChoice = do
csel <- get caseChoice selection
- if (boundsCheck csel suite)
+ if boundsCheck csel suite
then do let s = (suiteCases !! csel)
set tsBox [ text :~ (\_ -> displaySemInput s) ]
else geniBug $ "Gui: test case selector bounds check error: " ++
- show csel ++ " of " ++ show suite ++ "\n"
+ show csel ++ " of " ++ show tcaseLabels ++ "\n"
----------------------------------------------------
set caseChoice [ items := tcaseLabels
, selection := caseSel
@@ -377,18 +360,19 @@
\section{Configuration}
% --------------------------------------------------------------------
-\paragraph{configGui}\label{fn:configGui} provides a graphical interface which
-aims to be a complete substitute for the command line switches. In addition to
-the program state \fnparam{pstRef}, it takes a continuation \fnparam{loadFn}
-which tells what to do when the user closes the window.
+The 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!.
-The only thing which are not provided in this GUI are a list of optimisations
-and a test case selector (which are already handled by the main interface).
-This GUI is a standalone window with two tabbed sections. Note: one thing
-you may want to note is that we do not divide the same way between basic
-and advanced options as with the console interface.
+\begin{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
@@ -404,11 +388,9 @@
++ map hfill lst
let shortSize = sz 10 25
let longSize = sz 20 25
-\end{code}
-
-The first tab contains only the basic options:
-
-\begin{code}
+ -- -----------------------------------------------------------------
+ -- basic options tab
+ -- -----------------------------------------------------------------
pbas <- panel nb []
-- files loaded (labels)
macrosFileLabel <- staticText pbas [ text := getListFlagP MacrosFlg config ]
@@ -440,12 +422,9 @@
-- the layout for the basic stuff
let layBasic = dynamic $ container pbas $ -- boxed "Basic options" $
hfloatLeft $ dynamic $ fill $ column 4 $ map (dynamic.hfill) $ layFiles
-\end{code}
-
-The second tab contains more advanced options. Maybe we should split this
-into more tabs?
-
-\begin{code}
+ -- -----------------------------------------------------------------
+ -- advanced options tab
+ -- -----------------------------------------------------------------
padv <- panel nb []
-- XMG tools
viewCmdTxt <- entry padv
@@ -472,30 +451,16 @@
, widget morphFileBrowseBt ]
, row 3 [ label "morph command"
, (marginRight.hfill) $ widget morphCmdTxt ] ]
- -- ignore semantics
- ignoreSemChk <- checkBox padv
- [ text := "Ignore semantics"
- , tooltip := "Useful as a corpus generator"
- , checked := hasFlagP IgnoreSemanticsFlg config ]
- let maxTreesStr = maybe "" show $ getFlagP MaxTreesFlg config
- maxTreesText <- entry padv
- [ text := maxTreesStr
- , tooltip := "Limit number of elementary trees in a derived tree"
- , size := shortSize ]
- let layIgnoreSem = fakeBoxed "Ignore Semantics Mode"
- [ row 3 [ widget ignoreSemChk
- , hspace 5
- , label "max trees", rigid $ widget maxTreesText ] ]
-- put the whole darn thing together
let layAdvanced = hfloatLeft $ container padv $ column 10
- $ [ layXMG, layPolarities, layMorph, layIgnoreSem ]
-\end{code}
-
-When the user clicks on a Browse button, an open file dialogue should pop up.
-It gets its value from the file label on its left (passed in as an argument),
-and updates said label when the user has made a selection.
-
-\begin{code}
+ $ [ 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 ++ "/"
@@ -520,12 +485,9 @@
setBrowse lexiconBrowseBt lexiconFileLabel
setBrowse tsBrowseBt tsFileLabel
setBrowse morphFileBrowseBt morphFileLabel
-\end{code}
-
-Let's not forget the layout which puts the whole configGui together and the
-command that makes everything ``work'':
-
-\begin{code}
+ -- -----------------------------------------------------------------
+ -- config GUI layout
+ -- -----------------------------------------------------------------
let parsePol = parseFlagWithParsec "polarities" geniPolarities
parseRF = parseFlagWithParsec "root features" geniFeats
onLoad
@@ -541,19 +503,14 @@
morphCmdVal <- get morphCmdTxt text
morphInfoVal <- get morphFileLabel text
--
- ignoreVal <- get ignoreSemChk checked
- maxTreesVal <- get maxTreesText text
- --
let maybeSet fl fn x =
if null x then deleteFlagP fl else setFlagP fl (fn x)
maybeSetStr fl x = maybeSet fl id x
- toggleFlag fl b = if b then setFlagP fl () else deleteFlagP fl
let setConfig = id
- . (maybeSet MaxTreesFlg read maxTreesVal)
- . (toggleFlag IgnoreSemanticsFlg ignoreVal)
. (maybeSetStr MacrosFlg macrosVal)
. (maybeSetStr LexiconFlg lexconVal)
. (maybeSetStr TestSuiteFlg tsVal)
+ . (maybeSetStr TestInstructionsFlg [(tsVal,Nothing)])
. (maybeSet RootFeatureFlg parseRF rootCatVal)
. (maybeSet ExtraPolaritiesFlg parsePol extraPolVal)
. (maybeSetStr ViewCmdFlg viewVal)
@@ -579,13 +536,12 @@
\end{code}
% --------------------------------------------------------------------
-\section{Running the generator}
+\section{Generation}
% --------------------------------------------------------------------
-\paragraph{doGenerate} parses the target semantics, then calls the
-generator and displays the result in a results gui (below).
-
\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
@@ -599,8 +555,6 @@
NullBuilder -> error "No gui available for NullBuilder"
SimpleBuilder -> a simpleGui_2p
SimpleOnePhaseBuilder -> a simpleGui_1p
- CkyBuilder -> a ckyGui
- EarleyBuilder -> a earleyGui
--
let doDebugger bg = debugGui bg pstRef pauseOnLex
doResults bg = resultsGui bg pstRef
@@ -613,10 +567,14 @@
handler title err = errorDialog f title (show err)
\end{code}
-\paragraph{resultsGui} displays generation result in a window. The window
-consists of various tabs for intermediary results in lexical
-selection, derived trees, derivation trees and generation statistics.
+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 =
@@ -630,28 +588,58 @@
nb <- notebook p []
-- realisations tab
(results,stats,resTab) <- BG.resultsPnl builderGui pstRef nb
- -- statistics tab
- let sentences = (fst . unzip) results
- statTab <- statsGui nb sentences stats
+ -- 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
- -- we put the realisations tab last because of what
- -- seems to be buggy behaviour wrt to wxhaskell
- -- or wxWidgets 2.4 and the splitter
- [ tab "summary" statTab
- , tab "realisations" resTab ] ]
+ 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}
-\paragraph{debuggerGui} All GenI builders can make use of an interactive
-graphical debugger. We provide here a universal debugging interface,
-which makes use of some parameterisable bits as defined in the BuilderGui
-module. This window shows a seperate tab for each surface realisation
-task (lexical selection, filtering, building). We also rely heavily on
-helper code defined in \ref{sec:debugger_helpers}.
+\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 surfuce realisation (lexical selection, filtering, building).
+The building phase has a parameterisable GUI, which means that if you wanted to
+develop a new surface realisation algorithm for GenI, you could also extend the
+debugger GUI to go with it.
+\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
@@ -665,9 +653,7 @@
nb <- notebook p []
-- generation step 1
initStuff <- initGeni pstRef
- let (tsem,_,_) = B.inSemInput initStuff
- (cand,_) = unzip $ B.inCands initStuff
- lexonly = B.inLex initStuff
+ let (cand,_) = unzip $ B.inCands initStuff
-- continuation for candidate selection tab
let step2 newCands =
do -- generation step 2.A (run polarity stuff)
@@ -689,15 +675,9 @@
, clientSize := sz 700 600 ]
return ()
-- candidate selection tab
- let missedSem = tsem \\ (nub $ concatMap tsemantics cand)
- -- we assume that for a tree to correspond to a lexical item,
- -- it must have the same semantics
- hasTree l = isJust $ find (\t -> tsemantics t == lsem) cand
- where lsem = isemantics l
- missedLex = [ l | l <- lexonly, (not.hasTree) l ]
(canPnl,_,_) <- if pauseOnLex
- then pauseOnLexGui pst nb cand missedSem missedLex step2
- else candidateGui pst nb cand missedSem missedLex
+ then pauseOnLexGui pst nb cand step2
+ else candidateGui pst nb cand
-- basic tabs
let basicTabs = [ tab "lexical selection" canPnl ]
--
@@ -706,21 +686,19 @@
-- display all tabs if we are not told to pause on lex selection
when (not pauseOnLex) (step2 cand)
\end{code}
-
-
% --------------------------------------------------------------------
\section{Tree browser}
\label{sec:treebrowser_gui}
% --------------------------------------------------------------------
-This is a very simple semantically-separated browser for all the
-trees in the grammar. Note that we can't just reuse candidateGui's
-code because we label and sort the trees differently. Here we
-ignore the arguments in tree semantics, and we display the tree
-polarities in its label.
+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
diff --git a/src/NLP/GenI/GuiHelper.hs b/src/NLP/GenI/GuiHelper.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/GuiHelper.hs
@@ -0,0 +1,750 @@
+-- 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/GuiHelper.lhs b/src/NLP/GenI/GuiHelper.lhs
deleted file mode 100644
--- a/src/NLP/GenI/GuiHelper.lhs
+++ /dev/null
@@ -1,860 +0,0 @@
-% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
-%
-% This program is free software; you can redistribute it and/or
-% modify it under the terms of the GNU General Public License
-% as published by the Free Software Foundation; either version 2
-% of the License, or (at your option) any later version.
-%
-% This program is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with this program; if not, write to the Free Software
-% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-\chapter{GUI Helper}
-
-This module provides helper functions for building the GenI graphical
-user interface
-
-\begin{code}
-{-# LANGUAGE FlexibleContexts #-}
-module NLP.GenI.GuiHelper where
-\end{code}
-
-\ignore{
-\begin{code}
-import Graphics.UI.WX
--- import Graphics.UI.WXCore
-
-import qualified Control.Monad as Monad
-import Control.Monad.State ( execStateT, runState )
-import qualified Data.Map as Map
-
-import Data.IORef
-import Data.List (intersperse)
-import System.Directory
-import System.FilePath ((<.>),(),dropExtensions)
-import System.Process (runProcess)
-import Text.ParserCombinators.Parsec (parseFromFile)
-
-import NLP.GenI.Graphviz
-import NLP.GenI.Automaton (numStates, numTransitions)
-import NLP.GenI.Statistics (Statistics, showFinalStats)
-
-import NLP.GenI.Configuration ( getFlagP, MacrosFlg(..), ViewCmdFlg(..) )
-import NLP.GenI.GeniShow(geniShow)
-import NLP.GenI.GraphvizShow ()
-import NLP.GenI.Tags (TagItem(tgIdName), tagLeaves)
-import NLP.GenI.Geni
- ( ProgState(..), showRealisations )
-import NLP.GenI.GeniParsers ( geniTagElems )
-import NLP.GenI.General
- (geniBug, boundsCheck, dropTillIncluding, ePutStrLn)
-import NLP.GenI.Btypes
- ( showAv, showPred, showSem, showLexeme, Sem, ILexEntry(iword, ifamname), )
-import NLP.GenI.Tags
- ( idname, mapBySem, TagElem(ttrace, tinterface) )
-
-import NLP.GenI.Configuration
- ( Params(..), MetricsFlg(..), setFlagP )
-
-import qualified NLP.GenI.Builder as B
-import NLP.GenI.Builder (queryCounter, num_iterations, chart_size,
- num_comparisons)
-import NLP.GenI.Polarity (PolAut, detectPolFeatures)
-import NLP.GenI.GraphvizShowPolarity ()
-\end{code}
-}
-
-\subsection{Lexically selected items}
-
-We have a browser for the lexically selected items. We group the lexically
-selected items by the semantics they subsume, inserting along the way some
-fake trees and labels for the semantics.
-
-The arguments \fnparam{missedSem} and \fnparam{missedLex} are used to
-indicate to the user respectively if any bits of the input semantics
-have not been accounted for, or if there have been lexically selected
-items for which no tree has been found.
-
-\begin{code}
-candidateGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry]
- -> GvIO Bool (Maybe TagElem)
-candidateGui pst f xs missedSem missedLex = do
- p <- panel f []
- (tb,gvRef,updater) <- tagViewerGui pst p "lexically selected item" "candidates"
- $ sectionsBySem xs
- let warningSem = if null missedSem then ""
- else "WARNING: no lexical selection for " ++ showSem missedSem
- warningLex = if null missedLex then ""
- else "WARNING: '" ++ (concat $ intersperse ", " $ map showLex missedLex)
- ++ "' were lexically selected, but are not anchored to"
- ++ " any trees"
- where showLex l = (showLexeme $ iword l) ++ "-" ++ (ifamname l)
- --
- polFeats = "Polarity attributes detected: " ++ (unwords.detectPolFeatures) xs
- warning = unlines $ filter (not.null) [ warningSem, warningLex, polFeats ]
- -- side panel
- sidePnl <- panel p []
- ifaceLst <- singleListBox sidePnl [ tooltip := "interface for this tree (double-click me!)" ]
- traceLst <- singleListBox sidePnl [ tooltip := "trace for this tree (double-click me!)" ]
- tNoted <- textCtrl sidePnl [ wrap := WrapWord, text := "Hint: copy from below and paste into the sem:\n" ]
- let laySide = container sidePnl $ column 2
- [ label "interface"
- , fill $ widget ifaceLst
- , label "trace"
- , fill $ widget traceLst
- , label "notes"
- , fill $ widget tNoted ]
- -- handlers
- let addLine :: String -> String -> String
- addLine x y = y ++ "\n" ++ x
- --
- addToNoted w =
- do sel <- get w selection
- things <- get w items
- when (sel > 0) $ set tNoted [ text :~ addLine (things !! sel) ]
- set ifaceLst [ on doubleClick := \_ -> addToNoted ifaceLst ]
- set traceLst [ on doubleClick := \_ -> addToNoted traceLst ]
- -- updaters : what happens when the user selects an item
- let updateTrace = gvOnSelect (return ())
- (\s -> set traceLst [ items := ttrace s ])
- updateIface = gvOnSelect (return ())
- (\s -> set ifaceLst [ items := map showAv $ tinterface s ])
- Monad.unless (null xs) $ do
- addGvHandler gvRef updateTrace
- addGvHandler gvRef updateIface
- -- first time run
- gvSt <- readIORef gvRef
- updateIface gvSt
- updateTrace gvSt
- --
- let layMain = fill $ row 2 [ fill tb, vfill laySide ]
- theItems = if null warning then [ layMain ] else [ hfill (label warning) , layMain ]
- lay = fill $ container p $ column 5 theItems
- return (lay, gvRef, updater)
-
-sectionsBySem :: (TagItem t) => [t] -> [ (Maybe t, String) ]
-sectionsBySem tsem =
- let semmap = mapBySem tsem
- sem = Map.keys semmap
- --
- lookupTr k = Map.findWithDefault [] k semmap
- section k = (Nothing, header) : (map tlab $ lookupTr k)
- where header = "___" ++ showPred k ++ "___"
- tlab t = (Just t, tgIdName t)
- in concatMap section sem
-\end{code}
-
-\subsection{Polarity Automata}
-
-A browser to see the automata constructed during the polarity optimisation
-step.
-
-\begin{code}
-polarityGui :: (Window a) -> [(String,PolAut,PolAut)] -> PolAut
- -> GvIO () PolAut
-polarityGui f xs final = do
- let stats a = " (" ++ (show $ numStates a) ++ "st " ++ (show $ numTransitions a) ++ "tr)"
- aut2 (_ , a1, a2) = [ a1, a2 ]
- autLabel (fv,a1,a2) = [ fv ++ stats a1, fv ++ " pruned" ++ stats a2]
- autlist = (concatMap aut2 xs) ++ [ final ]
- labels = (concatMap autLabel xs) ++ [ "final" ++ stats final ]
- --
- gvRef <- newGvRef () labels "automata"
- setGvDrawables gvRef autlist
- graphvizGui f "polarity" gvRef
-\end{code}
-
-\paragraph{statsGui} displays the generation statistics and provides a
-handy button for saving results to a text file.
-
-\begin{code}
-statsGui :: (Window a) -> [String] -> Statistics -> IO Layout
-statsGui f sentences stats =
- do let msg = showRealisations sentences
- --
- p <- panel f []
- t <- textCtrl p [ text := msg, enabled := False ]
- statsTxt <- staticText p [ text := showFinalStats stats ]
- --
- saveBt <- button p [ text := "Save to file"
- , on command := maybeSaveAsFile f msg ]
- return $ fill $ container p $ column 1 $
- [ hfill $ label "Performance data"
- , hfill $ widget statsTxt
- , hfill $ label "Realisations"
- , fill $ widget t
- , hfloatRight $ widget saveBt ]
-\end{code}
-
-\subsection{TAG trees}
-
-Our graphical interfaces have to display a great variety of items. To
-keep things nicely factorised, we define some type classes to describe
-the things that these items may have in common.
-
-\begin{code}
--- | Any data structure which has corresponds to a TAG tree and which
--- has some notion of derivation
-class XMGDerivation a where
- getSourceTrees :: a -> [String]
-
-instance XMGDerivation TagElem where
- getSourceTrees te = [idname te]
-\end{code}
-
-\fnlabel{toSentence} almost displays a TagElem as a sentence, but only
-good enough for debugging needs. The problem is that each leaf may be
-an atomic disjunction. Our solution is just to display each choice and
-use some delimiter to seperate them. We also do not do any
-morphological processing.
-
-\begin{code}
-toSentence :: TagElem -> String
-toSentence = unwords . map squishLeaf . tagLeaves
-
-squishLeaf :: (a,([String], b)) -> String
-squishLeaf = showLexeme.fst.snd
-\end{code}
-
-\subsection{TAG viewer}
-
-A TAG viewer is a graphvizGui that lets the user toggle the display
-of TAG feature structures.
-
-\begin{code}
-tagViewerGui :: (GraphvizShow Bool t, TagItem t, XMGDerivation t)
- => ProgState -> (Window a) -> String -> String -> [(Maybe t,String)]
- -> GvIO Bool (Maybe t)
-tagViewerGui pst f tip cachedir itNlab = do
- p <- panel f []
- let (tagelems,labels) = unzip itNlab
- gvRef <- newGvRef False labels tip
- setGvDrawables gvRef tagelems
- (lay,ref,updaterFn) <- graphvizGui p cachedir gvRef
- -- button bar widgets
- detailsChk <- checkBox p [ text := "Show features"
- , checked := False ]
- viewTagLay <- viewTagWidgets p gvRef (pa pst)
- -- handlers
- let onDetailsChk =
- do isDetailed <- get detailsChk checked
- setGvParams gvRef isDetailed
- updaterFn
- set detailsChk [ on command := onDetailsChk ]
- -- pack it all in
- let cmdBar = hfill $ row 5
- [ dynamic $ widget detailsChk
- , viewTagLay ]
- lay2 = fill $ container p $ column 5 [ fill lay, cmdBar ]
- return (lay2,ref,updaterFn)
-\end{code}
-
-\subsection{XMG Metagrammar stuff}
-
-XMG trees are produced by the XMG metagrammar system
-(\url{http://sourcesup.cru.fr/xmg/}). To debug these grammars, it is useful,
-given a TAG tree, to see what its metagrammar origins are. We provide here an
-interface to Yannick Parmentier's handy visualisation tool ViewTAG.
-
-\begin{code}
-viewTagWidgets :: (GraphvizShow Bool t, TagItem t, XMGDerivation t)
- => Window a -> GraphvizRef (Maybe t) Bool -> Params
- -> IO Layout
-viewTagWidgets p gvRef config =
- do viewTagBtn <- button p [ text := "ViewTAG" ]
- viewTagCom <- choice p [ tooltip := "derivation tree" ]
- -- handlers
- let onViewTag = readIORef gvRef >>=
- gvOnSelect (return ())
- (\t -> do let derv = getSourceTrees t
- ds <- get viewTagCom selection
- if boundsCheck ds derv
- then runViewTag config (derv !! ds)
- else geniBug $ "Gui: bounds check in onViewTag"
- )
- set viewTagBtn [ on command := onViewTag ]
- -- when the user selects a tree, we want to update the list of derivations
- let updateDerivationList = gvOnSelect
- (set viewTagCom [ enabled := False ])
- (\s -> set viewTagCom [ enabled := True
- , items := getSourceTrees s
- , selection := 0] )
- addGvHandler gvRef updateDerivationList
- updateDerivationList =<< readIORef gvRef
- --
- return $ row 5 $ map dynamic [ widget viewTagCom, widget viewTagBtn ]
-
-runViewTag :: Params -> String -> IO ()
-runViewTag params drName =
- case getFlagP MacrosFlg params of
- Nothing -> ePutStrLn "Warning: No macros files specified (runViewTag)"
- Just f -> do
- -- figure out what grammar file to use
- let gramfile = dropExtensions f <.> "rec"
- treenameOnly = takeWhile (/= ':') . dropTillIncluding ':' . dropTillIncluding ':'
- -- run the viewer
- case getFlagP ViewCmdFlg params of
- Nothing -> ePutStrLn "Warning: No viewcmd specified (runViewTag)"
- Just c -> do -- run the viewer
- runProcess c [gramfile, treenameOnly drName]
- Nothing Nothing Nothing Nothing Nothing
- return ()
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Graphical debugger}
-\label{sec:debugger_helpers}
-% --------------------------------------------------------------------
-
-All GenI builders can make use of an interactive graphical debugger. In
-this section, we provide some helper code to build such a debugger.
-
-\paragraph{pauseOnLexGui} sometimes it is useful for the user to see the
-lexical selection only and either dump it to file or read replace it by
-the contents of some other file. We provide an optional wrapper around
-\fnref{candidateGui} which adds this extra functionality. The wrapper
-also includes a "Begin" button which runs your continuation on the new
-lexical selection.
-
-\begin{code}
-pauseOnLexGui :: ProgState -> (Window a) -> [TagElem] -> Sem -> [ILexEntry]
- -> ([TagElem] -> IO ()) -- ^ continuation
- -> GvIO Bool (Maybe TagElem)
-pauseOnLexGui pst f xs missedSem missedLex job = do
- p <- panel f []
- candV <- varCreate xs
- (tb, ref, updater) <- candidateGui pst p xs missedSem missedLex
- -- supplementary button bar
- let saveCmd =
- do c <- varGet candV
- let cStr = unlines $ map geniShow c
- maybeSaveAsFile f cStr
- loadCmd =
- do let filetypes = [("Any file",["*","*.*"])]
- fsel <- fileOpenDialog f False True "Choose your file..." filetypes "" ""
- case fsel of
- Nothing -> return ()
- Just file ->
- do parsed <- parseFromFile geniTagElems file
- case parsed of
- Left err -> errorDialog f "" (show err)
- Right c -> do varSet candV c
- setGvDrawables2 ref (sectionsBySem c)
- updater
- --
- saveBt <- button p [ text := "Save to file", on command := saveCmd ]
- loadBt <- button p [ text := "Load from file", on command := loadCmd ]
- nextBt <- button p [ text := "Begin" ]
- let disableW w = set w [ enabled := False ]
- set nextBt [ on command := do mapM disableW [ saveBt, loadBt, nextBt ]
- varGet candV >>= job ]
- --
- let lay = fill $ container p $ column 5
- [ fill tb, hfill (vrule 1)
- , row 0 [ row 5 [ widget saveBt, widget loadBt ]
- , hfloatRight $ widget nextBt ] ]
- return (lay, ref, updater)
-\end{code}
-
-\paragraph{debuggerTab} is potentially the most useful part of the
-debugger. It shows you the contents of chart, agenda and other
-such structures used during the actual surface realisation process.
-This may be a bit complicated to use because there is lots of extra
-stuff you need to pass in order to parameterise the whole deal.
-
-The function \fnreflite{debuggerTab} fills the parent window with the
-standard components of a graphical debugger:
-\begin{itemize}
-\item An item viewer which allows the user to select one of the items
- in the builder state.
-\item An item bar which provides some options on how to view the
- currently selected item, for example, if you want to display the
- features or not.
-\item A dashboard which lets the user do things like ``go ahead 6
- steps''.
-\end{itemize}
-
-See the API for more details.
-
-\begin{code}
-type DebuggerItemBar flg itm
- = (Panel ()) -- ^ parent panel
- -> GraphvizRef (Maybe itm) flg
- -- ^ gv ref to use
- -> GvUpdater -- ^ updaterFn
- -> IO Layout
-
--- | A generic graphical debugger widget for GenI
---
--- Besides the Builder, there are two functions you need to pass in make this
--- work:
---
--- 1. a 'stateToGv' which converts the builder state into a list of items
--- and labels the way 'graphvizGui' likes it
---
--- 2. an 'item bar' function which lets you control what bits you display
--- of a selected item (for example, if you want a detailed view or not)
--- the item bar should return a layout
---
--- Note that we don't constrain the type of item returned by the builder to
--- be the same as the type handled by your gui: that's quite normal because
--- you might want to decorate the type with some other information
-debuggerPanel :: (GraphvizShow flg itm)
- => B.Builder st itm2 Params -- ^ builder to use
- -> flg -- ^ initial value for the flag argument in GraphvizShow
- -> (st -> [(Maybe itm, String)])
- -- ^ function to convert a Builder state into lists of items
- -- and their labels, the way graphvizGui likes it
- -> (DebuggerItemBar flg itm)
- -- ^ 'itemBar' function returning a control panel configuring
- -- how you want the currently selected item in the debugger
- -- to be displayed
- -> (Window a) -- ^ parent window
- -> Params -- ^ geni params
- -> B.Input -- ^ builder input
- -> String -- ^ graphviz cache directory
- -> IO Layout
-debuggerPanel builder gvInitial stateToGv itemBar f config input cachedir =
- do let initBuilder = B.init builder
- nextStep = B.step builder
- allSteps = B.stepAll builder
- --
- let (initS, initStats) = initBuilder input config2
- config2 = setFlagP MetricsFlg (B.defaultMetricNames) config
- (theItems,labels) = unzip $ stateToGv initS
- p <- panel f []
- -- ---------------------------------------------------------
- -- item viewer: select and display an item
- -- ---------------------------------------------------------
- gvRef <- newGvRef gvInitial labels "debugger session"
- setGvDrawables gvRef theItems
- (layItemViewer,_,updaterFn) <- graphvizGui p cachedir gvRef
- -- ----------------------------------------------------------
- -- item bar: controls for how an individual item is displayed
- -- ----------------------------------------------------------
- layItemBar <- itemBar p gvRef updaterFn
- -- -------------------------------------------
- -- dashboard: controls for the debugger itself
- -- -------------------------------------------
- db <- panel p []
- restartBt <- button db [text := "Start over"]
- nextBt <- button db [text := "Step by..."]
- leapVal <- entry db [ text := "1", clientSize := sz 30 25 ]
- finishBt <- button db [text := "Leap to end"]
- statsTxt <- staticText db []
- -- dashboard commands
- let showQuery c gs = case queryCounter c gs of
- Nothing -> "???"
- Just q -> show q
- updateStatsTxt gs = set statsTxt [ text :~ (\_ -> txtStats gs) ]
- txtStats gs = "itr " ++ (showQuery num_iterations gs) ++ " "
- ++ "chart sz: " ++ (showQuery chart_size gs)
- ++ "\ncomparisons: " ++ (showQuery num_comparisons gs)
- let genStep _ (st,stats) = runState (execStateT nextStep st) stats
- let showNext s_stats =
- do leapTxt <- get leapVal text
- let leapInt :: Integer
- leapInt = read leapTxt
- (s2,stats2) = foldr genStep s_stats [1..leapInt]
- setGvDrawables2 gvRef (stateToGv s2)
- setGvSel gvRef 1
- updaterFn
- updateStatsTxt stats2
- set nextBt [ on command :~ (\_ -> showNext (s2,stats2) ) ]
- let showLast =
- do -- redo generation from scratch
- let (s2, stats2) = runState (execStateT allSteps initS) initStats
- setGvDrawables2 gvRef (stateToGv s2)
- updaterFn
- updateStatsTxt stats2
- let showReset =
- do set nextBt [ on command := showNext (initS, initStats) ]
- updateStatsTxt initStats
- setGvDrawables2 gvRef (stateToGv initS)
- setGvSel gvRef 1
- updaterFn
- -- dashboard handlers
- set finishBt [ on command := showLast ]
- set restartBt [ on command := showReset ]
- showReset
- -- dashboard layout
- let layCmdBar = hfill $ container db $ row 5
- [ widget statsTxt, hfloatRight $ row 5
- [ widget restartBt, widget nextBt
- , widget leapVal, label " step(s)"
- , widget finishBt ] ]
- -- -------------------------------------------
- -- overall layout
- -- -------------------------------------------
- return $ fill $ container p $ column 5 [ layItemViewer, layItemBar, hfill (vrule 1), layCmdBar ]
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Graphviz GUI}
-\label{sec:graphviz_gui}
-% --------------------------------------------------------------------
-
-A general-purpose GUI for displaying a list of items graphically via
-AT\&T's excellent Graphviz utility. We have a list box where we display
-all the labels the user provided. If the user selects an entry from
-this box, then the item corresponding to that label will be displayed.
-See section \ref{sec:draw_item}.
-
-\paragraph{gvRef}
-
-We use IORef as a way to keep track of the gui state and to provide you
-the possibility for modifying the contents of the GUI. The idea is that
-
-\begin{enumerate}
-\item you create a GvRef with newGvRef
-\item you call graphvizGui and get back an updater function
-\item whenever you want to modify something, you use setGvWhatever
- and call the updater function
-\item if you want to react to the selection being changed,
- you should set gvhandler
-\end{enumerate}
-
-\begin{code}
-data GraphvizOrder = GvoParams | GvoItems | GvoSel
- deriving Eq
-data GraphvizGuiSt a b =
- GvSt { gvitems :: Map.Map Int a,
- gvparams :: b,
- gvlabels :: [String],
- -- tooltip for the selection box
- gvtip :: String,
- -- handler function to call when the selection is
- -- updated (note: before displaying the object)
- gvhandler :: Maybe (GraphvizGuiSt a b -> IO ()),
- gvsel :: Int,
- gvorders :: [GraphvizOrder] }
-type GraphvizRef a b = IORef (GraphvizGuiSt a b)
-
-newGvRef :: forall a . forall b . b -> [String] -> String -> IO (GraphvizRef a b)
-newGvRef p l t =
- let st = GvSt { gvparams = p,
- gvitems = Map.empty,
- gvlabels = l,
- gvhandler = Nothing,
- gvtip = t,
- gvsel = 0,
- gvorders = [] }
- in newIORef st
-
-setGvSel :: GraphvizRef a b -> Int -> IO ()
-setGvSel gvref s =
- do let fn x = x { gvsel = s,
- gvorders = GvoSel : (gvorders x) }
- modifyIORef gvref fn
-
-setGvParams :: GraphvizRef a b -> b -> IO ()
-setGvParams gvref c =
- do let fn x = x { gvparams = c,
- gvorders = GvoParams : (gvorders x) }
- modifyIORef gvref fn
-
-modifyGvParams :: GraphvizRef a b -> (b -> b) -> IO ()
-modifyGvParams gvref fn =
- do gvSt <- readIORef gvref
- setGvParams gvref (fn $ gvparams gvSt)
-
-setGvDrawables :: GraphvizRef a b -> [a] -> IO ()
-setGvDrawables gvref it =
- do let fn x = x { gvitems = Map.fromList $ zip [0..] it,
- gvorders = GvoItems : (gvorders x) }
- modifyIORef gvref fn
-
-setGvDrawables2 :: GraphvizRef a b -> [(a,String)] -> IO ()
-setGvDrawables2 gvref itlb =
- do let (it,lb) = unzip itlb
- fn x = x { gvlabels = lb }
- modifyIORef gvref fn
- setGvDrawables gvref it
-
--- | Helper function for making selection handlers (see 'addGvHandler')
--- Note that this was designed for cases where the contents is a Maybe
-gvOnSelect :: IO () -> (a -> IO ()) -> GraphvizGuiSt (Maybe a) b -> IO ()
-gvOnSelect onNothing onJust gvSt =
- let sel = gvsel gvSt
- things = gvitems gvSt
- in case Map.lookup sel things of
- Just (Just s) -> onJust s
- _ -> onNothing
-
-setGvHandler :: GraphvizRef a b -> Maybe (GraphvizGuiSt a b -> IO ()) -> IO ()
-setGvHandler gvref mh =
- do gvSt <- readIORef gvref
- modifyIORef gvref (\x -> x { gvhandler = mh })
- case mh of
- Nothing -> return ()
- Just fn -> fn gvSt
-
--- | add a selection handler - if there already is a handler
--- this handler will be called before the new one
-addGvHandler :: GraphvizRef a b -> (GraphvizGuiSt a b -> IO ()) -> IO ()
-addGvHandler gvref h =
- do gvSt <- readIORef gvref
- let newH = case gvhandler gvSt of
- Nothing -> Just h
- Just oldH -> Just (\g -> oldH g >> h g)
- setGvHandler gvref newH
-\end{code}
-
-\paragraph{graphvizGui} returns a layout (wxhaskell container) and a
-function for updating the contents of this GUI.
-
-Arguments:
-\begin{enumerate}
-\item f - (parent window) the GUI is provided as a panel within the parent.
- Note: we use window in the WxWidget's sense, meaning it could be
- anything as simple as a another panel, or a notebook tab.
-\item glab - (gui labels) a tuple of strings (tooltip, next button text)
-\item cachedir - the cache subdirectory. We intialise this by creating a cache
- directory for images which will be generated from the results
-\item gvRef - see above
-\end{enumerate}
-
-Returns: a function for updating the GUI. FIXME: it's not entirely clear
-what the updater function is for; note that it's not the same as the
-handler function!
-
-\begin{code}
-graphvizGui :: (GraphvizShow f d) =>
- (Window a) -> String -> GraphvizRef d f -> GvIO f d
-type GvIO f d = IO (Layout, GraphvizRef d f, GvUpdater)
-type GvUpdater = IO ()
-
-graphvizGui f cachedir gvRef = do
- initGvSt <- readIORef gvRef
- -- widgets
- p <- panel f [ fullRepaintOnResize := False ]
- split <- splitterWindow p []
- (dtBitmap,sw) <- scrolledBitmap split
- rchoice <- singleListBox split [tooltip := gvtip initGvSt]
- -- set handlers
- let openFn = openImage sw dtBitmap
- -- pack it all together
- let lay = fill $ container p $ margin 1 $ fill $
- vsplit split 5 200 (widget rchoice) (widget sw)
- set p [ on closing := closeImage dtBitmap ]
- -- bind an action to rchoice
- let showItem = do createAndOpenImage cachedir p gvRef openFn
- `catch` \e -> errorDialog f "" (show e)
- ------------------------------------------------
- -- create an updater function
- ------------------------------------------------
- let updaterFn = do
- gvSt <- readIORef gvRef
- let orders = gvorders gvSt
- labels = gvlabels gvSt
- sel = gvsel gvSt
- initCacheDir cachedir
- Monad.when (GvoItems `elem` orders) $
- set rchoice [ items :~ (\_ -> labels) ]
- Monad.when (GvoSel `elem` orders) $
- set rchoice [ selection :~ (\_ -> sel) ]
- modifyIORef gvRef (\x -> x { gvorders = []})
- -- putStrLn "updaterFn called"
- showItem
- ------------------------------------------------
- -- enable the tree selector
- -- FIXME: not sure that this is correct
- ------------------------------------------------
- let selectAndShow = do
- -- putStrLn "selectAndShow called"
- sel <- get rchoice selection
- -- note: do not use setGvSel (infinite loop)
- modifyIORef gvRef (\x -> x { gvsel = sel })
- -- call the handler if there is one
- gvSt <- readIORef gvRef
- case (gvhandler gvSt) of
- Nothing -> return ()
- Just h -> h gvSt
- -- now do the update
- updaterFn
- ------------------------------------------------
- set rchoice [ on select := selectAndShow ]
- -- call the updater function for the first time
- -- setGvSel gvRef 1
- updaterFn
- -- return the layout, the gvRef, and an updater function
- -- The gvRef is to make it easier for users to muck around with the
- -- state of the gui. Here, it's trivial, but when people combine guis
- -- together, it might be easier to keep track of when returned
- return (lay, gvRef, updaterFn)
-\end{code}
-
-\subsection{Scroll bitmap}
-
-Bitmap with a scrollbar
-
-\begin{code}
-scrolledBitmap :: Window a -> IO(VarBitmap, ScrolledWindow ())
-scrolledBitmap p = do
- dtBitmap <- variable [value := Nothing]
- sw <- scrolledWindow p [scrollRate := sz 10 10, bgcolor := white,
- on paint := onPaint dtBitmap,
- fullRepaintOnResize := False ]
- return (dtBitmap, sw)
-\end{code}
-
-\subsection{Bitmap functions}
-
-The following helper functions were taken directly from the WxHaskell
-sample code.
-
-\begin{code}
-type OpenImageFn = FilePath -> IO ()
-type VarBitmap = Var (Maybe (Bitmap ()))
-
-openImage :: Window a -> VarBitmap -> OpenImageFn
-openImage sw vbitmap fname = do
- -- load the new bitmap
- bm <- bitmapCreateFromFile fname -- can fail with exception
- closeImage vbitmap
- set vbitmap [value := Just bm]
- -- reset the scrollbars
- bmsize <- get bm size
- set sw [virtualSize := bmsize]
- repaint sw
- `catch` \_ -> repaint sw
-
-closeImage :: VarBitmap -> IO ()
-closeImage vbitmap = do
- mbBitmap <- swap vbitmap value Nothing
- case mbBitmap of
- Nothing -> return ()
- Just bm -> objectDelete bm
-
-onPaint :: VarBitmap -> DC a -> b -> IO ()
-onPaint vbitmap dc _ = do
- mbBitmap <- get vbitmap value
- case mbBitmap of
- Nothing -> return ()
- Just bm -> do dcClear dc
- drawBitmap dc bm pointZero False []
-\end{code}
-
-\subsection{Drawing stuff}
-\label{sec:draw_item}
-
-\paragraph{createAndOpenImage} Attempts to draw an image
-(or retrieve it from cache) and opens it if we succeed. Otherwise, it
-does nothing at all; the creation function will display an error message
-if it fails.
-
-\begin{code}
-createAndOpenImage :: (GraphvizShow f b) =>
- FilePath -> Window a -> GraphvizRef b f -> OpenImageFn -> IO ()
-createAndOpenImage cachedir f gvref openFn = do
- let errormsg g = "The file " ++ g ++ " was not created!\n"
- ++ "Is graphviz installed?"
- r <- createImage cachedir f gvref
- case r of
- Just graphic -> do exists <- doesFileExist graphic
- if exists
- then openFn graphic
- else fail (errormsg graphic)
- Nothing -> return ()
-
--- | Creates a graphical visualisation for anything which can be displayed
--- by graphviz.
-createImage :: (GraphvizShow f b)
- => FilePath -- ^ cache directory
- -> Window a -- ^ parent window
- -> GraphvizRef b f -- ^ stuff to display
- -> IO (Maybe FilePath)
-createImage cachedir f gvref = do
- gvSt <- readIORef gvref
- -- putStrLn $ "creating image via graphviz"
- let drawables = gvitems gvSt
- sel = gvsel gvSt
- config = gvparams gvSt
- dotFile <- createDotPath cachedir (show sel)
- graphicFile <- createImagePath cachedir (show sel)
- let create x = do toGraphviz config x dotFile graphicFile
- return (Just graphicFile)
- handler err = do errorDialog f "Error calling graphviz" (show err)
- return Nothing
- exists <- doesFileExist graphicFile
- -- we only call graphviz if the image is not in the cache
- if exists
- then return (Just graphicFile)
- else case Map.lookup sel drawables of
- Nothing -> return Nothing
- Just it -> create it `catch` handler
-\end{code}
-
-\subsection{Cache directory}
-
-We create a directory to put image files in so that we can avoid regenerating
-images. If the directory already exists, we can just delete all the files
-in it.
-
-\begin{code}
-initCacheDir :: String -> IO()
-initCacheDir cachesubdir = do
- mainCacheDir <- gv_CACHEDIR
- cmainExists <- doesDirectoryExist mainCacheDir
- Monad.when (not cmainExists) $ createDirectory mainCacheDir
- --
- let cachedir = mainCacheDir cachesubdir
- cExists <- doesDirectoryExist cachedir
- if (cExists)
- then do let notdot x = (x /= "." && x /= "..")
- contents <- getDirectoryContents cachedir
- olddir <- getCurrentDirectory
- setCurrentDirectory cachedir
- mapM removeFile $ filter notdot contents
- setCurrentDirectory olddir
- return ()
- else createDirectory cachedir
-\end{code}
-
-\section{Miscellaneous}
-\label{sec:gui_misc}
-
-\begin{code}
--- | Save the given string to a file, if the user selets one via the file save
--- dialog. Otherwise, don't do anything.
-maybeSaveAsFile :: (Window a) -> String -> IO ()
-maybeSaveAsFile f msg =
- do let filetypes = [("Any file",["*","*.*"])]
- fsel <- fileSaveDialog f False True "Save to" filetypes "" ""
- case fsel of
- Nothing -> return ()
- Just file -> writeFile file msg
-
--- | A message panel for use by the Results gui panels.
-messageGui :: (Window a) -> String -> IO Layout
-messageGui f msg = do
- p <- panel f []
- -- sw <- scrolledWindow p [scrollRate := sz 10 10 ]
- t <- textCtrl p [ text := msg, enabled := False ]
- return (fill $ container p $ column 1 $ [ fill $ widget t ])
-\end{code}
-
-\begin{code}
-gv_CACHEDIR :: IO String
-gv_CACHEDIR = do
- home <- getHomeDirectory
- return $ home ".gvcache"
-
-createImagePath :: String -> String -> IO String
-createImagePath subdir name = do
- cdir <- gv_CACHEDIR
- return $ cdir subdir name <.> "png"
-
-createDotPath :: String -> String -> IO String
-createDotPath subdir name = do
- cdir <- gv_CACHEDIR
- return $ cdir subdir name <.> "dot"
-\end{code}
-
-
diff --git a/src/NLP/GenI/Morphology.lhs b/src/NLP/GenI/Morphology.lhs
--- a/src/NLP/GenI/Morphology.lhs
+++ b/src/NLP/GenI/Morphology.lhs
@@ -19,26 +19,39 @@
\label{cha:Morphology}
This module handles mostly everything to do with morphology in Geni.
-There are two basic tasks: morphological input and output.
+There are two basic tasks: morphological input and output.
GenI farms out morphology to whatever third party program you
-specify in the configuration file.
+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 where
+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, isJust)
-import Data.List (intersperse)
+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}
}
@@ -46,7 +59,7 @@
type MorphFn = Pred -> Maybe Flist
\end{code}
-\section{Input}
+\section{Morphological input}
Morphological input means attaching morphological features on trees. The
user specifies morphological input through the input semantics. Our job
@@ -125,93 +138,95 @@
in (head.fst) $ listRepNode fn filt [t]
\end{code}
-\section{Output}
+\section{Morphological realisation}
-Output (\jargon{morphological generation}) refers to the actual process
+\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 on stdin a newline delimited list
-of lemmas and features, with \verb$----$ (four hyphens) as an intersentence
-delimiter:
+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}
-le [num:sg gen:f]
-fille [num:sg]
-detester [num:sg tense:past]
-le [num:pl gen:m]
-garcon [num:pl]
----- []
-ce []
-etre []
-le [num:pl]
-garcon [num:pl]
-que []
-le [num:sg gen:f]
-fille [num:sg]
-detester [num:sg tense:past]
+[
+ [{"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}
-It must return inflected forms on stdout, \emph{sentences} delimited by
-newlines. Note also that we expect exactly one result for every input.
-Notice that the morphological generator can choose to delete
-spaces or do other orthographical tricks in between words:
+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 les garcons que la fille detestait
+[
+ ["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 shell or Perl script.
+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 :: [(String,Flist)] -> [String]
-sansMorph = singleton . unwords . (map fst)
-
-type MorphLexicon = [(String, String, Flist)]
-type UninflectedDisjunction = (String, Flist)
-
--- | Return a list of results for each sentence
-inflectSentencesUsingLex :: MorphLexicon -> [[UninflectedDisjunction]] -> [[String]]
-inflectSentencesUsingLex mlex = map (inflectSentenceUsingLex mlex)
-
-inflectSentenceUsingLex :: MorphLexicon -> [UninflectedDisjunction] -> [String]
-inflectSentenceUsingLex mlex = map unwords . mapM (inflectWordUsingLex mlex)
-
--- | Return only n matches, but note any excessive ambiguities or missing matches
-inflectWordUsingLex :: MorphLexicon -> UninflectedDisjunction -> [String]
-inflectWordUsingLex mlex (lem,fs)
- | null matches = [ lem ++ "-" ] -- no matches = lemma plus little icon
- | length matches > 2 = [ lem ++ "*" ] -- too many matches!
- | otherwise = matches
- where
- matches = [ word | (word, mLem, mFs) <- mlex, lem == mLem, isJust $ fs `unifyFeat` mFs ]
+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 -> [[UninflectedDisjunction]] -> IO [[String]]
+inflectSentencesUsingCmd :: String -> [LemmaPlusSentence] -> IO [(LemmaPlusSentence,[String])]
inflectSentencesUsingCmd morphcmd sentences =
- do -- add intersential delimiters
- let delim = [("----",[])]
- morphlst = concat (intersperse delim sentences)
- -- format the stuff as input to the inflector
- let fn (lem,fs) = lem ++ " " ++ showFlist fs
- order = unlines $ map fn morphlst
- -- run the inflector
- (toP, fromP, _, pid) <- runInteractiveCommand morphcmd
- hPutStrLn toP order
+ do -- run the inflector
+ (toP, fromP, _, _) <- runInteractiveCommand morphcmd
+ hPutStrLn toP . render . pp_value . showJSON $ sentences
hClose toP
- waitForProcess pid
-- read the inflector output back as a list of strings
- (map (singleton . trim) . lines) `fmap` hGetContents fromP
- `catch` \e -> do ePutStrLn "Error calling morphological generator"
- ePutStrLn $ show e
- return $ map sansMorph sentences
+ 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]
diff --git a/src/NLP/GenI/OptimalityTheory.lhs b/src/NLP/GenI/OptimalityTheory.lhs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/OptimalityTheory.lhs
@@ -0,0 +1,390 @@
+% 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/Polarity.lhs b/src/NLP/GenI/Polarity.lhs
--- a/src/NLP/GenI/Polarity.lhs
+++ b/src/NLP/GenI/Polarity.lhs
@@ -1,5 +1,5 @@
% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
+% 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
@@ -84,23 +84,25 @@
\begin{code}
import Data.Bits
+import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.List
-import Data.Maybe (isNothing)
+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(GAnon), fromGConst, isConst,
- Replacable(..),
+import NLP.GenI.Btypes(Pred, SemInput, Sem, Flist, AvPair(..), showAv,
+ GeniVal(..), fromGConst, isConst,
+ replace,
emptyPred, Ptype(Initial),
showFlist, showSem, sortSem,
- root, gup, gdown, gtype, GType(Subs),
- SemPols, unifyFeat, rootUpd)
+ 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}
@@ -109,28 +111,36 @@
\begin{code}
-- | intermediate auts, seed aut, final aut, potentially modified sem
type PolResult = ([AutDebug], PolAut, PolAut, Sem)
-type AutDebug = (String, PolAut, PolAut)
+type AutDebug = (PolarityKey, PolAut, PolAut)
--- | Constructs a polarity automaton from the surface realiser's input: input
--- semantics, lexical selection, extra polarities and index constraints. For
--- debugging purposes, it returns all the intermediate automata produced by
--- the construction algorithm.
-buildAutomaton :: SemInput -> [TagElem] -> Flist -> PolMap -> PolResult
-buildAutomaton (tsem,tres,_) candRaw rootFeat extrapol =
+-- | 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 String Interval
- rcatPol = Map.fromList $ polarise (-1) $ getval __cat__ rootFeat
+ 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
+ r = detect . tinterface $ t
candRest = map constrain candRaw
inputRest = declareIdxConstraints tres
-- polarity detection
- cand = detectPols candRest
+ cand = detectPols polarityAttrs candRest
-- building the automaton
in makePolAut cand tsem allExtraPols
\end{code}
@@ -171,7 +181,7 @@
makePolAut :: [TagElem] -> Sem -> PolMap -> PolResult
makePolAut candsRaw tsemRaw extraPol =
let -- polarity items
- ksCands = concatMap ((Map.keys).tpolarities) cands
+ ksCands = concatMap (Map.keys . tpolarities) cands
ksExtra = Map.keys extraPol
ks = sortBy (flip compare) $ nub $ ksCands ++ ksExtra
-- perform index counting
@@ -186,7 +196,7 @@
build k xs = (k,aut,prune aut):xs
where aut = buildPolAut k initK (thd3 $ head xs)
initK = Map.findWithDefault (ival 0) k extraPol
- res = foldr build [("(seed)",seed,prune seed)] ks
+ res = foldr build [(PolarityKey "(seed)",seed,prune seed)] ks
in (reverse res, seed, thd3 $ head res, tsem)
\end{code}
@@ -289,7 +299,7 @@
-- 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)
+ next = nub newStates : states aut
-- recursive step to the next literal
in buildSeedAut' cands ls (i+1) (newAut { states = next })
@@ -340,7 +350,7 @@
automaton that you can use when there is no ``previous automaton''.
\begin{code}
-buildPolAut :: String -> Interval -> PolAut -> PolAut
+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
@@ -364,7 +374,7 @@
automaton.
\begin{code}
-buildPolAut' :: String -> PolTransFn -> PolAut -> PolAut
+buildPolAut' :: PolarityKey -> PolTransFn -> PolAut -> PolAut
-- for each literal... (this is implicit in the automaton state grouping)
buildPolAut' fk skeleton aut =
let -- previously created candidates
@@ -372,14 +382,14 @@
-- 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)
+ next = Set.toList newStates : states aut
-- recursive step to the next literal
in if Set.null newStates
then aut
else buildPolAut' fk skeleton (newAut { states = next })
-- given a previously created state...
-buildPolAutHelper :: String -> PolTransFn -> PolState -> (PolAut,Set.Set PolState) -> (PolAut,Set.Set PolState)
+buildPolAutHelper :: 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
@@ -398,7 +408,7 @@
newSt t skel2 = PolSt pr2 ex2 (po2:skelPo2)
where
PolSt pr2 ex2 skelPo2 = skel2
- po2 = po1 !+! (Map.findWithDefault (ival 0) fk pol)
+ po2 = po1 !+! Map.findWithDefault (ival 0) fk pol
pol = case t of Nothing -> Map.empty
Just t2 -> tpolarities t2
in result
@@ -680,20 +690,20 @@
where clump ((_,is),ps) = zip is ps
-- part 3 (adding extra semantics)
indices = concatMap fn (Map.toList chargemap)
- where fn (i,c) = replicate (0-c) i
+ 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)
+ 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 []
+ comparefn i ct cm = if cm < ct then extra else []
where maxNeeded = Map.findWithDefault 0 i chargemap -- cap the number added
- extra = replicate (min (0 - maxNeeded) (ct - cm)) i
+ 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
@@ -740,7 +750,7 @@
\begin{code}
assignIndex :: GeniVal -> TagElem -> TagElem
assignIndex i te =
- let idxfs = [ (__idx__, i) ]
+ let idxfs = [ AvPair __idx__ i ]
oldt = ttree te
oldr = root oldt
tfup = gup oldr
@@ -785,16 +795,16 @@
detectIdxConstraints :: Flist -> Flist -> PolMap
detectIdxConstraints cs interface =
let matches = intersect cs interface
- matchStr = map showIdxConstraint matches
+ matchStr = map idxConstraintKey matches
in Map.fromList $ zip matchStr ((repeat.ival) 1)
declareIdxConstraints :: Flist -> PolMap
declareIdxConstraints = Map.fromList . (map declare) where
- declare c = (showIdxConstraint c, minusone)
+ declare c = (idxConstraintKey c, minusone)
minusone = ival (-1)
-showIdxConstraint :: AvPair -> String
-showIdxConstraint = ('.' :) . showAv
+idxConstraintKey :: AvPair -> PolarityKey
+idxConstraintKey = PolarityKey . ('.' :) . showAv
\end{code}
\subsection{Automatic detection}
@@ -817,7 +827,7 @@
sfeats = [ concat s | s <- map substTops tes, (not.null) s ]
--
attrs :: Flist -> [String]
- attrs avs = [ a | (a,v) <- avs, isConst v ]
+ attrs avs = [ a | AvPair a v <- avs, isConst v ]
theAttributes = map attrs $ rfeats ++ sfeats
in if null tes then [] else foldr1 intersect theAttributes
@@ -829,9 +839,9 @@
detectSansIdx :: [TagElem] -> [TagElem]
detectSansIdx =
let rfeats t = (gdown.root.ttree) t
- feats t | ttype t == Initial = concat $ (rfeats t) : (substTops t)
+ feats t | ttype t == Initial = concat $ rfeats t : substTops t
feats t = concat $ substTops t
- attrs avs = [ a | (a,v) <- avs, isConst v ]
+ 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}
@@ -859,32 +869,38 @@
time. It would be nice to have some kind of mutual exclusion working.
\begin{code}
-detectPols :: [TagElem] -> [TagElem]
-detectPols = map detectPols'
+detectPols :: Set.Set PolarityAttr -> [TagElem] -> [TagElem]
+detectPols attrs = map (detectPolsH attrs)
-detectPols' :: TagElem -> TagElem
-detectPols' te =
- let otherFeats = [] --, __idx__ ]
- feats = __cat__ : otherFeats
+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
--
- rootdown = (gdown.root.ttree) te
- rootup = (gup.root.ttree) te
- rstuff :: [[String]]
- rstuff = getval __cat__ rootup -- cat is special, see below
- ++ (concatMap (\v -> getval v rootdown) otherFeats)
- -- re:above, cat it is considered global to the whole tree
- -- to be robust, we grab it from the top feature
- substuff :: [[String]]
- substuff = concatMap (\v -> concatMap (getval v) (substTops te)) feats
+ rup = gup . root .ttree $ te
+ rdown = gdown . root . ttree $ te
--
- -- substs nodes only
- commonPols :: [ (String,Interval) ]
- commonPols = polarise (-1) substuff
+ 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 :: [ (String,Interval) ]
pols = case ttype te of
- Initial -> commonPols ++ polarise 1 rstuff
- _ -> commonPols
+ Initial -> substuff ++ rstuff
+ _ -> substuff
--
oldfm = tpolarities te
in te { tpolarities = foldr addPol oldfm pols }
@@ -893,14 +909,45 @@
__cat__ = "cat"
__idx__ = "idx"
-getval :: String -> Flist -> [[String]]
-getval att fl =
- case [ v | (a,v) <- fl, a == att ] of
- [] -> error $ "[polarities] No instances of " ++ att ++ " in " ++ showFlist fl ++ "."
- vs -> if all isConst vs
- then map (prefixWith att . fromGConst) vs
- else error $ "[polarities] Not all values for feature " ++ att ++ " are instantiated."
+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)
@@ -908,19 +955,11 @@
prefixWith :: String -> [String] -> [String]
prefixWith att = map (\x -> att ++ ('_' : x))
-polarise :: Int -> [[String]] -> [ (String, Interval) ]
-polarise i = concatMap fn
- where
- fn [x] = [ (x, one) ]
- fn amb = for amb $ \x -> (x, oneZero)
- one = ival i
- oneZero = toZero i
-
-for :: [a] -> (a -> b) -> [b]
-for = flip map
+substNodes :: TagElem -> [GNode]
+substNodes t = [ gn | gn <- (flatten.ttree) t, gtype gn == Subs ]
substTops :: TagElem -> [Flist]
-substTops t = [ gup gn | gn <- (flatten.ttree) t, gtype gn == Subs ]
+substTops = map gup . substNodes
\end{code}
\subsection{Chart sharing}
@@ -1031,11 +1070,11 @@
\begin{code}
type SemMap = Map.Map Pred [TagElem]
-type PolMap = Map.Map String Interval
+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 :: (String,Interval) -> PolMap -> PolMap
+addPol :: (PolarityKey,Interval) -> PolMap -> PolMap
addPol (p,c) m = Map.insertWith (!+!) p c m
-- | Ensures that all states and transitions in the polarity automaton
@@ -1162,6 +1201,6 @@
-- The advantage is that it displays fewer quotation marks.
showLitePm :: PolMap -> String
showLitePm pm =
- let showPair (f, pol) = showInterval pol ++ f
+ let showPair (f, pol) = showInterval pol ++ fromPolarityKey f
in concat $ intersperse " " $ map showPair $ Map.toList pm
\end{code}
diff --git a/src/NLP/GenI/PolarityTypes.hs b/src/NLP/GenI/PolarityTypes.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/PolarityTypes.hs
@@ -0,0 +1,44 @@
+-- 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/Regression.hs b/src/NLP/GenI/Regression.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/Regression.hs
@@ -0,0 +1,83 @@
+-- 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/Simple/SimpleBuilder.lhs b/src/NLP/GenI/Simple/SimpleBuilder.lhs
--- a/src/NLP/GenI/Simple/SimpleBuilder.lhs
+++ b/src/NLP/GenI/Simple/SimpleBuilder.lhs
@@ -24,8 +24,8 @@
item is a derived tree.
\begin{code}
-{-# OPTIONS_GHC -fglasgow-exts #-}
--- {-# LANGUAGE LiberalTypeSynonyms #-}
+{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans #-}
+{-# LANGUAGE LiberalTypeSynonyms, TemplateHaskell #-}
module NLP.GenI.Simple.SimpleBuilder (
-- Types
Agenda, AuxAgenda, Chart, SimpleStatus, SimpleState,
@@ -33,15 +33,14 @@
-- From SimpleStatus
simpleBuilder_1p, simpleBuilder_2p, simpleBuilder,
- theAgenda, theAuxAgenda, theChart, theResults,
+ theAgenda, theHoldingPen, theChart, theResults,
initSimpleBuilder,
addToAgenda, addToChart,
genconfig,
-
-#ifndef DISABLE_GUI
SimpleGuiItem(..),
- theTrash, unpackResult,
-#endif
+ theTrash, step,
+
+ unpackResult,
)
where
\end{code}
@@ -49,24 +48,28 @@
\ignore{
\begin{code}
-import Control.Monad (when, liftM2)
-import Control.Monad.State
+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', unfoldr, sortBy)
-import Data.Maybe (isJust, isNothing)
+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,Auxiliar)
- , Replacable(..), replaceOneAsMap
+ ( Ptype(Initial)
+ , GeniVal
+ , replace, DescendGeniVal(..)
, GNode(..), NodeName
, root, foot
, plugTree, spliceTree
@@ -78,27 +81,28 @@
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(TagSite),
+import NLP.GenI.Tags (TagElem, TagSite(..),
tagLeaves, tidnum,
ttree, ttype, tsemantics,
detectSites,
- TagDerivation,
+ TagDerivation, DerivationStep(..),
ts_rootFeatureMismatch,
)
import NLP.GenI.Configuration
import NLP.GenI.General
( BitVector, mapMaybeM, mapTree', geniBug, preTerminals, )
-#ifndef DISABLE_GUI
import NLP.GenI.Btypes ( GType(Other), sortSem, Sem, gnnameIs )
import NLP.GenI.General ( repList, )
import NLP.GenI.Tags ( idname,
ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure,
)
-#endif
+
+import Data.List ( sortBy, unfoldr )
\end{code}
}
@@ -119,7 +123,7 @@
{ B.init = initSimpleBuilder twophase
, B.step = if twophase then generateStep_2p else generateStep_1p
, B.stepAll = B.defaultStepAll (simpleBuilder twophase)
- , B.finished = \s -> (null.theAgenda) s && (not twophase || step s == Auxiliar)
+ , B.finished = \s -> (null.theAgenda) s && (not twophase || isAdjunctionPhase (step s))
, B.unpack = unpackResults.theResults
, B.partial = unpackResults.partialResults
}
@@ -133,9 +137,15 @@
type Agenda = [SimpleItem]
type AuxAgenda = [SimpleItem]
type Chart = [SimpleItem]
-#ifndef DISABLE_GUI
type Trash = [SimpleItem]
-#endif
+
+data GenerationPhase = SubstitutionPhase
+ | AdjunctionPhase
+ deriving (Show)
+
+isAdjunctionPhase :: GenerationPhase -> Bool
+isAdjunctionPhase AdjunctionPhase = True
+isAdjunctionPhase _ = False
\end{code}
\subsection{SimpleState and SimpleStatus}
@@ -160,15 +170,13 @@
data SimpleStatus = S
{ theAgenda :: Agenda
- , theAuxAgenda :: AuxAgenda
+ , theHoldingPen :: AuxAgenda
, theChart :: Chart
-#ifndef DISABLE_GUI
, theTrash :: Trash
-#endif
, theResults :: [SimpleItem]
, theIafMap :: IafMap -- for index accessibility filtering
, tsem :: BitVector
- , step :: Ptype
+ , step :: GenerationPhase
, gencounter :: Integer
, genconfig :: Params
-- we keep a SemBitMap strictly to help display the semantics
@@ -181,37 +189,38 @@
\begin{code}
addToAgenda :: SimpleItem -> SimpleState ()
-addToAgenda te = do
- modify $ \s -> s{theAgenda = te:(theAgenda s) }
+addToAgenda te =
+ modify $ \s -> s{theAgenda = te : theAgenda s }
updateAgenda :: Agenda -> SimpleState ()
-updateAgenda a = do
+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
+ let counter = gencounter s + 1
te2 = te { siId = counter }
put s{gencounter = counter,
- theAuxAgenda = te2:(theAuxAgenda s) }
+ theHoldingPen = te2 : theHoldingPen s }
addToChart :: SimpleItem -> SimpleState ()
addToChart te = do
- modify $ \s -> s { theChart = te:(theChart s) }
+ modify $ \s -> s { theChart = te:theChart s }
incrCounter chart_size 1
-#ifndef DISABLE_GUI
addToTrash :: SimpleItem -> String -> SimpleState ()
addToTrash te err = do
- let te2 = modifyGuiStuff (\g -> g { siDiagnostic = err:(siDiagnostic g) }) te
- modify $ \s -> s { theTrash = te2 : (theTrash s) }
-#endif
+ 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 = do
- modify $ \s -> s { theResults = te : (theResults s) }
+addToResults te =
+ modify $ \s -> s { theResults = te : theResults s }
\end{code}
\subsection{SimpleItem}
@@ -220,11 +229,11 @@
data SimpleItem = SimpleItem
{ siId :: ChartId
--
- , siSubstnodes :: ![TagSite]
- , siAdjnodes :: ![TagSite]
+ , siSubstnodes :: [TagSite]
+ , siAdjnodes :: [TagSite]
--
- , siSemantics :: !BitVector
- , siPolpaths :: !BitVector
+ , siSemantics :: BitVector
+ , siPolpaths :: BitVector
-- for generation sans semantics
-- , siAdjlist :: [(String,Integer)] -- (node name, auxiliary tree id)
-- for index accesibility filtering (one-phase only)
@@ -240,13 +249,24 @@
, siPendingTb :: [ TagSite ] -- only for one-phase
-- how was this item produced?
, siDerivation :: TagDerivation
-#ifndef DISABLE_GUI
-- for the debugger only
, siGuiStuff :: SimpleGuiItem
-#endif
- } deriving Show
+ } deriving (Show)
-#ifndef DISABLE_GUI
+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
@@ -255,33 +275,35 @@
, siDiagnostic :: [String]
, siFullSem :: Sem
, siIdname :: String
- } deriving Show
+ } 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 }
-#endif
type ChartId = Integer
-instance Replacable SimpleItem where
- replaceMap s i =
- i { siSubstnodes = replaceMap s (siSubstnodes i)
- , siAdjnodes = replaceMap s (siAdjnodes i)
- , siLeaves = replaceMap s (siLeaves i)
- , siRoot = replaceMap s (siRoot i)
- , siFoot = replaceMap s (siFoot i)
- , siPendingTb = replaceMap s (siPendingTb i)
-#ifndef DISABLE_GUI
- , siGuiStuff = replaceMap s (siGuiStuff i)
-#endif
+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)
}
- replaceOne = replaceOneAsMap
-#ifndef DISABLE_GUI
-instance Replacable SimpleGuiItem where
- replaceMap s i = i { siNodes = replaceMap s (siNodes i) }
- replaceOne = replaceOneAsMap
-#endif
+instance DescendGeniVal SimpleGuiItem where
+ descendGeniVal s i = i { siNodes = descendGeniVal s (siNodes i) }
\end{code}
\begin{code}
@@ -297,7 +319,7 @@
-- | True if both 'closed' and 'aux' are True
closedAux :: SimpleItem -> Bool
-closedAux x = (aux x) && (closed x)
+closedAux x = aux x && closed x
adjdone :: SimpleItem -> Bool
adjdone = null.siAdjnodes
@@ -314,7 +336,8 @@
-- | Creates an initial SimpleStatus.
initSimpleBuilder :: Bool -> B.Input -> Params -> (SimpleStatus, Statistics)
initSimpleBuilder twophase input config =
- let cands = map (initSimpleItem bmap) $ B.inCands input
+ 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
@@ -322,20 +345,18 @@
-- need an initial tb step that only addresses the
-- nodes with null adjunction constraints
simpleDp = if twophase then simpleDispatch_2p
- else simpleDispatch_1p (isIaf config)
+ else simpleDispatch_1p (hasOpt Iaf config)
initialDp = dpTbFailure >--> simpleDp
--
initS = S{ theAgenda = []
- , theAuxAgenda = []
+ , theHoldingPen = []
, theChart = []
-#ifndef DISABLE_GUI
, theTrash = []
-#endif
, theResults = []
, semBitMap = bmap
, tsem = semToBitVector bmap sem
, theIafMap = semToIafMap sem
- , step = Initial
+ , step = SubstitutionPhase
, gencounter = toInteger $ length cands
, genconfig = config }
--
@@ -343,8 +364,9 @@
runState (execStateT (mapM initialDp cands) initS) (B.initStats config)
-initSimpleItem :: SemBitMap -> (TagElem, BitVector) -> SimpleItem
-initSimpleItem bmap (teRaw,pp) =
+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
@@ -358,7 +380,7 @@
, siInaccessible = []
-- for generation sans semantics
-- , siAdjlist = []
- , siLeaves = tagLeaves te
+ , siLeaves = map (second (uncurry B.UninflectedDisjunction)) $ tagLeaves te
, siDerived = tlite
, siRoot = ncopy.root $ theTree
, siFoot = if ttype te == Initial then Nothing
@@ -367,14 +389,11 @@
-- note: see comment in initSimpleBuilder re: tb unification
, siPendingTb = nullAdjNodes
--
-#ifndef DISABLE_GUI
- , siGuiStuff = initSimpleGuiItem te
-#endif
+ , siGuiStuff = if disableGui then emptySimpleGuiItem else initSimpleGuiItem te
}
where setIaf i = i { siAccesible = iafNewAcc i }
theTree = ttree te
-#ifndef DISABLE_GUI
initSimpleGuiItem :: TagElem -> SimpleGuiItem
initSimpleGuiItem te = SimpleGuiItem
{ siHighlight = []
@@ -382,7 +401,6 @@
, siDiagnostic = []
, siFullSem = tsemantics te
, siIdname = idname te }
-#endif
renameNodesWithTidnum :: TagElem -> (TagElem, Tree NodeName)
renameNodesWithTidnum te =
@@ -408,7 +426,7 @@
generateStep_1p :: SimpleState ()
generateStep_1p =
do isDone <- gets (null.theAgenda)
- iaf <- gets (isIaf.genconfig)
+ iaf <- gets (hasOpt Iaf .genconfig)
let dispatch = mapM (simpleDispatch_1p iaf)
if isDone
then return ()
@@ -447,46 +465,38 @@
generateStep_2p = do
nir <- gets (null.theAgenda)
curStep <- gets step
- -- this check may seem redundant with generate, but it's needed
- -- to protect against a user who calls generateStep_2p on a finished
- -- state
- if (nir && curStep == Auxiliar)
- then return ()
- else do incrCounter num_iterations 1
- -- this triggers exactly once in the whole process
- if nir
- then switchToAux
- else generateStep_2p'
+ case curStep of
+ SubstitutionPhase -> if nir then switchToAux else generateStep_2p_sub
+ AdjunctionPhase -> if nir then return () else generateStep_2p_adj
-generateStep_2p' :: SimpleState ()
-generateStep_2p' =
- do -- choose an item from the agenda
+generateStep_2p_sub :: SimpleState ()
+generateStep_2p_sub =
+ do incrCounter num_iterations 1
+ -- choose an item from the agenda
given <- selectGiven
- -- have we triggered the switch to aux yet?
- curStep <- gets step
- -- do either substitution or adjunction
- res <- if (curStep == Initial)
- then applySubstitution given
- else liftM2 (++) (sansAdjunction2p given) (applyAdjunction2p given)
-
- -- determine which of the res should go in the agenda
- -- (monadic state) and which should go in the result (res')
- mapM simpleDispatch_2p res
+ res <- applySubstitution given
+ mapM_ simpleDispatch_2p res
-- put the given into the chart untouched
- if (curStep == Initial)
- then addToChart given
- else when (adjdone given) $ trashIt given
+ 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 ()
-#ifdef DISABLE_GUI
-trashIt _ = return ()
-#else
trashIt item =
- do s <- get
+ do disableGui <- gets (hasFlagP DisableGuiFlg . genconfig)
+ unless disableGui $ do
+ s <- get
let bmap = semBitMap s
itemSem = siSemantics item
inputSem = tsem s
@@ -494,7 +504,6 @@
then "unknown reason!"
else ts_semIncomplete $ bitVectorToSem bmap $ inputSem `xor` itemSem
addToTrash item reason
-#endif
-- | Arbitrarily selects and removes an element from the agenda and
-- returns it.
@@ -502,53 +511,50 @@
selectGiven = do
agenda <- gets theAgenda
case agenda of
- [] -> geniBug "null agenda in selectGiven"
+ [] -> geniBug "null agenda in selectGiven"
(a:atail) -> updateAgenda atail >> return a
\end{code}
\subsection{Switching phases}
-\fnlabel{switchToAux} When all substitutions has been done, tags with
-substitution nodes still open are deleted, then the auxiliars tags are put in
-Chart and the (initial) tags in the repository are moved into the Agenda. The
-step is then changed to Auxiliary
+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 chart = theChart st
+ 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 chart
- res1@(compT1, incompT1) =
- partition (null.siSubstnodes) initialT
+ initialT = filter siInitial (theChart st)
+ (compT1, incompT1) = partition (null.siSubstnodes) initialT
--
- auxAgenda = theAuxAgenda st
- (compT2, incompT2) =
- if semfiltered config
- then semfilter (tsem st) auxAgenda compT1
- else res1
+ (auxTrees, compT2) =
+ if hasOpt EarlyNa config
+ then ( mapMaybe (detectNa oldAuxTrees) oldAuxTrees
+ , mapMaybe (detectNa auxTrees) compT1 )
+ else ( oldAuxTrees, compT1 )
--
- compT = compT2
- put st{ theAgenda = []
- , theAuxAgenda = []
- , theChart = auxAgenda
- , step = Auxiliar}
+ (compT3, incompT3) =
+ if hasOpt SemFiltered config
+ then semfilter (tsem st) auxTrees compT2
+ else (compT2, [])
+ --
+ compT = compT3
-- the root cat filter by Claire
- let switchFilter =
- if rootcatfiltered config
- then dpRootFeatFailure2 >--> dpToAgenda
- else dpToAgenda
- mapM switchFilter compT
+ put st{ theAgenda = []
+ , theHoldingPen = []
+ , theChart = auxTrees
+ , step = AdjunctionPhase }
+ mapM_ simpleDispatch_2p_adjphase compT
-- toss the syntactically incomplete stuff in the trash
-#ifndef DISABLE_GUI
- mapM (\t -> addToTrash t ts_synIncomplete) incompT1
- mapM (\t -> addToTrash t "sem-filtered") incompT2
-#endif
- return ()
+ mapM_ (\t -> addToTrash t ts_synIncomplete) incompT1
+ mapM_ (\t -> addToTrash t "sem-filtered") incompT3
\end{code}
\subsubsection{SemFilter Optimisation}
@@ -645,17 +651,13 @@
nr = TagSite rn newU newD rOrigin
adj1 = nr : (delete r $ siAdjnodes item1)
adj2 = siAdjnodes item2
-#ifdef DISABLE_GUI
- item1g = item1
-#else
item1g = item1 { siGuiStuff = g2 }
where g2 = g { siNodes = repList (gnnameIs rn) newRoot (siNodes g) }
g = siGuiStuff item1
-- gui stuff
newRoot g = g { gup = newU, gdown = newD, gtype = Other }
-#endif
let pending = if twophase then []
- else nr : ((siPendingTb item1) ++ (siPendingTb item2))
+ else nr : (siPendingTb item1 ++ siPendingTb item2)
return $! replace subst $ combineSimpleItems [rn] item1g $
item2 { siSubstnodes = stail ++ (siSubstnodes item1)
, siAdjnodes = adj2 ++ adj1
@@ -737,20 +739,14 @@
-- do top/bottom unification on the node
case unifyFeat t b of
Nothing ->
-#ifndef DISABLE_GUI
do addToTrash (modifyGuiStuff (\g -> g { siHighlight = [gn] }) item)
ts_tbUnificationFailure
-#endif
return []
Just (tb,s) ->
let item1 = if isRootOf item gn
then item { siRoot = TagSite gn tb [] o }
else item
-#ifdef DISABLE_GUI
- item2 = item1
-#else
item2 = modifyGuiStuff (constrainAdj gn tb) item1
-#endif
in return $! [replace s $! item2 { siAdjnodes = atail }]
sansAdjunction2p _ = return []
\end{code}
@@ -783,26 +779,15 @@
iapplyAdjNode twophase aItem pItem = {-# SCC "iapplyAdjNode" #-}
case siAdjnodes pItem of
[] -> Nothing
- (TagSite an_name an_up an_down nOrigin : atail) -> do
- -- block repeated adjunctions of the same SimpleItem (for ignore semantics mode)
- -- guard $ not $ (an_name, siId aItem) `elem` (siAdjlist pItem)
+ (pSite : pTail) -> do
-- let's go!
- let r@(TagSite r_name r_up r_down rOrigin) = siRoot aItem -- auxiliary tree, eh?
- (TagSite f_name f_up f_down _) <- siFoot aItem -- should really be an error if fails
- (anr_up', subst1) <- unifyFeat r_up an_up
- (anf_down, subst2) <- unifyFeat (replace subst1 f_down) (replace subst1 an_down)
- let -- combined substitution list and success condition
- subst12 = mergeSubst subst1 subst2
- -- the result of unifying the t1 root and the t2 an
- anr = TagSite r_name (replace subst2 anr_up') r_down rOrigin
- let anf_up = replace subst12 f_up
+ (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 : (atail ++ auxlite)
- --
-#ifdef DISABLE_GUI
- aItem2 = aItem
-#else
+ 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
@@ -813,41 +798,68 @@
setSites (TagSite n u d _) gn =
if gnname gn == n then gn { gup = u, gdown = d }
else gn
-#endif
rawCombined =
- combineSimpleItems [r_name, an_name] aItem2 $ pItem
+ combineSimpleItems [tsName r, an_name] aItem2 $ pItem
{ siAdjnodes = newadjnodes
, siLeaves = siLeaves aItem ++ siLeaves pItem
- , siDerived = spliceTree f_name (siDerived aItem) an_name (siDerived pItem)
- , siDerivation = addToDerivation 'a' (aItem,rOrigin) (pItem,nOrigin,an_name)
+ , 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 (TagSite an_name anf_up anf_down nOrigin) : (siPendingTb pItem) ++ (siPendingTb aItem)
+ 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 anf_up anf_down
-#ifdef DISABLE_GUI
- let (_, subst3) = tbRes
- myRes = res'
-#else
+ tbRes <- unifyFeat (tsUp anf) (tsDown anf)
let (anf_tb, subst3) = tbRes
myRes = modifyGuiStuff (constrainAdj an_name anf_tb) res'
-#endif
-- apply the substitutions
res' = replace (mergeSubst subst12 subst3) rawCombined
return myRes
-- ---------------
if twophase then finalRes2p else finalRes1p
+
+-- 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}
% --------------------------------------------------------------------
@@ -866,35 +878,35 @@
-- * are on the some of the same polarity automaton paths as the
-- current agenda item
lookupChart :: SimpleItem -> SimpleState [SimpleItem]
-lookupChart given = do
- chart <- gets theChart
- let gpaths = siPolpaths given
- gsem = siSemantics given
- return [ i | i <- chart
- -- should be on the same polarity path (chart sharing)
- , (siPolpaths i) .&. gpaths /= 0
- -- semantics should not be overlapping
- && (siSemantics i .&. gsem ) == 0
- ]
+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)
-#ifndef DISABLE_GUI
+ item2 { siSemantics = siSemantics item1 .|. siSemantics item2
+ , siPolpaths = siPolpaths item1 .&. siPolpaths item2
, siGuiStuff = combineSimpleGuiItems hi (siGuiStuff item1) (siGuiStuff item2)
-#endif
}
-#ifndef DISABLE_GUI
combineSimpleGuiItems :: [NodeName]
-> SimpleGuiItem -> SimpleGuiItem -> SimpleGuiItem
combineSimpleGuiItems hi item1 item2 =
- item2 { siFullSem = sortSem $ (siFullSem item1) ++ (siFullSem item2)
- , siNodes = (siNodes item1) ++ (siNodes item2)
- , siDiagnostic = (siDiagnostic item1) ++ (siDiagnostic item2)
+ item2 { siFullSem = sortSem $ siFullSem item1 ++ siFullSem item2
+ , siNodes = siNodes item1 ++ siNodes item2
+ , siDiagnostic = siDiagnostic item1 ++ siDiagnostic item2
, siHighlight = hi
}
@@ -902,7 +914,6 @@
constrainAdj gn newT g =
g { siNodes = repList (gnnameIs gn) fixIt (siNodes g) }
where fixIt n = n { gup = newT, gdown = [], gaconstr = True }
-#endif
\end{code}
\subsubsection{Derivation trees}
@@ -919,7 +930,7 @@
addToDerivation op (tc,tcOrigin) (tp,tpOrigin,tpSite) =
let hp = siDerivation tp
hc = siDerivation tc
- newnode = (op, tcOrigin, (tpOrigin, tpSite))
+ newnode = DerivationStep op tcOrigin tpOrigin tpSite
in newnode:hp++hc
\end{code}
@@ -942,6 +953,11 @@
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)
@@ -957,16 +973,12 @@
condFilter isResult resFilter nonResFilter item
dpAux, dpToAgenda :: SimpleDispatchFilter
-dpTbFailure, dpRootFeatFailure, dpRootFeatFailure2, dpToResults :: SimpleDispatchFilter
+dpTbFailure, dpToResults :: SimpleDispatchFilter
dpToTrash :: String -> SimpleDispatchFilter
dpToAgenda x = addToAgenda x >> return Nothing
dpToResults x = addToResults x >> return Nothing
-#ifdef DISABLE_GUI
-dpToTrash _ _ = return Nothing
-#else
dpToTrash m x = addToTrash x m >> return Nothing
-#endif
dpAux item =
if closedAux item
@@ -994,18 +1006,14 @@
-- | If the item (ostensibly a result) does not have the correct root
-- category, return Nothing; otherwise return Just item
-dpRootFeatFailure = dpRootFeatFailure_ False
-dpRootFeatFailure2 = dpRootFeatFailure_ True
-
-dpRootFeatFailure_ :: Bool -> SimpleDispatchFilter
-dpRootFeatFailure_ count item =
+dpRootFeatFailure :: SimpleDispatchFilter
+dpRootFeatFailure item =
do config <- gets genconfig
let rootFeat = getListFlagP RootFeatureFlg config
(TagSite _ top _ _) = siRoot item
case unifyFeat rootFeat top of
Nothing ->
- do when count $ incrCounter "root_feat_discards" 1
- dpToTrash (ts_rootFeatureMismatch rootFeat) item
+ dpToTrash (ts_rootFeatureMismatch rootFeat) item
Just (_, s) ->
return . Just $ replace s item
\end{code}
@@ -1027,7 +1035,7 @@
type TbEither = Either String Subst
tbUnifyTree :: SimpleItem -> Bool
tbUnifyTree item = {-# SCC "tbUnifyTree" #-}
- case foldl tbUnifyNode (Right Map.empty) (siPendingTb item) of
+ case foldl' tbUnifyNode (Right Map.empty) (siPendingTb item) of
Left _ -> False
Right _ -> True
\end{code}
@@ -1146,7 +1154,7 @@
listToSentenceAut :: [ B.UninflectedDisjunction ] -> B.SentenceAut
listToSentenceAut nodes =
let theStart = 0
- theEnd = (length nodes) - 1
+ theEnd = length nodes - 1
theStates = [theStart..theEnd]
--
emptyAut = NFA
@@ -1158,10 +1166,10 @@
-- create a transition for each lexeme in the node to the
-- next state...
helper :: (Int, B.UninflectedDisjunction) -> B.SentenceAut -> B.SentenceAut
- helper (current, (lemmas, features)) aut =
+ helper (current, B.UninflectedDisjunction lemmas features) aut =
foldl' addT aut lemmas
where
- addT a t = addTrans a current (Just (t, features)) next
+ addT a t = addTrans a current (Just (LemmaPlus t features)) next
next = current + 1
--
in foldr helper emptyAut (zip theStates nodes)
@@ -1180,7 +1188,6 @@
\begin{code}
partialResults :: SimpleStatus -> [SimpleItem]
-#ifndef DISABLE_GUI
partialResults st = unfoldr getNext 0
where
inputsem = tsem st
@@ -1199,8 +1206,20 @@
countBits 0 = 0
countBits bs = if testBit bs 0 then 1 + next else next
where next = countBits (shiftR bs 1)
-#else
-partialResults = return []
-#endif
+\end{code}
+
+% --------------------------------------------------------------------
+% 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
--- a/src/NLP/GenI/Simple/SimpleGui.lhs
+++ b/src/NLP/GenI/Simple/SimpleGui.lhs
@@ -26,31 +26,32 @@
\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), emptyGNode, GeniVal(GConst))
+import NLP.GenI.Btypes (GNode(gnname, gup), AvPair(..), emptyGNode, GeniVal(GConst))
import NLP.GenI.Configuration ( Params(..) )
-import NLP.GenI.General ( snd3 )
import NLP.GenI.Geni ( ProgStateRef, runGeni, GeniResult )
import NLP.GenI.Graphviz ( GraphvizShow(..), gvNewline, gvUnlines )
import NLP.GenI.GuiHelper
( messageGui, tagViewerGui,
- debuggerPanel, DebuggerItemBar, setGvParams, GvIO, newGvRef,
+ debuggerPanel, DebuggerItemBar, setGvParams, GvIO, newGvRef, GraphvizGuiSt(..),
viewTagWidgets, XMGDerivation(getSourceTrees),
)
-import NLP.GenI.Tags (tsemantics, TagElem(idname, ttree), TagItem(..), emptyTE)
+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
- , theResults, theAgenda, theAuxAgenda, theChart, theTrash)
+ , step, theResults, theAgenda, theHoldingPen, theChart, theTrash)
\end{code}
}
@@ -87,14 +88,14 @@
\begin{code}
realisationsGui :: ProgStateRef -> (Window a) -> [SimpleItem]
- -> GvIO Bool (Maybe SimpleItem)
+ -> GvIO () Bool (Maybe SimpleItem)
realisationsGui _ f [] =
do m <- messageGui f "No results found"
- g <- newGvRef False [] ""
+ g <- newGvRef () False ""
return (m, g, return ())
realisationsGui pstRef f resultsRaw =
do let tip = "result"
- itNlabl = map (\t -> (Just t, siToSentence t)) resultsRaw
+ itNlabl = map (Just &&& siToSentence) resultsRaw
--
pst <- readIORef pstRef
-- FIXME: have to show the semantics again
@@ -116,7 +117,7 @@
stToGraphviz :: SimpleStatus -> [(Maybe SimpleItem, String)]
stToGraphviz st =
let agenda = section "AGENDA" $ theAgenda st
- auxAgenda = section "AUXILIARY" $ theAuxAgenda st
+ auxAgenda = section "HOLDING" $ theHoldingPen st
trash = section "TRASH" $ theTrash st
chart = section "CHART" $ theChart st
results = section "RESULTS" $ theResults st
@@ -127,9 +128,10 @@
showPaths t = " (" ++ showPolPaths t ++ ")"
in concat [ agenda, auxAgenda, chart, trash, results ]
-simpleItemBar :: Params -> DebuggerItemBar Bool SimpleItem
+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
@@ -140,12 +142,18 @@
updaterFn
set detailsChk [ on command := onDetailsChk ]
--
- return . hfloatCentre . (container ib) . row 5 $
+ 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}
% --------------------------------------------------------------------
@@ -160,7 +168,7 @@
instance XMGDerivation SimpleItem where
-- Note: this is XMG-related stuff
- getSourceTrees it = tgIdName it : (map snd3 . siDerivation $ it)
+ getSourceTrees it = tgIdName it : (map dsChild . siDerivation $ it)
\end{code}
\begin{code}
@@ -188,7 +196,7 @@
nodes = siNodes.siGuiStuff $ si
nodeMap = Map.fromList $ zip (map gnname nodes) nodes
lookupOrBug k = case Map.lookup k nodeMap of
- Nothing -> emptyGNode { gup = [ ("cat",GConst ["error looking up " ++ k]) ] }
+ Nothing -> emptyGNode { gup = [ AvPair "cat" (GConst ["error looking up " ++ k]) ] }
Just x -> x
\end{code}
@@ -196,5 +204,5 @@
siToSentence :: SimpleItem -> String
siToSentence si = case unpackResult si of
[] -> siIdname.siGuiStuff $ si
- (h:_) -> unwords . map fst . fst $ h
+ (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
@@ -30,67 +30,38 @@
USA.
-}
-module NLP.GenI.Statistics(Statistics, StatisticsState, StatisticsStateIO,
+module NLP.GenI.Statistics(Statistics, StatisticsState,
emptyStats,
- printOutAllMetrics, printOutAllMetrics', printOutInspectionMetrics,
showFinalStats,
initialStatisticsStateFor,
- addMetric, addInspectionMetric, setPrintOutInterval,
- mergeMetrics,
+ addMetric,
Metric(IntMetric), queryMetrics, updateMetrics,
- incrIntMetric, queryIntMetric, addIntMetrics,
+ incrIntMetric, queryIntMetric,
) where
import Control.Monad.State
import Data.Maybe (mapMaybe)
-import Data.List (intersperse)
+import Text.JSON
-------------------------------------------
-- Statistics are collections of Metrics
-- which can be printed out (at regular intervals)
-------------------------------------------
-data Statistics = Stat{metrics::[Metric],
- inspectionMetrics::[Metric],
- count::Int,
- step::Maybe Int}
+newtype Statistics = Stat{ metrics::[Metric] }
type StatisticsState a = forall m. (MonadState Statistics m) => m a
-type StatisticsStateIO a = forall m. (MonadState Statistics m, MonadIO m) => m a
updateMetrics :: (Metric -> Metric) -> Statistics -> Statistics
-updateMetrics f stat = stat{metrics = map f (metrics stat),
- inspectionMetrics = map f (inspectionMetrics stat)}
+updateMetrics f stat = stat{metrics = map f (metrics stat) }
queryMetrics :: (Metric -> Maybe a) -> Statistics -> [a]
-queryMetrics f stat = (mapMaybe f (metrics stat))
- ++ (mapMaybe f (inspectionMetrics stat))
-
-mergeMetrics :: (Metric -> Metric -> Metric) -> Statistics -> Statistics -> Statistics
-mergeMetrics f s1 s2 = s1 { metrics = zipWith f (metrics s1) (metrics s2)
- , inspectionMetrics = zipWith f (inspectionMetrics s1) (inspectionMetrics s2)}
-
---updateStep :: Statistics -> Statistics
---updateStep s@(Stat _ [] _ _) = s
---updateStep s@(Stat _ _ _ Nothing) = s
---updateStep stat = stat{count = (count stat)+1}
-
-needsToPrintOut :: Statistics -> Bool
-needsToPrintOut (Stat _ [] _ _) = False
-needsToPrintOut (Stat _ _ _ Nothing) = False
-needsToPrintOut (Stat _ _ iter (Just toi)) = iter > 0 && iter `mod` toi == 0
-
-noStats :: Statistics -> Bool
-noStats (Stat [] [] _ _) = True
-noStats _ = False
+queryMetrics f = mapMaybe f . metrics
emptyStats :: Statistics
-emptyStats = Stat{metrics=[],
- inspectionMetrics=[],
- count=0,
- step=Nothing}
+emptyStats = Stat []
--------------------------- Monadic Statistics functions follow ------------------------------
@@ -98,53 +69,13 @@
initialStatisticsStateFor :: (MonadState Statistics m) => (m a -> Statistics -> b) -> m a -> b
initialStatisticsStateFor f = flip f emptyStats
-{- | Adds a metric at the end of the list (thus,
- metrics are printed out in the order in which they were added -}
+-- | Adds a metric at the beginning of the list
+-- (note we reverse the order whene we want to print the metrics)
addMetric :: Metric -> StatisticsState ()
-addMetric newMetric = modify (\stat -> stat{metrics = (metrics stat)++[newMetric]})
-
-{- | Adds a metric that will be printed out at regular intervals -}
-addInspectionMetric :: Metric -> StatisticsState ()
-addInspectionMetric newMetric = modify (\stat -> stat{inspectionMetrics = (inspectionMetrics stat)++[newMetric]})
-
-setPrintOutInterval :: Int -> StatisticsState ()
-setPrintOutInterval i = modify (resetInterval i)
- where resetInterval 0 stat = stat{step = Nothing}
- resetInterval x stat = stat{step = Just x}
-
-printOutAllMetrics :: StatisticsStateIO ()
-printOutAllMetrics = get >>= (liftIO . printOutAllMetrics')
-
-printOutAllMetrics' :: Statistics -> IO ()
-printOutAllMetrics' stats =
- do
- unless (noStats stats) $ do
- liftIO $ putStrLn "(final statistics)"
- liftIO $ printOutList (inspectionMetrics stats ++ metrics stats)
-
-printOutInspectionMetrics :: StatisticsStateIO ()
-printOutInspectionMetrics = do
- shouldPrint <- gets needsToPrintOut
- when ( shouldPrint ) $ do
- liftIO $ putStr "(partial statistics: iteration "
- iter <- gets count
- liftIO . putStr . show $ iter
- liftIO $ putStrLn ")"
- ims <- gets inspectionMetrics
- liftIO $ printOutList ims
-
-
-printOutList :: Show a => [a] -> IO ()
-printOutList ms = unless ( null ms ) $ do
- let separator = "\n----------------------------------\n"
- putStr "begin"
- putStr separator
- putStr $ concat $ intersperse separator $ map show ms
- putStr separator
- putStr "end\n"
+addMetric newMetric = modify (\stat -> stat{metrics = newMetric : metrics stat } )
showFinalStats :: Statistics -> String
-showFinalStats stats = unlines $ map show $ metrics stats
+showFinalStats = unlines . map show . reverse . metrics
--------------------------------------------
-- Metrics
@@ -152,7 +83,7 @@
data Metric = IntMetric String Int
instance Show Metric where
- show (IntMetric s x) = s ++ " : " ++ (show x)
+ show (IntMetric s x) = s ++ " : " ++ show x
incrIntMetric :: String -> Int -> Metric -> Metric
incrIntMetric key i (IntMetric s c) | s == key = IntMetric s (c+i)
@@ -162,10 +93,13 @@
queryIntMetric key (IntMetric s c) | s == key = Just c
queryIntMetric _ _ = Nothing
-addIntMetrics :: Metric -> Metric -> Metric
-addIntMetrics (IntMetric s1 c1) (IntMetric s2 c2) | s1 == s2 = IntMetric s1 (c1 + c2)
-addIntMetrics s1 _ = s1
+--------------------------- JSON Output ------------------------------
--- ratio :: Int -> Int -> Float
--- ratio x y = (fromIntegral x) / (fromIntegral y)
+instance JSON Statistics where
+ readJSON _j =
+ error "can't read GenI statistics from JSON yet; sorry"
+ showJSON = JSObject . toJSObject . map metricToJSON . metrics
+-- not quite showJSON here
+metricToJSON :: Metric -> (String, JSValue)
+metricToJSON (IntMetric s i) = (s, showJSON i)
diff --git a/src/NLP/GenI/SysGeni.hs b/src/NLP/GenI/SysGeni.hs
new file mode 100644
--- /dev/null
+++ b/src/NLP/GenI/SysGeni.hs
@@ -0,0 +1,77 @@
+-- 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/SysGeni.lhs b/src/NLP/GenI/SysGeni.lhs
deleted file mode 100644
--- a/src/NLP/GenI/SysGeni.lhs
+++ /dev/null
@@ -1,93 +0,0 @@
-% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
-%
-% This program is free software; you can redistribute it and/or
-% modify it under the terms of the GNU General Public License
-% as published by the Free Software Foundation; either version 2
-% of the License, or (at your option) any later version.
-%
-% This program is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with this program; if not, write to the Free Software
-% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-\chapter{SysGeni}
-
-The SysGeni module mainly exists for running GenI as an application bundle
-under MacOS X. We mostly re-export stuff from System.Process, but if we
-are in a MacOS X application bundle, then we add \verb!../Resources/bin!
-to the path for all the random crap that we ship with with GenI.
-
-\begin{code}
-{-# LANGUAGE ForeignFunctionInterface #-}
-module NLP.GenI.SysGeni
-where
-\end{code}
-
-\ignore{
-\begin{code}
-import qualified System.Process as S
-
-import Data.List (isSuffixOf)
-import System.FilePath
-import System.IO (Handle)
-import System.Exit (ExitCode)
-
-#ifdef __GLASGOW_HASKELL__
-import Foreign
-import Foreign.C
-import Control.Monad
-#include "ghcconfig.h"
-#endif
-\end{code}
-}
-
-\section{Running a process}
-
-\begin{code}
-waitForProcess :: S.ProcessHandle -> IO ExitCode
-waitForProcess = S.waitForProcess
-\end{code}
-
-But one thing special we need to do for Macs is to detect if we're
-running from an application bundle. If we are, we assume that any
-processes we want to run are in \texttt{../Resources/bin}.
-
-\begin{code}
-runInteractiveProcess :: String -> [String]
- -> Maybe FilePath
- -> Maybe [(String, String)]
- -> IO (Handle, Handle, Handle, S.ProcessHandle)
-runInteractiveProcess cmd args x y = do
- dirname <- getProgDirName
- -- detect if we're in an .app bundle, i.e. if
- -- we are running from something.app/Contents/MacOS
- let appBundle = ".app/Contents/MacOS/"
- resBinCmd = "../Resources/bin" cmd
- -- if we're in an .app bundle, we should prefix the
- -- path with ../Resources/bin
- let cmd2 = if appBundle `isSuffixOf` dirname
- then resBinCmd else cmd
- S.runInteractiveProcess cmd2 args x y
-\end{code}
-
-\paragraph{Process helpers}
-
-\begin{code}
-foreign import ccall unsafe "getProgArgv"
- getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
-
-getProgDirName :: IO String
-getProgDirName =
- alloca $ \ p_argc ->
- alloca $ \ p_argv -> do
- getProgArgv p_argc p_argv
- argv <- peek p_argv
- s <- peekElemOff argv 0 >>= peekCString
- return $ takeDirectory s
-\end{code}
-
diff --git a/src/NLP/GenI/Tags.lhs b/src/NLP/GenI/Tags.lhs
--- a/src/NLP/GenI/Tags.lhs
+++ b/src/NLP/GenI/Tags.lhs
@@ -24,10 +24,12 @@
and \ref{sec:adjunction} instead.
\begin{code}
+{-# LANGUAGE TemplateHaskell #-}
+
module NLP.GenI.Tags(
-- Main Datatypes
Tags, TagElem(..), TagItem(..), TagSite(..),
- TagDerivation, emptyTE,
+ TagDerivation, DerivationStep(..), emptyTE,
ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure,
ts_rootFeatureMismatch,
@@ -45,22 +47,29 @@
\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),
+ GeniVal(GConst), AvPair(..),
GNode(gup, glexeme, gnname, gaconstr, gdown, gtype, gorigin),
GType(Subs), Flist,
- Replacable(..), replaceOneAsMap,
+ DescendGeniVal(..),
Collectable(..), Idable(..),
Sem, Pred, emptyPred,
emptyGNode,
showFlist, showPairs, showSem, lexemeAttributes,
)
import NLP.GenI.General (groupByFM, preTerminals)
+import NLP.GenI.PolarityTypes (PolarityKey(..))
\end{code}
}
@@ -89,28 +98,42 @@
combining macros with lexicon (see section \ref{sec:combine_macros}).
\begin{code}
-data TagSite = TagSite { tsName :: !String
- , tsUp :: !Flist
- , tsDown :: !Flist
- , tsOrigin :: !String
+data TagSite = TagSite { tsName :: String
+ , tsUp :: Flist
+ , tsDown :: Flist
+ , tsOrigin :: String
}
- deriving (Show, Eq, Ord)
+ 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,
+ ttype :: Ptype,
ttree :: Tree GNode,
tsemantics :: Sem,
-- optimisation stuff
-- (polarity key to charge interval)
- tpolarities :: Map.Map String (Int,Int),
+ tpolarities :: Map.Map PolarityKey (Int,Int),
tinterface :: Flist, -- for idxconstraints (pol)
ttrace :: [String],
tsempols :: [SemPols]
}
- deriving (Show, Eq)
+ 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
@@ -118,7 +141,30 @@
the name of the parent tree and the node affected.
\begin{code}
-type TagDerivation = [ (Char, String, (String, String)) ]
+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}
@@ -132,16 +178,14 @@
_ -> error "TagElem compare not exhaustively defined"
where compareId = compare (tidnum t1) (tidnum t2)
-instance Replacable TagElem where
- replaceMap s te =
- te { tinterface = replaceMap s (tinterface te)
- , ttree = replaceMap s (ttree te)
- , tsemantics = replaceMap s (tsemantics te) }
- replaceOne = replaceOneAsMap
+instance DescendGeniVal TagElem where
+ descendGeniVal s te =
+ te { tinterface = descendGeniVal s (tinterface te)
+ , ttree = descendGeniVal s (ttree te)
+ , tsemantics = descendGeniVal s (tsemantics te) }
-instance Replacable TagSite where
- replaceMap s (TagSite n fu fd o) = TagSite n (replaceMap s fu) (replaceMap s fd) o
- replaceOne s (TagSite n fu fd o) = TagSite n (replaceOne s fu) (replaceOne s fd) o
+instance 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)
@@ -288,7 +332,7 @@
lexs -> lexs
where
grab la =
- let match (a, (GConst v)) | a == la = Just v
+ let match (AvPair a (GConst v)) | a == la = Just v
match _ = Nothing
in firstMaybe match guppy
guppy = gup node
@@ -330,3 +374,7 @@
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
--- a/src/NLP/GenI/Test.hs
+++ b/src/NLP/GenI/Test.hs
@@ -17,20 +17,15 @@
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-- ----------------------------------------------------------------------
--- TODO: use somebody else's test framework... do not let this grow into a
--- custom monstrosity.
-
module NLP.GenI.Test where
-import Test.QuickCheck ( quickCheck )
-import NLP.GenI.Btypes
+import System.Environment ( getArgs )
+import Test.Framework
+import NLP.GenI.GeniVal ( testSuite )
runTests :: IO ()
runTests =
- do putStrLn $ header "unification"
- putStrLn "unification is symmetrical" >> quickCheck prop_unify_sym
- putStrLn "everything unifies with underscore" >> quickCheck prop_unify_anon
- putStrLn "everything unifies with itself" >> quickCheck prop_unify_self
- where
- bar = replicate 72 '='
- header x = unlines [bar,x,bar]
+ do args <- filter (/= "--unit-tests") `fmap` getArgs
+ flip defaultMainWithArgs args
+ [ NLP.GenI.GeniVal.testSuite
+ ]
diff --git a/src/NLP/GenI/unused/Predictors.lhs b/src/NLP/GenI/unused/Predictors.lhs
deleted file mode 100644
--- a/src/NLP/GenI/unused/Predictors.lhs
+++ /dev/null
@@ -1,315 +0,0 @@
-% GenI surface realiser
-% Copyright (C) 2005 Carlos Areces and Eric Kow
-%
-% This program is free software; you can redistribute it and/or
-% modify it under the terms of the GNU General Public License
-% as published by the Free Software Foundation; either version 2
-% of the License, or (at your option) any later version.
-%
-% This program is distributed in the hope that it will be useful,
-% but WITHOUT ANY WARRANTY; without even the implied warranty of
-% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-% GNU General Public License for more details.
-%
-% You should have received a copy of the GNU General Public License
-% along with this program; if not, write to the Free Software
-% Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-\chapter{Predictor Optimisation}
-
-One optimisation is to annotate the macros with a set of
-\jargon{predictors}. This allows macros to predict that they will
-combine with certain (usually) null-semantic trees. For example, a
-common noun would predict that it needs a determiner.
-
-\begin{code}
-module Predictors
-where
-\end{code}
-
-\begin{code}
-import Debug.Trace
-import qualified Data.Map as Map
-import Data.List (nub, sortBy, groupBy, intersect)
-import Monad (when, ap, foldM)
-import MonadState (get, put)
-
-import Bfuncs (Sem, Flist, AvPair, showSem, showAv, isVar)
-import Tags (TagElem(TE), emptyTE, idname, tsemantics, substnodes,
- derivation, tpredictors, drawTagTrees)
-import Configuration (defaultParams)
-import Mstate (MS, Gstats, initGstats, addGstats, initMState,
- runState, genstats,
- incrNumcompar, incrSzchart, incrGeniter,
- renameTagElem,
- addToInitRep,
- getGenRep, lookupGenRep, genRepToList, addListToGenRep,
- iapplySubstNode,
- nullInitRep, getInitRep, genrep, getSem, selectGiven)
-
-import Polarity (showLite)
-\end{code}
-
-% ----------------------------------------------------------------------
-\section{Optimisation}
-% ----------------------------------------------------------------------
-
-We attempt substitution between macro and any predictors that it has.
-Whenever we succeed, we can pass the combined tree as a candidate.
-Whenever we fail, we have to pass both the macro and its predictors.
-This is basically an indirect means of adding some kind of indexing to
-the generator's chart.
-
-Note: there are actually two cases here. For those predictors that
-we can substitute into the macro, we return the resulting tree and
-discard the predictor.
-
-\begin{code}
-optimisePredictors :: [[TagElem]] -> PredictorMap -> ([[TagElem]], Gstats)
-optimisePredictors cands predictmap =
- let trees = nub $ concat cands
- -- calculate predicted trees
- sumup = foldr addGstats initGstats
- optTree t = optimisePredictors' predictmap t
- optPath p = (r, sumup s)
- where (r,s) = unzip $ map optTree p
- (res, stats) = optPath trees
- treemap = Map.fromList $ zip trees res
- -- replace trees with their predicted equivalents
- repTree t = lookupWithDefaultFM treemap [t] t
- repPath p = concatMap repTree p
- {- repPath p = trace ("\n==============\npath\n=============\n" ++ drawTagTrees l) l
- where l = repPath' p -}
- in (map repPath cands, stats)
-\end{code}
-
-\paragraph{optimisePredictors'} is a helper function that tries to
-fulfill as many of a tree's predictors as possible. Any predictors
-it cannot use are also returned so that they can be passed to the
-generator proper.
-
-\begin{code}
-optimisePredictors' :: PredictorMap -> TagElem -> ([TagElem], Gstats)
-optimisePredictors' predictmap te =
- let -- grab the predictors (helper fns)
- isneg _ e = e < 0
- predictors t = Map.keys $ filterFM isneg $ tpredictors t
- ptrees t = concatMap fn (predictors t)
- where fn = lookupWithDefaultFM predictmap []
- -- generate
- tePtrees = ptrees te
- initSt = initMState tePtrees [te] (tsemantics te) defaultParams
- (res', st) = runState miniGenerate initSt
- -- pick the trees with the largest derivation history
- derSz = length.snd.derivation
- cmpDerSz t1 t2 = compare (derSz t2) (derSz t1) -- note the inversion
- sameDerSz t1 t2 = (derSz t2) == (derSz t1)
- groupedres = groupBy sameDerSz $ sortBy cmpDerSz res'
- -- return the results
- result = head groupedres -- trace ("\n==============\nresults for " ++ idname te ++ "\n=============\n" ++ drawTagTrees res) $
- rejects = concatMap ptrees result
- stats = genstats st
- --
- debugstr = "\n==================="
- ++ "\noptimising " ++ showLite te
- ++ "\nptrees: " ++ showLite (tePtrees)
- ++ "\n==================== "
- errormsg = "Geni: Predictors.optimisePredictors' is broken"
- in case () of _ | null tePtrees -> ([te], stats)
- | null groupedres -> error errormsg
- | otherwise -> (result ++ rejects, stats)
-\end{code}
-
-% ----------------------------------------------------------------------
-\subsection{miniGenerate}
-% ----------------------------------------------------------------------
-
-miniGenerate is a lightweight version of the generator which operates
-on the following principles:
-
-\begin{enumerate}
-\item There is one primary tree (chart) and some secondary trees
- (agenda), which should not be confused with auxiliary trees
-\item All operations are performed between the primary
- tree and the secondary trees, that is, you won't
- have any interaction between secondary trees
-\item The primary tree may substitute with or be
- substituted any number of secondary trees
-\item Secondary trees may only be used once
-\end{enumerate}
-
-It is used as a helper function for optimisePredictors.
-
-\begin{code}
-miniGenerate :: MS [TagElem]
-miniGenerate = do
- nir <- nullInitRep
- gr <- getGenRep
- if nir then return (concat $ elems gr) else do
- incrGeniter 1
- tsem <- getSem
- -- choose a secondary tree from the agenda
- given <- selectGiven
- -- perform any substitutions
- chart <- lookupGenRep given
- let (res', cost') = unzip $ map (timidSubstitution given) chart
- res = concat res'
- cost = foldr (+) 0 cost'
- incrSzchart (length res)
- incrNumcompar cost
- -- add any succesful results to the chart
- st <- get
- put st { genrep = addListToGenRep gr res }
- miniGenerate
-\end{code}
-
-\paragraph{timidSubstitution} attempts to perform substitution between
-input trees $te_1$ and $te_2$. This is meant strictly to be a helper
-function for optimisePredictors, so we'll have a somewhat conservative
-and quirky behaviour:
-\begin{itemize}
-\item If there are no ways to perform substitution, we return the empty
-list
-\item If there is exactly one way to perform substitution
-(either $te_1$ into $te_2$ or vice versa), we
-return that substitution.
-\item If there is more than one way to do it, we return the empty list.
-This is because the situation is ambiguous and could lead to unpredictable
-results (see section \ref{sec:optimisePredictors_tricky})
-\end{itemize}
-
-This is somewhat similar to MState's applySubstitution, except that we
-rule out the case of multiple results, and that we do not require the
-substitution nodes to be in any particular order.
-
-\begin{code}
-timidSubstitution :: TagElem -> TagElem -> ([TagElem],Int)
-timidSubstitution te1 te2 =
- let tesem = tsemantics te1
- -- we only substitute tags with no overlaping semantics
- notOverlap = null $ intersect (tsemantics te2) tesem
- -- we rename tags to do a proper substitution
- rte1 = renameTagElem 'A' te1
- rte2 = renameTagElem 'B' te2
- -- perform the substitution
- subst t1 t2 = concatMap (iapplySubstNode t1 t2) $ substnodes t2
- res' = (subst rte1 rte2) ++ (subst rte2 rte1)
- res = if (length res' == 1) then res' else []
- -- measuring efficiency
- cost = fn te1 + fn te2
- where fn t = length $ substnodes t
- in if notOverlap then (res, cost) else ([], 0)
-\end{code}
-
-\subsection{Trickiness in optimisePredictors}
-\label{sec:optimisePredictors_tricky}
-
-Rejecting ambiguous substitutions is crucial to the idea that
-secondary trees may only be used once.
-
-Consider the trees for \textit{the N, enemy of N, friend}.
-The idea is that we eventually want to generate \textit {the enemy of the
-friend}, so the result of optimisePredictors should ideally be something like:
-\textit{the friend, the enemy of N}
-
-But this isn't so easy to achieve. In fact, if we tried to achieve
-the above result, we would instead get a highly undesirable result
-like this \textit{the friend, the enemy of the N}
-
-Do you see why the above result is bad? It is because now there is
-no way to substitute friend into that noun-substitution node. To
-avoid this sort of over-ambitiousness, we avoid ambiguous cases where a
-tree could both substitute into or be substituted into another. So we
-get a less optimal, but much safer result \textit{the friend, enemy of,
-the}:
-
-% ----------------------------------------------------------------------
-\section{Cleanup}
-% ----------------------------------------------------------------------
-
-\paragraph{fillPredictors} This is neccesary when either the
-predictor optimisation is disabled or if there are some
-predictor substitutions which do not succeed. It takes a list of paths
-and inserts all required predictors on the paths.
-
-\begin{code}
-fillPredictors :: [[TagElem]] -> PredictorMap -> [[TagElem]]
-fillPredictors paths predictmap =
- let isneg _ pol = pol < 0
- getP = lookupWithDefaultFM predictmap []
- predictors te = Map.keys $ filterFM isneg $ tpredictors te
- addP te = te : (concatMap getP $ predictors te)
- in map (\p -> nub $ concatMap addP p) paths
-\end{code}
-
-% --------------------------------------------------------------------
-\section{Instatiation of predictors}
-% --------------------------------------------------------------------
-
-We combine the predictors from the lexicon and macros. The idea is
-to do this in a way which lets the grammar writer be lazy while having
-as simple and predictable a behaviour as possible. Any predictors that
-the lexicon has must correspond to some variable predictor in the
-macros, so if I say in the lexicon that a tree as predictor
-$+vsup:avoir$ there had better be a $+vsup:X$ in the macros to back it
-up.
-
-\begin{code}
-combinePredictors tt le =
- let -- fn to add an item to the predictors map
- addP (fv,c) fm = addToFM_C (+) fm fv c
- -- lexicon predictors
- lpr = sort $ ipredictors le
- -- tree predictors (variable vs constant predictors)
- tpr = sort $ ptpredictors tt
- isVpr ((f,v),_) = (not $ null v) && isVar v
- (varPr,constPr) = partition isVpr tpr
- constPrFm = foldr addP Map.empty constPr
- -- separating the charges from the fv
- (lfv, lc) = unzip lpr
- (vfv, vc) = unzip varPr
- -- the unification
- unify [] [] = []
- unify ((tf,tv):tnext) ((lf,lv):lnext)
- | tf /= lf = error errmsg
- | isVar lv = error errvlex
- | isVar tv = (lf,lv):(unify (substFlist' tnext (tv,lv)) lnext)
- | lv == tv = (lf,lv):(unify tnext lnext)
- | otherwise = error errmsg
- unification = unify vfv lfv
- -- error messages in case things don't line up
- errmsg = "Word '" ++ (iword le) ++ "' does not correctly "
- ++ " instantiate the variable predictors in tree "
- ++ (itreename le)
- ++ "\n Tree predictors: " ++ (show $ map fst varPr)
- ++ "\n Word predictors: " ++ (show $ map fst lpr)
- ++ "\n Hint: only the variable predictors should be instantiated"
- errvlex = "Word '" ++ (iword le) ++ "' contains variable "
- ++ " predictors in " ++ (show $ map fst lpr)
- in if (lc == vc) -- note: this implies list equality
- then foldr addP constPrFm $ zip unification lc
- else error errmsg
-\end{code}
-
-
-% ----------------------------------------------------------------------
-\section{PredictorMap}
-% ----------------------------------------------------------------------
-
-We create a map between predictors and the trees that provide them.
-
-\begin{code}
-type PredictorMap = Map AvPair [TagElem]
-\end{code}
-
-\begin{code}
-mapByPredictors :: [TagElem] -> PredictorMap
-mapByPredictors trees = foldr mapByPredictors' Map.empty trees
-
-mapByPredictors' :: TagElem -> PredictorMap -> PredictorMap
-mapByPredictors' tree fm =
- let ispos _ pol = (pol > 0)
- predictors = Map.keys $ filterFM ispos $ tpredictors tree
- addp p f = addToFM_C (++) f p [tree]
- in foldr addp fm predictors
-\end{code}