diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/NLP/Antfarm.hs b/NLP/Antfarm.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm.hs @@ -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 diff --git a/NLP/Antfarm/Cardinality.hs b/NLP/Antfarm/Cardinality.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/Cardinality.hs @@ -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 diff --git a/NLP/Antfarm/Demo.hs b/NLP/Antfarm/Demo.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/Demo.hs @@ -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) diff --git a/NLP/Antfarm/English.hs b/NLP/Antfarm/English.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/English.hs @@ -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"] diff --git a/NLP/Antfarm/History.hs b/NLP/Antfarm/History.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/History.hs @@ -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 diff --git a/NLP/Antfarm/Internal.hs b/NLP/Antfarm/Internal.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/Internal.hs @@ -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 diff --git a/NLP/Antfarm/Refex.hs b/NLP/Antfarm/Refex.hs new file mode 100644 --- /dev/null +++ b/NLP/Antfarm/Refex.hs @@ -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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/antfarm.cabal b/antfarm.cabal new file mode 100644 --- /dev/null +++ b/antfarm.cabal @@ -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 diff --git a/antfarm/antfarm.hs b/antfarm/antfarm.hs new file mode 100644 --- /dev/null +++ b/antfarm/antfarm.hs @@ -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 + ] diff --git a/test/antfarm-test.hs b/test/antfarm-test.hs new file mode 100644 --- /dev/null +++ b/test/antfarm-test.hs @@ -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 + ]