{-
 *  SAD / Alice / FOL -- parser module for plain first-order texts
 *  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 FOL (fol) where

import Control.Monad (liftM,liftM2,guard,unless)
import Data.Char (toLower)

import Text
import Parser
import State

-- First-order text

fol :: FTL [Block]
fol = narrow $ space () >> topsimp

topsimp = u1 -/- u2 -/- u4
  where
    tps = u1 -/- u2 -/- u3
    u1  = liftM2 (:) formula tps
    u2  = char ':' >> readEOI >> contra
    u3  = readEOI >> return []
    u4  = readEOI >> fail "no input"

formula = do  ty <- (char ':' >> return Affi) -/- return Assu
              l <- reset; f <- iff_form; char '.'; t <- getSTask
              let e = wf (free f) f in unless (null e) (lfail l e)
              liftM (Block f [] [] ty t l "" [] 0) getTxt

contra  = do  l <- reset; t <- getSTask
              return [Block zFalse [] [] Affi t l "" [] 0 "contradiction"]

-- Binary formulas

iff_form  = bi_form imp_form imp_form iff_op Iff id
imp_form  = bi_form dis_form imp_form imp_op Imp id
dis_form  = bi_form con_form dis_form dis_op Or  id
con_form  = bi_form dot_form con_form con_op And id

-- Grouping: parentheses and Church's dot

dot_form  = (char '.' >> iff_form) -/- par_form
par_form  = (char '(' >> after iff_form (char ')')) -/- all_form

-- Quantifiers

all_form  = (all_op >> qu_head All) -/- exi_form
exi_form  = (exi_op >> qu_head Exi) -/- neg_form
qu_head o = do  vs <- com_seq sym; f <- dot_form
                return $ foldr (o . Var) f vs

-- Unary formulas

neg_form  = (neg_op >> liftM Not dot_form) -/-
            (word "true"  >> return zTrue) -/-
            (word "false" >> return zFalse) -/- equ_form

equ_form  =
    do  t <- sin_term; o <- equ_op -/- return '_'
        case o of
          '=' -> liftM (zEqu t) sin_term
          '!' -> liftM (Not . zEqu t) sin_term
          _   -> return $ case t of Var v -> Trm v [] ; _ -> t

sin_term  = bi_form sym seq_term (char '(') Trm Var
seq_term  = after (com_seq sin_term) (char ')')

sym = do  s <- readWord; let ss = map toLower s
          guard (ss `notElem` opers); space s

-- Service stuff

bi_form lf rf op cn cm =
    do  f <- lf; o <- op -/- return '_'
        case o of '_' -> return $ cm f
                  _   -> liftM (cn f) rf

com_seq p = bi_form p (com_seq p) (char ',') (:) (:[])

iff_op  = char '~' -/- (word "iff" >> return '~')
imp_op  = char '>' -/- (word "implies" >> return '>')
dis_op  = char '|' -/- (word "or" >> return '|')
con_op  = char '&' -/- (word "and" >> return '&')
neg_op  = char '-' -/- (word "not" >> return '-')
all_op  = char '@' -/- (word "forall" >> return '@')
exi_op  = char '$' -/- (word "exists" >> return '$')
equ_op  = char '=' -/- (char '!' >> char '=' >> return '!')

opers = ["iff", "implies", "or", "and", "not", "forall", "exists", "true", "false"]

