{-
 *  SAD / Alice / TPTP -- parser for TPTP problems with axioms included
 *  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 TPTP (tptp) where

import Control.Monad (liftM,liftM2,guard,unless)
import Data.Char (isUpper)
import Data.Maybe (fromJust)

import Text
import Parser
import State

tptp :: FTL [Block]
tptp = narrow $ space () >> liftM2 conj contra toptptp
  where
    conj g (b:bs) | blType b == Assu  = b : conj g bs
                  | null (blMark g)   = conj b bs
                  | otherwise         = conj f bs
      where
        h = Or (blForm g) (blForm b)
        f = Block h [] [] Affi Prov (blLine b) (blMark g) [] 0 (show h)

    conj g [] = [g]


toptptp = u1 -/- u2 -/- u3 -/- u5
  where
    tpt = u1 -/- u2 -/- u3 -/- u4
    u1  = liftM2 (:) t_frm tpt
    u2  = liftM2 (:) t_cls tpt
    u3  = include >> return []
    u4  = readEOI >> return []
    u5  = readEOI >> fail "no input"

t_frm   = do  l <- reset; word "input_formula"; char '('; s <- token readWord
              char ','; k <- wordOf ["axiom","hypothesis","conjecture"]
              let { ty = if head k == 'c' then Affi else Assu }; char ','
              f <- formula >>= norm []; char ')'; char '.'
              let e = wf (free f) f in unless (null e) (lfail l e)
              return $ Block f [] [] ty Prov l s [] 0 (show f)

t_cls   = do  l <- reset; word "input_clause"; char '('; s <- token readWord
              char ','; k <- wordOf ["axiom","hypothesis","conjecture"]
              let { ty = if head k == 'c' then Affi else Assu }; char ','
              char '['; f <- claus (ty == Assu); char ']'; char ')'; char '.'
              return $ Block f [] [] ty Prov l s [] 0 (show f)

include = do  l <- reset; word "include"; char '('; char_ '\''; word_ "axioms"
              char_ '/'; dn <- readWord; c <- charOf_ ['+','-']; v <- readWord
              char_ '.'; ex <- wordOf_ ["ax", "eq"]; char '\''; char ')'; char '.'
              lfail l $ "the axioms " ++ dn ++ c:v ++ '.':ex ++ " are inaccessible"

contra  = do  l <- reset
              return $ Block zFalse [] [] Affi Prov l "" [] 0 "contradiction"

claus h = do  ls <- chain (char ',') (pls -/- mns)
              let t = if h then zTrue else zFalse
                  f = foldr1 (if h then Or else And) ls
                  g = foldr (if h then All else Exi) f (free f)
              return $ if null ls then t else g
  where
    pls = string "++" >> (if h then tatm else liftM Not tatm)
    mns = string "--" >> (if h then liftM Not tatm else tatm)

formula = do  f <- un_formula; binTail f -/- return f

binTail f = iff -/- xor -/- imp -/- pmi -/- or -/- nor -/- and -/- nan
  where
    iff = liftM (Iff f) $ string "<=>" >> formula
    xor = liftM (Not . Iff f) $ string "<~>" >> formula
    imp = liftM (Imp f) $ string "=>" >> formula
    pmi = liftM (\ g -> Imp g f) $ string "<=" >> formula
    or  = liftM (Or f) $ string "|" >> formula
    nor = liftM (Not . Or f) $ string "~|" >> formula
    and = liftM (And f) $ string "&" >> formula
    nan = liftM (Not . And f) $ string "~&" >> formula

un_formula  = uqu -/- equ -/- neg -/- par -/- tatm
  where
    uqu = do  char '!'; char '['; vs <- chain (char ',') tvr
              char ']'; char ':'; f <- un_formula
              return $ foldr All f vs

    equ = do  char '?'; char '['; vs <- chain (char ',') tvr
              char ']'; char ':'; f <- un_formula
              return $ foldr Exi f vs

    neg = liftM Not $ char '~' >> un_formula

    par = char '(' >> after formula (char ')')

tatm = liftM2 Trm sym (u1 -/- u2 -/- return [])
  where
    u1  = expar $ return []
    u2  = expar $ chain (char ',') (expar arg -/- arg)
    arg = tatm -/- tvr

    expar p = char '(' >> after p (char ')')

tvr = do  v@(c:_) <- readWord; guard (isUpper c); space (Var v)

sym = do  s@(c:_) <- readWord; guard (not $ isUpper c)
          space $ if s == "equal" then "=" else s


-- Service stuff

norm vs (All v@(Var x) f) | v `elem` vs =
                              do  Var h <- hidden; let u = Var (x ++ h)
                                  liftM (All u . subst u v) (norm vs f)
                          | otherwise   = liftM (All v) (norm (v:vs) f)
norm vs (Exi v@(Var x) f) | v `elem` vs =
                              do  Var h <- hidden; let u = Var (x ++ h)
                                  liftM (Exi u . subst u v) (norm vs f)
                          | otherwise   = liftM (Exi v) (norm (v:vs) f)
norm _ f@(Trm _ _)  = return f
norm vs f           = mapFM (norm vs) f

