{-
 *  SAD / Alice / Phrase -- subparser for ForTheL sentences
 *  Copyright (C) 2001-2004  SAD Development Team (see ../README)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License along
 *  with this program; if not, write to the Free Software Foundation, Inc.,
 *  59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 -}

module Phrase where

import Control.Monad (liftM,liftM2,liftM3,unless)

import Text
import Parser
import State

-- Definition grammar (special statement)

definition  = def_prd -|- def_fun -|- def_ntn

def_prd = liftM2 def frm (word "iff" >> statement)
  where
    frm = ver -|- adj -|- uvr -|- uad -|- ipr -|- ppr
    ppr = prim_ppr variable
    ipr = liftM2 substH var $ prim_ipr variable
    ver = liftM2 substH var $ liftM snd $ prim_ver variable
    adj = liftM2 substH var $ liftM snd $ is >> prim_adj variable
    uvr = do  v <- var; comma_op; u <- var
              (_, f) <- prim_m_ver variable
              return $ substH v $ subst u zHoleMS f
    uad = do  v <- var; comma_op; u <- var
              (_, f) <- is >> prim_m_adj variable
              return $ substH v $ subst u zHoleMS f
    def l r = Iff (Ann DHD l) r

def_fun = do  l <- frm; is; v <- hidden; ieq_atom >>= def l v
  where
    frm = fun -|- ifn -|- pfn
    fun = liftM snd $ the >> prim_fun variable
    ifn = liftM2 substH var $ prim_ifn variable -|- prim_rfn variable
    pfn = prim_cfn variable -|- prim_lfn variable -|- prim_ufn variable

    def l _ (Var _, Ann DIG (Trm "=" [_, t])) = return (Ann DHD $ zEqu l t)
    def l v (q, f) = liftM prep (dig [v] f)
      where
        prep g = All v $ Iff (Ann DHD $ zEqu v l) $ subv $ substH g q
        subv g@(Trm _ _) | g == l = v ; subv g = mapF subv g

def_ntn = do  an; (_, n, v:vs) <- prim_ntn variable
              unless (null vs) $ ntfail "inadmissible multinamed notion"
              is; (q, f) <- isa_atom; g <- dig [v] f
              return $ All v $ Iff (Ann DHD $ substH v n) (substH g q)


-- Statement grammar

statement = headed -|- (aon_chain atomic >>= stail)

headed  = u1 -|- u2 -|- u3
  where
    u1  = do  word "if"; x <- statement; word "then"
              y <- statement; return (Imp x y)
    u2  = do  wrong; x <- statement; return (Not x)
    u3  = do  word "for"; q <- comma qu_notion
              x <- statement; return (qchain x q)

stail x = opt x (u1 -|- u2 -|- u3 -|- u4)
  where
    u1  = word "and" >> liftM (And x) headed
    u2  = word "or"  >> liftM (Or x)  headed
    u3  = word "iff" >> liftM (Iff x) statement
    u4  = do  wordOf ["when","where"]; y <- statement
              return $ foldr All (Imp y x) (decl [] y)

atomic  = atom -|- thereis -|- (wehve >> (sym_stat -|- thesis))

thesis  = u1 -|- u2 -|- u3
  where
    u1  = the >> word "thesis" >> getThes
    u2  = the >> word "contrary" >> liftM Not getThes
    u3  = an  >> word "contradiction" >> return zFalse

thereis = there >> (u1 -|- u2)
  where
    u1  = do  word "no"; (q, f, v) <- notion
              return $ Not (foldr Exi (substH f q) v)
    u2  = liftM hchain $ comma (opt [] an >> notion)

    hchain [(q, f, v)]    = foldr Exi (substH f q) v
    hchain ((q, f, v):ns) = foldr Exi (substH f q `And` hchain ns) v

choostt = liftM hchain $ comma (opt [] an >> notion)
  where
    hchain [(q, f, v@[Var ('x':'_':_)])]
        = foldr Exi (substH f q) v
    hchain [(q, f, _)] = substH f q
    hchain ((q, f, v@[Var ('x':'_':_)]):ns)
        = foldr Exi (substH f q `And` hchain ns) v
    hchain ((q, f, _):ns) = substH f q `And` hchain ns


-- Symbolic formula

sym_stat  = liftM2 qchain s_formula $ opt [] (word "for" >> comma qu_notion)

s_formula = liftM dedot s_iff
  where
    s_iff = s_imp >>= bin_f s_imp (string "<=>") Iff
    s_imp = s_dis >>= bin_f s_imp (string "=>")  Imp
    s_dis = s_con >>= bin_f s_dis (string "\\/") Or
    s_con = s_neg >>= bin_f s_con (string "/\\") And
    s_neg = s_qua -|- (word "not" >> liftM (app_r Not) s_neg)
    s_qua = s_atm -|- (word "forall" >> q_qua All Imp >>= q_app)
                  -|- (word "exists" >> q_qua Exi And >>= q_app)

    s_atm = s_prf -|- s_inf -|- expar statement
    s_prf = prim_ppr s_term
    s_inf = do  s <- comma i_term; p <- prim_ipr s_term; dig s (Ann DIG p)

    q_qua q c = do (_, f, v) <- snotion; return $ \ g -> foldr q (c f g) v

    q_app fn  = liftM (app_r fn) $ s_neg -|-
                      (char ':' >> liftM (Ann DOT) s_formula)

    bin_f _ _ _ f@(Ann DOT _) = return f
    bin_f rf op cn f  = opt f $ op >> liftM (app_r $ cn f) rf

    app_r c (Ann DOT g) = Ann DOT $ c g  ;  app_r c g = c g

    dedot (Ann DOT f) = f  ;  dedot f = f


-- Atomic grammar

atom :: FTL Formula
atom  = do  (q, ts) <- term_seq
            p <- and_chain does_literal >>= dig ts
            c <- opt [] (word "for" >> comma qu_notion)
            return $ substH (qchain p c) q

does_literal  = u1 -|- u2 -|- u3 -|- u4
  where
    u1  = does >> literal prim_ver
    u2  = does >> m_literal prim_m_ver
    u3  = has >> has_literal
    u4  = is >> and_chain (isa_literal -|- is_literal)

is_literal  = u1 -|- u2 -|- u3
  where
    u1  = literal prim_adj
    u2  = m_literal prim_m_adj
    u3  = with >> has_literal

isa_literal = u1 -|- u2
  where
    u1  = do  (q, f) <- ieq_atom; return $ substH f q
    u2  = do  word "not"; (q, g) <- ieq_atom
              let unf = liftM (Ann DIG . Not) (dig [zHole] g)
              f <- unf -/- return (Not g); return $ substH f q

ieq_atom  = isa_atom -|- equ_atom
isa_atom  = do  opt [] an; (q, f, _) <- anotion; return (q, f)
equ_atom  = do  (q, t) <- nn_term; return (q, Ann DIG $ zEqu zHole t)

has_literal = u1 -|- u2 -|- u3 -|- u4
  where
    u1  = liftM (Ann DIG . hchain) (comma $ opt [] art >> attrib)
    u2  = word "common" >> liftM hchain (comma $ opt [] art >> attrib')
    u3  = do  word "no"; (q, f, v) <- attrib
              return $ substH (Ann DIG (Not (foldr Exi f v))) q
    u4  = do  word "no"; word "common"; (q, f, v) <- attrib
              return $ substH (Not (foldr Exi (Ann DIG f) v)) q

    hchain [(q, f, v)]    = substH (foldr Exi f v) q
    hchain ((q, f, v):ns) = substH (foldr Exi (And f $ hchain ns) v) q
    attrib' = do (q, f, v) <- attrib; return (q, Ann DIG f, v)

literal p   = positive p  -|- (word "not" >> negative p)
m_literal p = mpositive p -|- (word "not" >> mnegative p)
mpositive p = spositive p -|- (word "pairwise" >> ppositive p)
mnegative p = snegative p -|- (word "pairwise" >> pnegative p)

positive p  = do  (q, f) <- p term; return $ substH (Ann DIG f) q
spositive p = do  (q, f) <- p term; return $ substH (Ann DMS f) q
ppositive p = do  (q, f) <- p term; return $ substH (Ann DMP f) q

negative p  = do  (q, f) <- p term; return $ substH (Ann DIG $ Not f) q
snegative p = do  (q, f) <- p term; return $ substH (Not $ Ann DMS f) q
pnegative p = do  (q, f) <- p term; return $ substH (Not $ Ann DMP f) q


-- Notion grammar

anotion :: FTL Notion
anotion = u1 -|- u2 -|- u3
  where
    u1  = do a <- positive prim_un_adj; anotion >>= apl a
    u2  = do a <- mpositive prim_m_un_adj; anotion >>= apl a
    u3  = do n <- prim_ntn term >>= m2s; opt n $ ra >>= apr n

    m2s (q, f, [v]) = return (q, Ann DIG f, v)
    m2s _ = ntfail "inadmissible multinamed notion"

    apl a (q, f, v) = return (q, And f a, v)
    apr (q, f, v) a = return (q, And f (subst zHole v a), v)

    ra  = ra1 -|- ra2 -|- ra3
    ra1 = such >> that >> liftM (Ann DIG) statement
    ra2 = that >> and_chain does_literal
    ra3 = and_chain is_literal

notion :: FTL MNotion
notion = u1 -|- u2 -|- u3
  where
    u1  = do a <- positive prim_un_adj; notion >>= app a
    u2  = do a <- mpositive prim_m_un_adj; notion >>= app a
    u3  = ((prim_ntn term >>= dgn) -|- snotion) >>= rattr app
    dgn (q, f, v)   = do  p <- dig v (Ann DIG f); return (q, p, v)
    app a (q, f, v) = do  p <- dig v a; return (q, And f p, v)

attrib :: FTL MNotion
attrib  = u1 -|- u2 -|- u3
  where
    u1  = do a <- positive prim_un_adj; attrib >>= app a
    u2  = do a <- mpositive prim_m_un_adj; attrib >>= app a
    u3  = (prim_un_ntn term -|- prim_un_fun term) >>= rattr app
    app a (q, f, v) = do  p <- dig v a; return (q, And f p, v)

rattr app n  = opt n $ (u1 -|- u2 -|- u3) >>= flip app n
  where
    u1  = such >> that >> statement
    u2  = that >> and_chain does_literal
    u3  = and_chain is_literal

snotion :: FTL MNotion
snotion = paren $ do  v <- comma var; f <- prim_int s_term
                      g <- dig v (Ann DIG f); return (zHole, g, v)

-- Term grammar

term_seq :: FTL MTerm
term_seq  = do  (q, ts) <- qu_notion -|- liftM s2m nn_term
                (q', ts') <- opt (zHole, []) (comma_op >> term_seq)
                return (substH q' q, ts ++ ts')
  where
    s2m (q, t) = (q, [t])

qu_notion :: FTL MTerm
qu_notion = paren (fa -|- ex -|- no)
  where
    fa  = do  wordOf ["every", "each", "all", "any"]; (q, f, v) <- notion
              return (substH (foldr All (Imp f zHole) v) q, v)

    ex  = do  word "some"; (q, f, v) <- notion
              return (substH (foldr Exi (And f zHole) v) q, v)

    no  = do  word "no"; (q, f, v) <- notion
              return (substH (foldr All (Imp f (Not zHole)) v) q, v)

term :: FTL Term
term  = (qu_notion >>= m2s) -|- nn_term
  where
    m2s (q, [v]) = return (q, v)
    m2s _ = ntfail "inadmissible multinamed notion"

nn_term   = s_term -|- paren (opt [] the >> prim_fun term)

fo_term   = s_term -|- paren (opt [] the >> prim_fun fo_term)

s_term    = liftM ((,) zHole) i_term

i_term    = l_term >>= i_tl
  where
    c_term  = var -|- expar i_term -|- prim_cfn s_term

    r_term  = c_term >>= r_tl
    r_tl t  = opt t $ liftM (substH t) (prim_rfn s_term) >>= r_tl

    l_term  = r_term -|- prim_lfn s_term
              -|- prim_ufn (liftM ((,) zHole) l_term)

    i_tl t  = opt t $ liftM (substH t) (prim_ifn s_term)

variable  = do  v <- var; return (zHole, v)


-- Digger

dig ts  (Ann DIG f) = return $ digS ts f
dig [_] (Ann DMS _) = fail "too few subjects for an m-predicate"
dig ts  (Ann DMS f) = return $ foldr1 And $ map (apMS f) $ zip ts (tail ts)
dig [_] (Ann DMP _) = fail "too few subjects for an m-predicate"
dig ts  (Ann DMP f) = return $ foldr1 And $ map (apMS f) $ pairMP ts
dig ts  f@(Trm _ _) = return f
dig ts  f = mapFM (dig ts) f

digS ts (And f g) = And (digS ts f) (digS ts g)
digS ts f = if zHole `notElem` free f then f else
              foldr1 And $ map (flip substH f) ts

apMS f (x, y) = substH x $ subst y zHoleMS f

pairMP (t:ts) = map (\ y -> (t, y)) ts ++ pairMP ts
pairMP _ = []


-- Chains

aon_chain :: FTL Formula -> FTL Formula
aon_chain p = (do f <- p; opt f (ao f)) -|- (word "neither" >> nr)
  where
    ao f  = liftM (foldl And f) (op_tail (word "and") p)
        -|- liftM (foldl Or  f) (op_tail (word "or")  p)
    nr    = liftM (foldl1 And . map Not) (chain (word "nor") p)

and_chain :: FTL Formula -> FTL Formula
and_chain = liftM (foldl1 And) . chain (word "and")

qchain :: Formula -> [MTerm] -> Formula
qchain = foldr (\ (l, _) r -> substH r l)


-- Service stuff

paren p = p -|- expar p
expar p = char '(' >> after p (char ')')
exbrk p = char '[' >> after p (char ']')
exbrc p = char '{' >> after p (char '}')

comma     = chain comma_op
comma_op  = word "and" -|- (char ',' >> return "and")

an    = wordOf ["a", "an"]
the   = wordOf ["the"]
art   = wordOf ["a", "an", "the"]
is    = wordOf ["is", "be", "are"]
has   = wordOf ["has", "have"]
with  = wordOf ["with", "of", "having"]
such  = wordOf ["such", "so"]
that  = wordOf ["that"]
does  = opt [] $ wordOf ["does", "do"]
wehve = opt [] $ word "we" >> word "have"
wrong = mapM_ word ["it","is","wrong","that"]
there = word "there" >> (is -|- wordOf ["exists", "exist"])

