module NLP.GenI.Semantics where
import Control.Applicative ((<$>))
import Control.Arrow (first, (&&&), (***))
import Control.DeepSeq
import Control.Monad.Error
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.Text (Text)
import qualified Data.Text as T
import Control.Error
import NLP.GenI.FeatureStructure
import NLP.GenI.General (histogram)
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 $ 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 $ 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)