packages feed

antfarm (empty) → 0.1.0.0

raw patch · 12 files changed

+1205/−0 lines, 12 filesdep +HUnitdep +antfarmdep +basesetup-changed

Dependencies added: HUnit, antfarm, base, containers, minimorph, mtl, parsec, test-framework, test-framework-hunit, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Eric Kow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Eric Kow nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ NLP/Antfarm.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DeriveDataTypeable, ViewPatterns, OverloadedStrings, TupleSections #-}++-- | Module    : NLP.Antfarm.History+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Referring expression generation for definitions.+--+--+module NLP.Antfarm+    (+    -- * Key structures+      module NLP.Antfarm.Refex+    -- * Discourse history+    , RefHistory(..)+    , addToHistory, emptyHistory, noteImplicitBounds+    -- * Core generation+    , rx, subrx, subrxNumber+    -- * English surface form+    , englishRx, englishSubrx+    )+  where++import NLP.Antfarm.Internal+import NLP.Antfarm.Refex+import NLP.Antfarm.English+import NLP.Antfarm.History
+ NLP/Antfarm/Cardinality.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+-- | Module    : NLP.Antfarm.Cardinality+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Cardinality constraints+module NLP.Antfarm.Cardinality where++import Data.Text ( Text )++data Constraint = AtMost  Int+                | Exactly Int+                | AtLeast Int+                | Unknown Text+  deriving (Show, Eq, Ord)++lowerBound :: Constraint -> Maybe Int+lowerBound (AtLeast x) = Just x+lowerBound (Exactly x) = Just x+lowerBound (AtMost _)  = Nothing+lowerBound (Unknown _) = Nothing++upperBound :: Constraint -> Maybe Int+upperBound (AtLeast _) = Nothing+upperBound (Exactly x) = Just x+upperBound (AtMost x)  = Just x+upperBound (Unknown _) = Nothing++unknown :: Constraint -> Maybe Text+unknown (Unknown t) = Just t+unknown _           = Nothing
+ NLP/Antfarm/Demo.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE OverloadedStrings, TupleSections #-}+-- | Module    : NLP.Antfarm.Demo+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Helper functions for the antfarm demonstrator.  You probably don't want to+-- import this module unless you're doing something amusing like making a web+-- app out of the antfarm demonstrator.  But it could be useful to look at the+-- source if you're making something using antfarm+module NLP.Antfarm.Demo where++import Control.Applicative+import Control.Arrow hiding ( (<+>) )+import Control.Monad.Trans.State+import Control.Monad.Identity+import Data.Char ( isAlpha, isSpace, isDigit )+import Data.Function+import Data.List+import Data.List ( find, nub )+import Data.Maybe+import Data.Text ( Text )+import Data.Tree+import qualified Data.Set as Set+import qualified Data.Text as T++import NLP.Minimorph.English+import NLP.Minimorph.Number+import NLP.Minimorph.Util+import Text.Parsec hiding ( State )+import Text.Parsec.String+import qualified Text.Parsec as P++import NLP.Antfarm+import NLP.Antfarm.English+import NLP.Antfarm.History+import NLP.Antfarm.Refex+import NLP.Antfarm.Cardinality++decode :: String -> Either ParseError [[DiscourseUnit]]+decode t =+    map fromDemoForest <$> parse (pFilled pSentence) "" t++decodeRx :: String -> Either ParseError [DiscourseUnit]+decodeRx t =+    fromDemoForest <$> parse (pFilled pDemoElemForest) "" t++type RefStateT m a = StateT RefHistory m a+type RefState a    = RefStateT Identity a++nextRx :: Monad m => [DiscourseUnit] -> RefStateT m Text+nextRx dus = do+   oldst <- get+   modify (addToHistory dus)+   return $ englishRx $ rx oldst (map toSubRxInput dus)++-- ----------------------------------------------------------------------+--+-- ----------------------------------------------------------------------++itemToClass :: Text -> Text+itemToClass i_ =+    fromMaybe i (lookup i lexMap)+  where+    i = stripNonClassStuff i_++isClassWide :: Text -> Bool+isClassWide i = i == stripNonClassStuff i++stripNonClassStuff :: Text -> Text+stripNonClassStuff = T.takeWhile isAlpha++lexMap :: [ (Text,Text) ]+lexMap = [ ("a", "ant")+         , ("b", "box")+         , ("c", "cat")+         , ("d", "dog")+         , ("e", "egg")+         , ("f", "fox")+         , ("g", "gun")+         , ("h", "hen")+         , ("i", "imp")+         , ("j", "jug")+         , ("k", "key")+         , ("l", "leg")+         , ("m", "map")+         , ("n", "nun")+         , ("o", "owl")+         , ("p", "pig")+         , ("q", "car")+         , ("r", "rig")+         , ("s", "saw")+         , ("t", "tin")+         , ("u", "ubi")+         , ("v", "vat")+         , ("w", "wig")+         , ("x", "axe")+         , ("y", "yew")+         , ("z", "zoo")+         , ("A", "animal")+         , ("B", "bird")+         , ("M", "mammal")+         ]++onWords :: (Text -> Maybe Text) -> Text -> Text+onWords f = T.unwords . mapMaybe f . T.words++intercalateRx :: [Text] -> Text+intercalateRx = T.intercalate ", "+++-- ----------------------------------------------------------------------+-- aura-rx-test language examples+--+-- a1+-- a1 a2+-- a1 a2+-- a >= 5 a3+-- a >= 5 ( b1 b3 )+-- a1 a2  ( b1 b3 ) c < 3 ( d3 )+-- ----------------------------------------------------------------------++data DemoElem = DemoElem+    { dClass  :: Text+    , dConstr :: Constr+    }+  deriving Show++data Constr = Constr Constraint+            | Inst   Text+            | ClassWide+  deriving Show++fromDemoElem :: DemoElem -> RefGroup+fromDemoElem e = RefGroup+    { rgClass  = dClass e+    , rgIdxes  = Set.fromList   [ x | Inst x   <- [dConstr e] ]+    , rgBounds = explicitBounds [ x | Constr x <- [dConstr e] ]+    }++mergeGroups :: [RefGroup] -> RefGroup+mergeGroups [] =+    error $ "mergeGroups: can't merge empty list"+mergeGroups rs@(r0:_) =+    if any (\r -> rgClass r /= rgClass r0) rs+       then error . T.unpack $+                "mergeGroups: not all constraint classes match" <+> rgClass r0+       else noteImplicitBounds $+            r0 { rgIdxes  = Set.unions    (map rgIdxes  rs)+               , rgBounds = foldr1 narrow (map rgBounds rs)+               }++-- | Regroup constraints and examples so that like are with like+--+-- > a1 b3 a4+-- >   ==> [a1 a4] [b3]+-- > a1 b3 a4 (x <= 3) b6+-- >   ==> [a1 a4]([x <= 3]) [b3 b6]+-- > a1 b3 a4 (x <= 3) b6 (y >= 8) a <= 1 (x >= 8)+-- >   ==> [a1 a4]([x <= 3 >= 8]) [b3 b6]([y>=8])+--+fromDemoForest :: [Tree DemoElem] -> [DiscourseUnit]+fromDemoForest ts =+    map mergeChunk chunks+  where+    key     = dClass . rootLabel+    -- tries to preserve order+    chunks  = map findChunk $ nub $ map key ts+    chunks_ = buckets key ts+    findChunk t = maybe (error "fromDemoForest: resort oops") (t,)+                $ lookup t chunks_+    --+    mergeChunk (_, xs) =+         Node (mergeGroups (map convert xs))+              (fromDemoForest $ concatMap subForest xs)+    convert = fromDemoElem . rootLabel++toSubRxInput :: DiscourseUnit -> Tree SubRxInput+toSubRxInput =+    onSubTrees helper+  where+    helper du@(Node rg _) = SubRxInput+        { srxInpDet    = SP [indefiniteDet word] ["the"]+        , srxInpWord   = SP word (defaultNounPlural word)+        , srxInpEntity = du+        }+      where+        word = rgClass rg++-- ----------------------------------------------------------------------+-- Parser for rx language+-- ----------------------------------------------------------------------++pFilled :: Parser a -> Parser a+pFilled p = spaces *> p <* eof++pSentence :: Parser [[Tree DemoElem]]+pSentence = (spaces *> pDemoElemForest) `sepBy` char ','++pDemoElemForest :: Parser [Tree DemoElem]+pDemoElemForest = pDemoElemTree `sepEndBy` spaces++pDemoElemTree :: Parser (Tree DemoElem)+pDemoElemTree = do+    n    <- pDemoElem ; spaces+    kids <- option [] $ P.between (char '(') (char ')') $+                pDemoElemForest+    return (Node n kids)++pDemoElem :: Parser DemoElem+pDemoElem = do+   lx      <- pLexeme <* spaces+   mconstr <- option Nothing (Just <$> pConstr)+   let inst = case mconstr of+           Nothing | isClassWide lx -> ClassWide+                   | otherwise      -> Inst lx+           Just c                   -> Constr c+   return $ DemoElem (itemToClass lx) inst++pConstr :: Parser Constraint+pConstr = try $ do+   op <- pOp+   case getOp op of+       Nothing -> fail . T.unpack $ "not a known op:" <+> op+       Just fn -> spaces *> (fn <$> pNatural)+ where+   getOp o = fst <$> find ((o `elem`) . snd) opTable+++opTable :: [(Int -> Constraint, [Text])]+opTable =+   [ (AtLeast,         [">=", "ge", "at-least"])+   , (AtLeast . (1+),  [">" , "gt"])+   , (AtMost,          ["<=", "le", "at-most"])+   , (AtMost . minus1, ["<" , "lt"])+   , (Exactly,         ["==", "=", "eq", "exactly"])+   ]+  where+    minus1 x = x - 1++pLexeme :: Parser Text+pLexeme =+    T.pack <$> many1 (satisfy isLexChar)+  where+    isLexChar c = c `notElem` "()<=>," && not (isSpace c)++pOp :: Parser Text+pOp =+    T.pack <$> many1 (satisfy isLexChar)+  where+    isLexChar c = c `notElem` "()," && not (isSpace c || isDigit c)++pNatural :: Parser Int+pNatural = read <$> many1 digit++-- ----------------------------------------------------------------------+--+-- ----------------------------------------------------------------------++class Pretty a where+    pretty :: a -> Text++instance Pretty RefGroup where+    pretty (RefGroup cl idxs bs) =+        cl <+> (parens . T.unwords $ Set.toAscList idxs)+           <+> pretty bs++instance Pretty Bounds where+    pretty (Bounds bs ml mu) =+        maybe "" ge ml <+> maybe "" le mu <+>+        (if null bs then "" else squares (T.unwords bs))+      where+        le i = "≤" <> pretty i+        ge i = "≥" <> pretty i++instance Pretty Text where+    pretty = id++instance Pretty Int where+    pretty = T.pack . show++parens :: Text -> Text+parens t = "(" <> t <> ")"++squares :: Text -> Text+squares t = "(" <> t <> ")"++prettyForest :: Pretty a => [Tree a] -> Text+prettyForest = T.unwords . map prettyTree++prettyTree :: Pretty a => Tree a -> Text+prettyTree (Node x []) = pretty x+prettyTree (Node x ns) = pretty x <+> "(" <> prettyForest ns <> ")"++-- ----------------------------------------------------------------------+-- odds and ends+-- ----------------------------------------------------------------------++buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ]+buckets f = map (first head . unzip)+          . groupBy ((==) `on` fst)+          . sortBy (compare `on` fst)+          . map (\x -> (f x, x))++onSubTrees :: (Tree a -> b) -> Tree a -> Tree b+onSubTrees f n@(Node _ ks) = Node (f n) (map (onSubTrees f) ks)
+ NLP/Antfarm/English.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Module    : NLP.Antfarm.English+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Functions to realise antfarm output in English.+--+-- We're not under any illusions that antfarm will work well for+-- languages other than English, but it could still be useful to+-- try anyway.+module NLP.Antfarm.English where++import Data.Text ( Text )+import Data.Tree ( Tree(..) )+import qualified Data.Text as T++import NLP.Minimorph.English+import NLP.Minimorph.Number+import NLP.Minimorph.Util+import NLP.Antfarm.Refex++-- | English realisation for a referring expression+englishRx :: [Tree SubRx] -> Text+englishRx =+    commas "and" . map (expand . fmap englishSubrx)+  where+    expand (Node main exs)  = main <+> examples exs+    examples [] =  ""+    examples xs = "(" <> T.intercalate ", " (map expand xs) <> ")"++-- | English realisation for a referring expression subunit (this can be useful+--   if you need special formatting between units, eg. bullet points)+englishSubrx :: SubRx -> Text+englishSubrx x =+    T.unwords $ discr ++ [body]+  where+    num   = srxNumber x+    discr = englishDiscriminator (srxDet x) (srxDiscriminator x)+    body  = fromSP num $ srxWord x++englishDiscriminator :: SingPlu [Text] -- ^ default determiner+                     -> Discriminator+                     -> [Text]+englishDiscriminator det discr =+    case discr of+        NilDiscriminator -> []+        TheSame          -> [ "the", "same"    ]+        TheOther         -> [ "the", "other"   ]+        TheOrdinal n     -> [ "the", ordinal n ]+        NewOrdinal 2     -> [ "another" ] -- prefer "another" to "a second"+        NewOrdinal n     -> [ indefiniteDet (ordinal n), ordinal n ]+        Another 1        -> [ "another" ]+        Another n        -> [ "another", cardinal n ]+        PlainCardinal 1  -> sg det+        PlainCardinal n  -> [ cardinal n ]+        CardinalOfThe n  -> [ cardinal n, "of", "the" ]+        The              -> [ "the" ]+        Bounded (SayAtLeast n)   -> [ "at", "least", cardinal n ]+        Bounded (SayAtMost  n)   -> [ "at", "most" , cardinal n ]+        Bounded (SayExactly n)   -> [ "exactly", cardinal n ]+        Bounded (SayBetween n m) -> [ "between", cardinal n, "and", cardinal m ]+        Bounded (SayArbitrary t) -> [ t ]++-- defaultDet :: Text -> SingPlu [Text]+-- defaultDet word = SP [indefiniteDet word] ["the"]
+ NLP/Antfarm/History.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleInstances #-}+{-# LANGUAGE ViewPatterns, TupleSections #-}+-- | Module    : NLP.Antfarm.History+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Discourse history tracking+module NLP.Antfarm.History where++import Control.Applicative ((<$>))+import Data.List ( foldl', elemIndex, delete )+import Data.Maybe ( isJust, mapMaybe )+import Data.Text ( Text )+import Data.Tree ( Tree(..), flatten )+import Prelude hiding ( lex )+import qualified Data.Set  as Set+import qualified Data.Map  as Map++import NLP.Antfarm.Refex++-- | A 'RefGroup' is considered to refer exactly to its indices if it+--   has no bounds information or examples associated with it.+isExact :: RefGroup -> Bool+isExact rg = rgBounds rg == emptyBounds++-- | A discourse unit that would refer to just an element+mkSingletonDu :: RefKey -> DiscourseUnit+mkSingletonDu (c,i) = Node (RefGroup c (Set.singleton i) emptyBounds) []++{-+Note [discourse tree]+~~~~~~~~~~~~~~~~~~~~~++Our notion of a discourse unit is a tree of a RefGroup and its examples (and+their examples, etc).  When we enter such a unit into the history, we also+enter all of the examples as separate entries at the same time. This+facilitates queries on the units, and also affects the counts.  For example, if+we say “two atoms (a carbon and an oxygen)” we can consider the oxygen to have+already beeen referenced once so when we bring up another oxygen, we say+“another oxygen” accounting for the fact that oxygen had already been mentioned+once+-}+instance Ord (Tree RefGroup) where+     compare (Node r1 ks1) (Node r2 ks2) =+         case compare r1 r2 of+             EQ -> compare ks1 ks2+             x  -> x++data RefHistory  = RefHistory+    { -- | How many times a 'DiscourseUnit' has been mentioned+      rhCount :: Map.Map DiscourseUnit RefCount+      -- | For each class: an ordering of indices that reflects what+      --   ordinal expression should be used for them (if at all)+      --+      --   So @[c8,c3,c4]@ means+      --+      --   c8: the first+      --   c3: the second+      --   c4: the third+    , rhOrder :: Map.Map Text [Text]+    }+type RefCount    = Int++plusRefCount :: RefCount -> RefCount -> RefCount+plusRefCount = (+)++-- | Discourse history without any objects+emptyHistory :: RefHistory+emptyHistory = RefHistory Map.empty Map.empty++-- ----------------------------------------------------------------------+-- building the discourse history+-- ----------------------------------------------------------------------++-- See note `discourse tree'+--+-- | Take note of the fact that these discourse units have been mentioned+--   (again) in the history.+--+--   You probably want to realise the units first, then add them to the+--   history.+addToHistory :: [DiscourseUnit] -> RefHistory -> RefHistory+addToHistory ks st = st+    { rhCount = foldl' plusOne    (rhCount st) (concatMap subtrees ks)+    , rhOrder = foldl' addOrdinal (rhOrder st) (concatMap duSingletons ks)+    }+  where+    plusOne    m k = Map.insertWith' plusRefCount k 1 m+    addOrdinal m (c,i) =+        Map.insertWith' append c [i] m+      where+        append new old = if all (`elem` old) new then old else old ++ new++-- | Individuals mentioned in a discourse unit+--   (see 'refSingleton')+duSingletons :: DiscourseUnit -> [RefKey]+duSingletons =+    mapMaybe refSingleton . flatten++-- | A 'refSingleton' is an instance that appears by itself in a 'RefGroup'+--   without other items or constraints that imply that there could be other+--   items+refSingleton :: RefGroup -> Maybe RefKey+refSingleton (RefGroup c is bnds) =+    case Set.toList is of+        [i] -> if kosher bnds then Just (c,i) else Nothing+        _   -> Nothing+  where+    -- either no bounds information, or “exactly 1" are acceptable+    kosher (Bounds [] Nothing Nothing)   = True+    kosher (Bounds [] (Just 1) (Just 1)) = True+    kosher _ = False++-- | If a RefGroup has explicit constraints, augment them with the+--   implicit constraints that arise from treating each item+--   as evidence of an at least constraint+--+--   It's a good idea to run this once when building 'RefGroup's,+--   but you may also decide that this sort of behaviour is not+--   desirable for your application, so it's off by default+noteImplicitBounds :: RefGroup -> RefGroup+noteImplicitBounds rg =+     if implicits > 0+        then rg { rgBounds = bounds2 }+        else rg+   where+     bounds1 = rgBounds rg+     bounds2 =+         case bLower bounds1 of+             Just l  -> bounds1 { bLower = Just (max l implicits) }+             Nothing -> if isJust (bUpper bounds1)+                           then bounds1 { bLower = Just implicits }+                           else bounds1+     implicits = Set.size (rgIdxes rg)++-- ----------------------------------------------------------------------+-- query+-- ----------------------------------------------------------------------++-- | @hasDistractorGroup st k@ returns whether or not the discourse history+--   @st@ contains a group with distractors to @k@.+--+--   See 'distractorGroups' for more details+hasDistractorGroup :: RefHistory -> RefKey -> Bool+hasDistractorGroup st k =+    not . null $ distractorGroups st k++-- | @distractorGroups st k@ returns all the distractor groups for @k@+--   in the discourse history.+--+--   A distractor is defined (here) as something that has the the same class+--   as @k@ but a different index.+distractorGroups :: RefHistory -> RefKey -> [DiscourseUnit]+distractorGroups st (c, i) =+    filter distracting (Map.keys (rhCount st))+  where+    distracting = not . safe+    safe (Node rg2 _) = c /= rgClass rg2+                     || i `Set.member` rgIdxes rg2+                     || isClasswide rg2++-- | @hasSupersetMention st g@ returns whether or not the discourse history+--   contains a group that includes all members of @g@+--+--   Note that if a group has already occured in the discourse history, this+--   returns a True (ie. not a strict superset)+hasSupersetMention :: RefHistory -> DiscourseUnit -> Bool+hasSupersetMention st k = not . Map.null . rhCount $ supersetMentions k st++-- | @supersetMentions g st@ returns the portion of discourse history @st@+--   in which all groups are supersets of @g@ (inclusive, not strict super)+supersetMentions :: DiscourseUnit -> RefHistory -> RefHistory+supersetMentions (Node g _) h =+    h { rhCount = Map.filterWithKey hasK (rhCount h) }+  where+    hasK (Node g2 _) _ =+        rgClass g == rgClass g2 &&+        rgIdxes g `Set.isSubsetOf` rgIdxes g2++-- | @lastMention st k@ returns the number of times @k@ has been mentioned+lastMention :: RefHistory -> RefKey -> Int+lastMention st (c,i) =+    sum . Map.elems . rhCount $ supersetMentions (mkSingletonDu (c,i)) st++-- | @lastMention st g@ returns the number of times the group @g@ has been+--   mentioned+lastMentions :: RefHistory -> DiscourseUnit -> Int+lastMentions st k = Map.findWithDefault 0 k (rhCount st)++isFirstMention :: RefHistory -> RefKey -> Bool+isFirstMention st k = lastMention st k == 0++-- ----------------------------------------------------------------------+-- subtle queries+-- ----------------------------------------------------------------------++-- | If it makes sense to refer to a key using an ordinal expression,+--   the order we should assign it (Nothing if we either can't sensibly+--   assign one, or the history does not give us enough information to+--   do so)+mentionOrder :: RefHistory -> RefKey -> Maybe Int+mentionOrder rh (c,i) =+   if isOnlySingletons rh+      then case Map.lookup c (rhOrder rh) of+               Just is | length is > 1 -> (+ 1) <$> elemIndex i is+               _                       -> Nothing+      else Nothing+  where+     -- the c's never appear with others of their own kind in the same+     -- 'RefGroup'+     isOnlySingletons = not . any isMultiMatch+                      . Map.keys+                      . rhCount+     isMultiMatch (Node g _) =+         c == rgClass g && Set.size (rgIdxes g) > 1++-- | Is a subset of a previously mentioned group @g@ where there are no+-- distractors to @g@ in the discourse history+hasTidyBackpointer :: RefHistory -> DiscourseUnit -> Bool+hasTidyBackpointer st du@(Node rg _) =+    not (any (hasDistractorGroup st) keys)+    && lastMentions st du == 0+    && hasSupersetMention st du+  where+    keys = [ (rgClass rg, idx) | idx <- Set.toList (rgIdxes rg) ]++-- | @isTheOther st k@ returns whether or not there is a two-member group in+--   the discourse history which @k@ is a member of such that the other+--   member has already been mentioned as a part of a singleton group.+--+--   The idea is that if you have said "one of the X", you will want to say+--   "the other X" for the other member of that group+isTheOther :: RefHistory -> RefKey -> Bool+isTheOther st (c,i) =+    any isBuddy $ Map.keys (rhCount st)+  where+    isBuddy (Node g2 []) | isExact g2 && c == rgClass g2 =+        -- the other instance was mentioned at least once+        case getBuddy (rgIdxes g2) of+          Just b  -> lastMentions st (mkSingletonDu (c,b)) >= 1+          Nothing -> False+    isBuddy _ = False+    --+    getBuddy (Set.toList -> idx) | length idx == 2 =+         case delete i idx of+             [b] -> Just b -- must be *exactly* one other item+             _   -> Nothing+    getBuddy _ = Nothing++-- | Is the class itself, not any individual entity within that class+--   ie. “ants” instead of “an ant” or “some ants”+--+--   By convention, any group which containts no indices or constraints+--   is considered to be classwide.+isClasswide :: RefGroup -> Bool+isClasswide rg = Set.null (rgIdxes rg) && isExact rg++-- ----------------------------------------------------------------------+-- odds and ends+-- ----------------------------------------------------------------------++-- | Like 'flatten', but returns whole subtrees instead of+--   just nodes:+--+--   > a(b c(d e(f g)) h)+--   > b+--   > c(d e(f g))+--   > d+--   > e(f g)+--   > f+--   > g+--   > h+--+--  Invariant: @map rootLabel (subtrees x) == flatten x@+subtrees :: Tree a -> [Tree a]+subtrees t =+    grab t []+  where+    grab st@(Node _ ts) xs = st : foldr grab xs ts++mkLeaf :: a -> Tree a+mkLeaf x = Node x []++fst3 :: (a, b, c) -> a+fst3 (x, _, _) = x++snd3 :: (a, b, c) -> b+snd3 (_, y, _) = y++thd3 :: (a, b, c) -> c+thd3 (_, _, z) = z
+ NLP/Antfarm/Internal.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE DeriveDataTypeable, ViewPatterns, OverloadedStrings, TupleSections #-}++-- | Module    : NLP.Antfarm.Internal+-- Copyright   : 2012 Eric Kow (Computational Linguistics Ltd.)+-- License     : BSD3+-- Maintainer  : eric.kow@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- The heart of the referring expression generation+module NLP.Antfarm.Internal where++import Data.Maybe ( fromMaybe )+import Data.Tree ( Tree(..) )+import Prelude hiding ( lex )+import qualified Data.Set  as Set++import NLP.Minimorph.Number++import NLP.Antfarm.Refex+import NLP.Antfarm.History++-- ----------------------------------------------------------------------+-- concepts (sub-unit of referring expressions)+-- ----------------------------------------------------------------------+-- englishDiscriminator (fromSP agr (srxDet srx))+-- word  = fromSP agr (srxWord srx)++-- | Decide how to realise a referring expression+rx :: RefHistory -> [Tree SubRxInput] -> [Tree SubRx]+rx st = map (subrx st)++-- | Decide how to realise a single unit within a referring expression+--+--   Keep in mind that this is only for one 'DiscourseUnit' within a single rx.+--   An rx may involve multiple discourse units (eg. 3 cats and 1 dog)+subrx :: RefHistory+      -> Tree SubRxInput+      -> Tree SubRx+subrx st (Node srx egs) =+    (Node root kids)+  where+    du    = srxInpEntity srx+    num   = surfaceNumber st du+    discr = discriminate  st du+    root  = SubRx num discr (srxInpDet srx) (srxInpWord srx)+    --+    kids | null egs               = []+         | lastMentions st du > 0 = []+         | otherwise              = map (subrx st) egs++-- ----------------------------------------------------------------------+-- Number+-- ----------------------------------------------------------------------++-- | Helper for 'fromConcept'+--+--   Whether the noun in a 'DiscourseUnit' should be realised as singular+--   or plural.  Note the difference between this and+--   'actualNumber'+surfaceNumber :: RefHistory -> DiscourseUnit -> Number+surfaceNumber st du =+    case subrxNumber du of+        FN_Singular      -> Singular+        FN_Plural        -> Plural+        FN_MaybeSingular -> if override then Plural else Singular+  where+    override = hasTidyBackpointer st du++-- | Whether a 'DiscourseUnit' should be considered *morally*+--   (semantically) singular or plural.  The actual form used may be+--   different (see 'conceptNumber' because of deeper issues that+--   override this).+--+--   Consider one of the *dogs*; here the rx number is 'Singular'+--   — one dog — but on the surface we use the 'Plural' (the NP+--   'the dogs' is itself plural).  This discrepency is partly due+--   to the hacky way we've written this.  A cleaner implementation+--   would recursively realise 'the dogs' as a separate expression+--   with its own number.+subrxNumber :: DiscourseUnit -> FuzzyNumber+subrxNumber (Node rg _) =+    fromMaybe usualAgr (constrAgr bounds)+  where+    bounds  = rgBounds rg+    count   = Set.size (rgIdxes rg)+    usualAgr+        | isClasswide rg  = FN_Plural -- dog*s* like food+        | count == 1      = FN_MaybeSingular+        | otherwise       = FN_Plural+    -- TODO not sure if this really belongs here or more in the surface?+    constrAgr (Bounds [] l u) =+        case (l,u) of+           (Just 1, Nothing)  -> Just FN_Singular -- TODO hmm?+           (Just 1, Just 1)   -> Just FN_Singular+           (Nothing, Just 1)  -> Just FN_Singular -- TODO hmm?+           (Nothing, Nothing) -> Nothing+           _                  -> Just FN_Plural+    constrAgr (Bounds _ _ _) = Just FN_Plural++-- ----------------------------------------------------------------------+-- Discriminator+-- ----------------------------------------------------------------------++-- | Helper for 'fromConcept'+--+--   A discriminator is what we call the optional bit of text that helps+--   you distinguish one set instances of a class from another, eg,+--   “the same” or “another three”, or simply “the“+discriminate :: RefHistory   -- ^ discourse history+             -> DiscourseUnit+             -> Discriminator+discriminate st du@(Node rg _) =+    helper $ boundsText bounds+  where+    keys    = [ (rgClass rg, idx) | idx <- rgIdxList rg ]+    bounds  = rgBounds rg+    count   = Set.size (rgIdxes rg)+    --+    helper (Just bnds) = case keys of+        _ | lastMentions st du > 0             -> TheSame+          | otherwise                          -> Bounded bnds+    helper Nothing = case keys of+        [k] | isTheOther st k                  -> TheOther+        [mentionOrder st -> Just i]            -> TheOrdinal i+        [distractorGroups st -> ds@(_:_)]      -> NewOrdinal (1 + length ds) -- an 8th ant+        _   | isClasswide rg                   -> NilDiscriminator+            | any (hasDistractorGroup st) keys -> Another count+            | all (isFirstMention st)     keys -> PlainCardinal count+            | hasTidyBackpointer st du         -> CardinalOfThe count+            | lastMentions st du > 0           -> The+            | otherwise                        -> PlainCardinal count++-- ----------------------------------------------------------------------+-- determiners+-- ----------------------------------------------------------------------++-- | If there are any unknown constraints, we pick the first one.+--   Otherwise, we generate an expression appropriate for the lower/upper bounds+boundsText :: Bounds -> Maybe BoundsExpr+boundsText (Bounds [] l u)    =+    case (l,u) of+        (Nothing, Nothing)   -> Nothing+        (Nothing, Just x)    -> Just $ SayAtMost  x+        (Just x, Nothing)    -> Just $ SayAtLeast x+        (Just x1, Just x2)+           | x1 == x2        -> Just $ SayExactly x1+           | otherwise       -> Just $ SayBetween x1 x2+boundsText (Bounds (x:_) _ _) = Just $ SayArbitrary x
+ NLP/Antfarm/Refex.hs view
@@ -0,0 +1,163 @@+module NLP.Antfarm.Refex where++import Data.Maybe ( mapMaybe )+import Data.Text ( Text )+import Data.Tree ( Tree )+import qualified Data.Set as Set++import NLP.Minimorph.Number++import NLP.Antfarm.Cardinality++-- ----------------------------------------------------------------------+-- * Referring expressions+-- ----------------------------------------------------------------------++-- | Input needed to realise a subunit of a referring expression+--   A subunit corresponds to 'RefGroup' (but in practice,+--   we need the whole 'DiscourseUnit', not just the 'RefGroup'+--   root)+data SubRxInput = SubRxInput+    { srxInpDet    :: SingPlu [Text] -- ^ determiner (can be empty)+    , srxInpWord   :: SingPlu Text   -- ^ main word+    , srxInpEntity :: DiscourseUnit+    }++-- | Output for a subunit of a referring expression+data SubRx = SubRx+    { srxNumber        :: Number+    , srxDiscriminator :: Discriminator+    , srxDet           :: SingPlu [Text]+    , srxWord          :: SingPlu Text+    }+  deriving (Eq, Show)++-- | A single referring expression has subunits, each of which+--   potentially having examples+type RxInput = [Tree SubRxInput]++-- | A referring expression+type Rx = [Tree SubRx]++-- ----------------------------------------------------------------------+-- * Discourse units+-- ----------------------------------------------------------------------++-- | A discourse unit includes all instances and constraints needed+--   to uniquely identify it. (see note discourse tree)+--+--   In the current implementation, a referring expression may contain+--   more than one discourse unit.  So in a referring expression “three cats+--   and at most two dogs (a poodle and a labrador)”, the “at most two dogs+--   (a poodle and a labrador)” and “three cats” would each correspond to+--   different 'DiscourseUnit's+type DiscourseUnit = Tree RefGroup++-- | A sub-unit in a referring expression, instances of and/or constraints+--   over class.  So in a referring expression “three cats and at most two+--   dogs”, the “at most two dogs” and “three cats” would each be 'RefGroup's+data RefGroup = RefGroup+    { rgClass  :: Text+    , rgIdxes  :: Set.Set Text+    , rgBounds :: Bounds+    }+  deriving (Ord, Eq)++rgIdxList :: RefGroup -> [Text]+rgIdxList = Set.toList . rgIdxes++-- | A unique object+type RefKey      = (Text, Text)++-- ----------------------------------------------------------------------+-- * Bounds+-- ----------------------------------------------------------------------++data Bounds = Bounds+    { bUnknown :: [Text]+        --  the whole idea of unknown constraints makes me very+        --  unhappy; we want to pass through any malformed+        --  constraints as is, so for now the only thing I can+        --  think to do with them is collect them in the groups+        --  which just seems wrong+    , bLower   :: Maybe Int -- ^ lower+    , bUpper   :: Maybe Int -- ^ upper+    }+  deriving (Ord, Eq)++emptyBounds :: Bounds+emptyBounds = Bounds [] Nothing Nothing++explicitBounds :: [Constraint] -> Bounds+explicitBounds cs = Bounds+    { bUnknown = [ t | Unknown t <- cs ]+    , bLower   = maximum `orNothing` mapMaybe lowerBound cs+    , bUpper   = minimum `orNothing` mapMaybe upperBound cs+    }+  where+    orNothing _ [] = Nothing+    orNothing f xs = Just (f xs)++-- | When two 'Bounds' are combined the result is narrower: the highest low+--   and the lowest high.+--+--   The unknown bounds are not really defined.  We concatenate them, for+--   what it's worth, which is at least sensible when none or only one of+--   them is defined, but not ideal when both are+narrow :: Bounds -> Bounds -> Bounds+narrow b1 b2 =+   b1 { bUnknown = bUnknown b1 ++ bUnknown b2+      , bLower   = mergeWith max (bLower b1) (bLower b2)+      , bUpper   = mergeWith min (bUpper b1) (bUpper b2)+      }+  where+    mergeWith _ Nothing    Nothing = Nothing+    mergeWith _ x@(Just _) Nothing = x+    mergeWith _ Nothing x@(Just _) = x+    mergeWith f (Just x)  (Just y) = Just (f x y)++-- ----------------------------------------------------------------------+-- * Number+-- ----------------------------------------------------------------------++-- | Fuzzy number is a variant on 'Number' that allows us the option+--   of overriding what would otherwise be singular agreement+--+--   If you don't need to, or have no idea why somebody would even want+--   to do such a thing, just 'defuzz' it+data FuzzyNumber = FN_Plural+                 | FN_MaybeSingular+                 | FN_Singular+  deriving (Eq, Show)++-- | @defuzz@ treats 'FN_MaybeSingular' as 'Singular'+defuzz :: FuzzyNumber -> Number+defuzz FN_Plural        = Plural+defuzz FN_MaybeSingular = Singular+defuzz FN_Singular      = Singular++-- | Somewhat abstract representation of subrx discriminators+--   (but in reality just based on English)+--+--   A discriminator is what we call the optional bit of text that helps+--   you distinguish one set instances of a class from another, eg,+--   “the same” or “another three”, or simply “the“.  This isn't a+--   technical term as far as I'm aware, just a made-up convenience word+data Discriminator = NilDiscriminator+                   | Bounded BoundsExpr+                   | TheSame+                   | TheOther+                   | TheOrdinal    Int+                   | NewOrdinal    Int+                   | Another       Int+                   | PlainCardinal Int+                   | CardinalOfThe Int+                   | The+  deriving (Eq, Show)++data BoundsExpr = SayAtLeast Int+                | SayAtMost  Int+                | SayBetween Int Int+                | SayExactly Int+                | SayArbitrary Text+  deriving (Eq, Show)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ antfarm.cabal view
@@ -0,0 +1,60 @@+-- Initial antfarm.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                antfarm+version:             0.1.0.0+synopsis:            Referring expressions for definitions+-- description:+homepage:            http://hub.darcs.net/kowey/antfarm+license:             BSD3+license-file:        LICENSE+author:              Eric Kow+maintainer:          eric.kow@gmail.com+-- copyright:+category:            Natural language processing+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:   NLP.Antfarm+                     NLP.Antfarm.Cardinality+                     NLP.Antfarm.Demo+                     NLP.Antfarm.English+                     NLP.Antfarm.History+                     NLP.Antfarm.Internal+                     NLP.Antfarm.Refex++  build-depends:       base < 5+               ,       containers+               ,       minimorph >= 0.1.1+               ,       text+               --      Begin NLP.Antfarm.Demo only :-/+               ,       mtl+               ,       parsec+               ,       transformers+               --      End NLP.Antfarm.Demo only++executable antfarm+  main-is:             antfarm.hs+  hs-source-dirs:      antfarm+  -- other-modules:+  build-depends:       base < 5+               ,       antfarm+               ,       containers+               ,       minimorph+               ,       mtl+               ,       text+++test-suite antfarm-test+  type:             exitcode-stdio-1.0+  main-is:          antfarm-test.hs+  hs-source-dirs:   test+  build-Depends:    base+               ,    antfarm+               ,    HUnit+               ,    minimorph+               ,    test-framework+               ,    test-framework-hunit+               ,    text+               ,    transformers
+ antfarm/antfarm.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad ( when )+import Control.Monad.State+import Data.List ( delete )+import Data.Text ( Text )+import Data.Tree+import System.Environment+import qualified Data.Set  as Set+import qualified Data.Text as T++import NLP.Minimorph.Util++import NLP.Antfarm.Demo+import NLP.Antfarm++main :: IO ()+main = do+  (verbose, args) <- do+      { as <- getArgs+      ; if "--verbose" `elem` as+           then return (True, delete "--verbose" as)+           else return (False, as)+      }+  case decode (unwords args) of+      Left err  -> fail $ "Did't understand the input: " ++ show err+      Right rxs ->+         let inps    = T.splitOn "," (T.pack (unwords args)) -- YUCK, duplication+             annoRxs = if length inps == length rxs+                          then zip inps rxs+                          else error "Argh, we wrote the antfarm parser wrong (length mismatch)"+         in putStr . T.unpack $ refexGen verbose annoRxs+++refexGen :: Bool -> [(Text,[DiscourseUnit])] -> Text+refexGen verbose annoRxs =+    T.unlines $ output : details+  where+    rxs     = map snd annoRxs+    output  = T.intercalate ", " results+    results = evalState (mapM nextRx rxs) emptyHistory+    details = if verbose+                 then zipWith showDetails annoRxs results+                 else []++showDetails :: (Text, [DiscourseUnit]) -> Text -> Text+showDetails (x,dus) rx = T.intercalate "\t"+    [ T.strip x+    , T.intercalate "; " (map prettyTree dus)+    , rx+    ]
+ test/antfarm-test.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Applicative+import System.Exit++import Test.HUnit+import Test.Framework.Providers.HUnit+import Test.Framework++import qualified NLP.AntfarmTest++main :: IO ()+main = defaultMain+    [ NLP.AntfarmTest.suite+    ]