GenI 0.17.4 → 0.20

raw patch · 52 files changed

+4364/−5431 lines, 52 filesdep +jsondep +paralleldep +splitdep ~HUnitdep ~basedep ~binarysetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: json, parallel, split, test-framework, test-framework-hunit, test-framework-quickcheck, uniplate, utf8-string

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

API changes (from Hackage documentation)

Files

• GenI.cabal +41/−36
• INSTALL +12/−8
• NEWS +61/−0
• Setup.hs +117/−0
• Setup.lhs +0/−68
• etc/macstuff/Info.plist +5/−5
• etc/macstuff/macosx-app +0/−114
• etc/stupidmorph.pl +85/−0
• examples/demo/README +0/−0
• examples/ej/lexicon +0/−0
• examples/ej/suite +0/−0
• examples/xmg-example/Makefile +3/−3
• examples/xmg-example/grammar/demo-corpus-latin1.txt +0/−6
• examples/xmg-example/grammar/demo-corpus-utf8.txt +6/−0
• examples/xmg-example/lexicon/demo-lemma-latin1.lex +0/−113
• examples/xmg-example/lexicon/demo-lemma-utf8.lex +113/−0
• examples/xmg-example/lexicon/demo-morph-latin1.mph +0/−24
• examples/xmg-example/lexicon/demo-morph-utf8.mph +24/−0
• examples/xmg-example/suite +0/−0
• src/EnableGUI.hs +0/−38
• src/MainGeni.lhs +53/−15
• src/NLP/GenI/Automaton.hs +136/−0
• src/NLP/GenI/Automaton.lhs +0/−140
• src/NLP/GenI/Btypes.lhs +134/−365
• src/NLP/GenI/BtypesBinary.hs +5/−0
• src/NLP/GenI/Builder.lhs +107/−25
• src/NLP/GenI/CkyEarley/CkyBuilder.lhs +0/−1244
• src/NLP/GenI/CkyEarley/CkyGui.lhs +0/−456
• src/NLP/GenI/Configuration.lhs +170/−152
• src/NLP/GenI/Console.hs +73/−75
• src/NLP/GenI/General.hs +7/−19
• src/NLP/GenI/Geni.lhs +286/−166
• src/NLP/GenI/GeniParsers.lhs +559/−413
• src/NLP/GenI/GeniShow.lhs +2/−2
• src/NLP/GenI/GeniVal.hs +309/−0
• src/NLP/GenI/GraphvizShow.lhs +10/−10
• src/NLP/GenI/Gui.lhs +141/−163
• src/NLP/GenI/GuiHelper.hs +750/−0
• src/NLP/GenI/GuiHelper.lhs +0/−860
• src/NLP/GenI/Morphology.lhs +84/−69
• src/NLP/GenI/OptimalityTheory.lhs +390/−0
• src/NLP/GenI/Polarity.lhs +119/−80
• src/NLP/GenI/PolarityTypes.hs +44/−0
• src/NLP/GenI/Regression.hs +83/−0
• src/NLP/GenI/Simple/SimpleBuilder.lhs +238/−219
• src/NLP/GenI/Simple/SimpleGui.lhs +22/−14
• src/NLP/GenI/Statistics.hs +21/−87
• src/NLP/GenI/SysGeni.hs +77/−0
• src/NLP/GenI/SysGeni.lhs +0/−93
• src/NLP/GenI/Tags.lhs +70/−22
• src/NLP/GenI/Test.hs +7/−12
• src/NLP/GenI/unused/Predictors.lhs +0/−315

@@ -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

@@ -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

@@ -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

@@ -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"]

@@ -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--

@@ -7,7 +7,7 @@ 	<key>CFBundleExecutable</key> 	<string>geni</string> 	<key>CFBundleGetInfoString</key>-	<string>GenI unstable 0.8</string>+	<string>GenI</string> 	<key>CFBundleIconFile</key> 	<string>wxmac.icns</string> 	<key>CFBundleIdentifier</key>@@ -15,22 +15,22 @@ 	<key>CFBundleInfoDictionaryVersion</key> 	<string>6.0</string> 	<key>CFBundleLongVersionString</key>-	<string>0.8, (c) 2005 LORIA</string>+	<string>(c) 2005-2009 LORIA</string> 	<key>CFBundleName</key> 	<string>GenI</string> 	<key>CFBundlePackageType</key> 	<string>APPL</string> 	<key>CFBundleShortVersionString</key>-	<string>0.8</string>+	<string>0</string> 	<key>CFBundleSignature</key> 	<string>????</string> 	<key>CFBundleVersion</key>-	<string>0.8</string>+	<string>0</string> 	<key>CSResourcesFileMapped</key> 	<true/> 	<key>LSRequiresCarbon</key> 	<true/> 	<key>NSHumanReadableCopyright</key>-	<string>Copyright 2005 LORIA</string>+	<string>Copyright 2005-2009 LORIA</string> </dict> </plist>

@@ -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] <program (a.out)>"-        echo ""-        echo "options: [defaults in brackets]"-        echo "  --help | -?         show this information"-	echo "  --verbose | -v      be verbose"-        echo ""-        exit 1;;-    -v|--verbose)-        verbose="yes";;-    -*) echo "error: Unknown option \"$1\". Use \"--help\" to show valid options." 1>&2-        echo "" 1>&2-        exit 2;;-    *)  if test "$program"; then-         echo "error: [program] is specified twice. Use \"--help\" to show valid options." 1>&2-	 echo ""1>&2-	 exit 2-	fi-	program="$1";;-  esac-  shift-done--# default program-if test -z "$program"; then-  echo "error: you need to specify a program. Use \"--help\" to show valid options." 1>&2-  echo "" 1>&2-  exit 2-fi--# show when verbose is true.-show()-{-  if test "$verbose" = "yes"; then -    echo "$1"-  fi-}--# link with default resources-# this is neccesary only to run the GUI from the command line -if test "$rezcomp"; then- show "creating resource:" - show " > $rezcomp $program"- $rezcomp $program-fi--# create a bundle-bundle="$program.app/Contents"--# create bundle directories-show "creating app directories:"-show " - $program.app"-mkdir -p $program.app-show " - $bundle"-mkdir -p $bundle-show " - $bundle/MacOS"-mkdir -p $bundle/MacOS-show " - $bundle/Resources"-mkdir -p $bundle/Resources--cp -f $program $bundle/MacOS/--# copy the icon -cp -f ${icnsfile} $bundle/Resources--# package info-show "creating package info:"-show " - $bundle/PkgInfo"-echo -n "APPL????" > $bundle/PkgInfo--# create program information file-cp ${infofile} $bundle/Info.plist --# tell finder that there's an icon -/Developer/Tools/SetFile -a C $bundle--show "done."-show ""

@@ -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 = <STDIN>;+$/ = $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);

@@ -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

@@ -1,6 +0,0 @@-Jean aime Marie.-Jean est appelé par Marie.-Marie aime Jean.-Marie appelle.-Jean qui appelle aime Marie.-ils appellent.

@@ -0,0 +1,6 @@+Jean aime Marie.+Jean est appelé par Marie.+Marie aime Jean.+Marie appelle.+Jean qui appelle aime Marie.+ils appellent.

@@ -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:

@@ -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:

@@ -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;]

@@ -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;]

@@ -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

@@ -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

@@ -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)

@@ -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}-

@@ -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}-}

@@ -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)

@@ -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}+}

@@ -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).--

@@ -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}

@@ -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

@@ -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)+

@@ -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

@@ -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}+} 

@@ -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}+<alpha-numeric>+<string-literal> (stuff between quotes)+<opt-whatever> (systematically... "" | <whatever>)+<keyword-whatever> (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}+<value>         ::= <variable> | <anonymous-variable> | <constant-disj>+<variable>      ::= "?" <identifier>+<anonymous>     ::= "?_" | "_"+<constant-disj> ::= <constant> (| <constant>)*+<constant>      ::= <identifier>+<identifier>    ::= <alphanumeric> | "+" | "-" | "_"+\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}+<feature-structure>    ::= "[" <atttribute-value-pair>* "]"+<attribute-value-pair> ::= <identifier> ":" <value>+\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}+<semantics>      ::= <keyword-semantics> "[" <literal>* "]"+<literal>        ::= <identifier> "(" <value>* ")"+\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}+<test-suite>       ::= <test-suite-entry>*+<test-suite-entry> ::= <opt-identifier> <semantics> <expected-output>*+<expected-output>  ::= <opt-keyword-sentence> "[" <identifier>* "]"+\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}+<lexicon>        ::= <lexicon-entry>*+<lexicon-entry>  ::= <lexicon-header> <opt-filters> <semantics>+<lexicon-header> ::= <lemma> <family> <parameters>+                   | <lemma> <family> <keyword-equations> <feature-structure>+<parameters>     ::= "(" <value>* <opt-interface> ")"+<interface>      ::= "!" <attribute-value-pairs>*+<filters>        ::= <keyword-filter> <feature-structure>+\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}+<macros> ::= <macro>*+<macro>  ::= <family-name> <opt-macro-name> <parameters> <tree-type> <tree>+             <opt-semantics> <opt-trace>++<parameters>     ::= "(" <value>* <opt-interface> ")"+<interface>      ::= ! <attribute-value-pair>*+<macro-name>     ::= <identifier>+<tree-type>      ::= "initial" | "auxiliary"+<trace>          ::= <keyword-trace> "[" <identifier>* "]"++<tree>           ::= <node> | <node> "{" <tree>* "}"+<node>           ::= <node-name> <opt-node-type> <node-payload>+<node-name>      ::= <identifier>+<node-type>      ::= <keyword-type> <core-node-type> | "anchor"+<core-node-type> ::= "foot" | "subst" | "lex"+<node-payload>   ::= <string-literal> | <feature-structure> "!" <feature-structure>+\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}

@@ -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

@@ -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