module NLP.GenI.Semantics where
import Control.Applicative ((<$>))
import Control.Arrow (first, (&&&), (***))
import Control.DeepSeq
import Control.Monad.Except
import Data.Binary
import Data.Data
import Data.Function (on)
import Data.List (delete, insert, nub, sortBy)
import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import NLP.GenI.FeatureStructure
import NLP.GenI.General (histogram, hush)
import NLP.GenI.GeniShow
import NLP.GenI.GeniVal
import NLP.GenI.Pretty
data Literal gv = Literal
{
lHandle :: gv
, lPredicate :: gv
, lArgs :: [gv]
}
deriving (Eq, Data, Typeable)
instance Ord gv => Ord (Literal gv) where
compare = compare `on` tucked
where
tucked l = (lPredicate l, lHandle l : lArgs l)
type Sem = [Literal GeniVal]
type LitConstr = (Literal GeniVal, [Text])
type SemInput = (Sem,Flist GeniVal,[LitConstr])
instance Collectable a => Collectable (Literal a) where
collect (Literal a b c) = collect a . collect b . collect c
emptyLiteral :: Literal GeniVal
emptyLiteral = Literal mkGAnon mkGAnon []
removeConstraints :: SemInput -> SemInput
removeConstraints (x, _, _) = (x, [], [])
sortSem :: Ord a => [Literal a] -> [Literal a]
sortSem = sortBy compareOnLiteral
compareOnLiteral :: Ord a => Literal a -> Literal a -> Ordering
compareOnLiteral = compare
sortByAmbiguity :: Sem -> Sem
sortByAmbiguity sem =
sortBy (flip compare `on` criteria) sem
where
criteria = (constants &&& ambiguity)
ambiguity l = fromMaybe 0 $ do
p <- boringLiteral l
negate <$> Map.lookup p (literalCount sem)
literalCount = histogram . mapMaybe boringLiteral
boringLiteral = singletonVal . lPredicate
class HasConstants a where
constants :: a -> Int
instance HasConstants GeniVal where
constants g = if isConst2 g then 1 else 0
where
isConst2 :: GeniVal -> Bool
isConst2 x = isJust (gConstraints x) && isNothing (gLabel x)
instance HasConstants a => HasConstants [a] where
constants = sum . map constants
instance HasConstants (Literal GeniVal) where
constants (Literal h p args) = constants (h:p:args)
instance DescendGeniVal a => DescendGeniVal (Literal a) where
descendGeniVal s (Literal h n lp) = Literal (descendGeniVal s h)
(descendGeniVal s n)
(descendGeniVal s lp)
instance Pretty Sem where
pretty = geniShowText
instance GeniShow Sem where
geniShowText = squares . T.unwords . map geniShowText
instance Pretty (Literal GeniVal) where
pretty = geniShowText
instance GeniShow (Literal GeniVal) where
geniShowText (Literal h p l) =
mh `T.append` geniShowText p
`T.append` (parens . T.unwords . map geniShowText $ l)
where
mh = if hideh h then "" else geniShowText h `T.snoc` ':'
hideh = maybe False isInternalHandle . singletonVal
instance Pretty SemInput where
pretty = geniShowText
instance GeniShow SemInput where
geniShowText = displaySemInput (T.unwords . map geniShowText)
instance GeniShow LitConstr where
geniShowText (sem, []) = geniShowText sem
geniShowText (sem, cs) = geniShowText sem <> squares (T.unwords cs)
displaySemInput :: ([LitConstr] -> Text) -> SemInput -> Text
displaySemInput dispLits (sem, icons, lcons) =
T.intercalate "\n" . concat $
[ [semStuff]
, [ idxStuff | not (null icons) ]
]
where
semStuff = geniKeyword "semantics"
. squares . dispLits
$ map withConstraints sem
idxStuff = geniKeyword "idxconstraints"
. squares
$ geniShowText icons
withConstraints lit =
(lit, concat [ cs | (p,cs) <- lcons, p == lit ])
isInternalHandle :: Text -> Bool
isInternalHandle = ("genihandle" `T.isPrefixOf`)
subsumeSem :: Sem -> Sem -> [(Sem,Subst)]
subsumeSem x y | length x > length y = []
subsumeSem x y =
map (first sortSem) $ subsumeSemH x y
subsumeSemH :: Sem -> Sem -> [(Sem,Subst)]
subsumeSemH [] [] = [ ([], Map.empty) ]
subsumeSemH _ [] = error "subsumeSemH: got longer list in front"
subsumeSemH [] _ = [ ([], Map.empty) ]
subsumeSemH (x:xs) ys = nub $
do let attempts = zip ys $ map (hush . subsumeLiteral x) ys
(y, Just (x2, subst)) <- attempts
let next_xs = replace subst xs
next_ys = replace subst $ delete y ys
prepend = insert x2 *** appendSubst subst
prepend `fmap` subsumeSemH next_xs next_ys
subsumeLiteral :: MonadUnify m
=> Literal GeniVal
-> Literal GeniVal
-> m (Literal GeniVal, Subst)
subsumeLiteral l1@(Literal h1 p1 la1) l2@(Literal h2 p2 la2) =
if length la1 == length la2
then do let hpla1 = h1:p1:la1
hpla2 = h2:p2:la2
(hpla, sub) <- hpla1 `allSubsume` hpla2
return (toLiteral hpla, sub)
else throwError $ T.unpack
$ pretty l1 <+> "does not subsume" <+> pretty l2 <+>
"because they don't have the same arity"
where
toLiteral (h:p:xs) = Literal h p xs
toLiteral _ = error "subsumeLiteral.toLiteral"
unifySem :: Sem -> Sem -> [(Sem,Subst)]
unifySem xs ys =
map (first sortSem) $
if length xs < length ys
then unifySemH xs ys
else unifySemH ys xs
unifySemH :: Sem -> Sem -> [(Sem,Subst)]
unifySemH [] [] = return ([], Map.empty)
unifySemH [] xs = return (xs, Map.empty)
unifySemH xs [] = error $ "unifySem: shorter list should always be in front: " ++ prettyStr xs
unifySemH (x:xs) ys = nub $ do
let attempts = zip ys $ map (hush . unifyLiteral x) ys
if all (isNothing . snd) attempts
then first (x:) `fmap` unifySemH xs ys
else do (y, Just (x2, subst)) <- attempts
let next_xs = replace subst xs
next_ys = replace subst $ delete y ys
prepend = insert x2 *** appendSubst subst
prepend `fmap` unifySemH next_xs next_ys
unifyLiteral :: MonadUnify m
=> Literal GeniVal
-> Literal GeniVal -> m (Literal GeniVal, Subst)
unifyLiteral l1@(Literal h1 p1 la1) l2@(Literal h2 p2 la2) =
if length la1 == length la2
then do let hpla1 = h1:p1:la1
hpla2 = h2:p2:la2
(hpla, sub) <- hpla1 `unify` hpla2
return (toLiteral hpla, sub)
else throwError $ T.unpack
$ pretty l1 <+> "does not unify with" <+> pretty l2 <+>
"because they don't have the same arity"
where
toLiteral (h:p:xs) = Literal h p xs
toLiteral _ = error "unifyLiteral.toLiteral"
instance NFData g => NFData (Literal g) where
rnf (Literal x1 x2 x3) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` ()
instance Binary g => Binary (Literal g) where
put (Literal x1 x2 x3)
= do put x1
put x2
put x3
get
= do x1 <- get
x2 <- get
x3 <- get
return (Literal x1 x2 x3)