{-
 *  SAD / Alice / ForTheL -- parser module for ForTheL 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 ForTheL (forthel) where

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

import Text
import Parser
import State
import Phrase
import Reason
import Intro

-- Top-level grammar

forthel :: FTL [Block]
forthel = narrow $ space () >> topfort

topfort = u1 -/- u2 -/- u3 -/- u5
  where
    tpf = u1 -/- u2 -/- u3 -/- u4
    u1  = liftM2 (:) (axiom  -/- definit) tpf
    u2  = liftM2 (:) (prpaff -/- theorem) tpf
    u3  = (intro   -/- dTask) >> tpf
    u4  = (readEOI -/- dExit) >> return []
    u5  = readEOI >> fail "no input"

axiom   = topsect Assu axm axmaff
theorem = topsect Affi thm prpaff
definit = topsect Defn def define

topsect k h p = do  l <- reset; m <- h; z <- getTxt
                    bs <- level tps; d <- getDpth; t <- getTask
                    return $ Block zHole bs [] k t l m [] d z
  where
    tps = u1 -/- u2 -/- (dTask >> tps)
    u1  = liftM2 (:) assume tps
    u2  = liftM (:[]) p


-- Affirmations with(out) a proof. Postprocess induction proofs.

data Scheme = Nul | Raw | Ind Formula | InS deriving (Eq,Show)

prpaff = do  m <- shw; b <- affirm; p <- phdr m; method p b
  where phdr Nul = prf ; phdr m = return m

method Nul b  = return b

method Raw b  = level $ do  setGoal b; setThes (bdot [] $ blForm b)
                            bs <- prftext; return b { blProf = bs }
  where
    bdot vs (All (Var v) f) = All (Var ('t':'_':v)) $ bdot (v:vs) f
    bdot vs (Exi (Var v) f) = Exi (Var ('t':'_':v)) $ bdot (v:vs) f
    bdot vs (Var v) | v `elem` vs = Var ('t':'_':v)
    bdot vs f = mapF (bdot vs) f

method InS b@(Block { blForm = All v@(Var _) _ }) = method (Ind v) b
method InS _  = fail "invalid induction thesis"

method (Ind t) bl@(Block { blForm = f, blDecl = dvs }) =
    do  ih <- getIH t f ; nb <- method Raw bl
        np <- insIH ih (blProf nb); return nb { blProf = np }
  where
    ft = free t ; ivar (Var x) = Var ('i':'_':x)

    getIH nt (All v f)  = let i = ivar v ; isub = subst i v
                          in  liftM (All i) $ getIH (isub nt) (isub f)
    getIH nt (Imp g f)      = liftM (Imp g) $ getIH nt f
    getIH nt f  | good nt   = return $ Imp (zLess nt t) f
                | otherwise = fail "invalid induction thesis"

    good (Trm _ ts) = and (map good ts)
    good (Var ('i':'_':_)) = True
    good v = v `elem` dvs

    insIH ih pr@(b : bs)
      | blType b == Chos && or (map (`elem` declB b) ft) = insIH ih []
      | or (map (`notElem` blDecl b) ft) = liftM (b :) $ insIH ih bs
      | otherwise = return $ b { blForm = ih, blProf = [],
                                    blType = Assu, blMark = "IH" } : pr
    insIH _ _ = fail "invalid induction proof"


-- Proof sections, motivated (prftext) or not (frmtext)

prftext = lowtext True
frmtext = lowtext False

lowtext mot = ptx
  where
    ptx = u1 -/- u2 -/- u3 -/- u4 -/- u5 -/- (dTask >> ptx) -/- (qed >> ptl)
    phd = u1 -/- u2 -/- u3 -/- u4 -/- u5 -/- (dTask >> phd)

    u1  = do  st <- getState id; a <- assume
              let (th, m) = chip (blDecl a) (blForm a) (stThes st)
              setThes th; if (m || not mot) then liftM (a:) phd else
                do  bs <- level frmtext
                    when (null bs) $ fail "unexpected end of proof"
                    t <- getTask; setState $ \ _ -> st { stTask = t }
                    let nbs = a { blDpth = succ (blDpth a) } : bs
                        nbl = a { blForm = zHole, blProf = nbs }
                    liftM (nbl { blType = Affi } :) ptl

    u2  = do  a <- prpaff; th <- liftM (cutt (blForm a)) getThes
              setThes th; liftM (a:) $ if (th == zTrue && mot)
                then after frmtext (dot link) else ptx

    u3  = liftM2 (:) choose phd
    u4  = liftM2 (:) frame ptx
    u5  = cases mot

    ptl | mot = do  ls <- dot link; gl <- getGoal; th <- getThes
                    t <- getTask; d <- getDpth; vs <- declared
                    return [ Block th [] vs Affi t (blLine gl)
                                "" (blLink gl ++ ls) d (blText gl) ]
        | otherwise = return []


-- Particular low-level sections: proof cases and blocks (frames)

cases m = do  th <- getThes; gl <- getGoal; cs <- level cas; t <- getTask
              ls <- if m then dot link else return []; let hdc = head cs
              let nls = blLink gl ++ ls; tx = blText gl; ln = blLine gl
                  djn = hdc { blForm = dis cs, blProf = [], blTask = t,
                              blLink = nls, blLine = ln, blText = tx }
              return  [ hdc { blForm = th, blProf = djn : cs, blLink = [],
                              blDpth = pred (blDpth hdc) } ]
  where
    dis = foldr1 Or . map (\ Block { blForm = Imp a _ } -> a)
    cls = cas -/- (dTask >> cls) -/- (qed >> return [])
    cas = liftM2 (:) (level castext) cls

castext = do  th <- getThes; bl <- cashyp; setGoal bl; bs <- prftext
              return bl { blForm = Imp (blForm bl) th, blProf = bl:bs,
                          blType = Affi, blDpth = pred (blDpth bl) }

frame   = do  l <- getLin; m <- frm; z <- getTxt; d <- getDpth
              bs <- level (dot frmtext); vs <- declared; t <- getTask
              return $ Block zHole bs vs Affi t l m [] d z


-- Sentences

affirm  = narrow $
          do  l <- reset; aff; f <- statement; ls <- dot link
              t <- getTask; dvs <- declared; freevars f dvs l
              liftM2 (Block f [] dvs Affi t l "" ls) getDpth getTxt

choose  = narrow $
          do  l <- reset; chs; f <- choostt; ls <- dot link
              t <- getTask; dvs <- declared; newfreevars f l
              liftM2 (Block f [] dvs Chos t l "" ls) getDpth getTxt

assume  = narrow $
          do  l <- reset; asm; f <- dot statement
              t <- getTask; dvs <- declared; newfreevars f l
              liftM2 (Block f [] dvs Assu t l "" []) getDpth getTxt

cashyp  = narrow $
          do  l <- reset; cas; f <- statement; ls <- dot link
              t <- getTask; dvs <- declared; freevars f dvs l
              liftM2 (Block f [] dvs Assu t l "" ls) getDpth getTxt

axmaff  = narrow $
          do  l <- reset; aff; f <- dot statement
              t <- getWTask; dvs <- declared; freevars f dvs l
              liftM2 (Block f [] dvs Affi t l "" []) getDpth getTxt

define  = narrow $
          do  l <- reset; aff; f <- dot definition; t <- getWTask
              dvs <- declared; freevars f dvs l; defcheck f dvs l
              liftM2 (Block f [] dvs Affi t l "" []) getDpth getTxt


-- Well-formedness checking

newfreevars f l   = do  dvs <- declBy f; freevars f dvs l
freevars f dvs l  = let err = wf dvs f in unless (null err) (lfail l err)

defcheck (All u f) dvs l                                = defcheck f (u:dvs) l
defcheck (Iff (Ann _ (Trm "=" [v, Trm _ vs])) _) dvs l  = wf_def dvs (v:vs) l
defcheck (Iff (Ann _ (Trm _ vs)) _) dvs l               = wf_def dvs vs l
defcheck (Ann _ (Trm "=" [Trm _ vs, _])) dvs l          = wf_def dvs vs l
defcheck _ _ l  = lfail l "compound expression in definition"

wf_def dvs vs l = if (nodups vs) then unless (all (`elem` vs) dvs)
                          $ lfail l "extra variables in the guard"
                  else lfail l "compound expression in definition"


-- Special instructions

intro = reset >> narrow introduce >> return ()

dTask = do  char '['; (c:_) <- tsk; char ']'
            setTask $ case c of 'n' -> None; 'c' -> Chck
                                'p' -> Prov; 'f' -> Full

dExit = char '[' >> ext >> char ']' >> return ()


-- Service stuff

axm = dot (word "axiom" >> mark)
thm = dot (wordOf ["theorem", "lemma", "corollary", "proposition"] >> mark)
def = dot (word "definition" >> mark)

cas = word "case" >> return ""
frm = dot (word "block" >> mark) -/- frn
frn = wordOf ["first", "second", "third", "now"]
        >> opt ' ' (char ':') >> return ""

asm = word "let" -|- (pr_letus >> pr_assume >> pr_that)
chs = pr_hence >> pr_letus >> pr_choose
aff = pr_hence

pr_letus  = opt [] ((word "let" >> word "us") -|- (word "we" >> word "can"))
pr_that   = opt [] (word "that")
pr_hence  = opt [] (wordOf ["then", "hence", "thus", "therefore"])

pr_show   = wordOf ["prove", "show", "demonstrate"]
pr_choose = wordOf ["choose", "take", "consider"]
pr_assume = wordOf ["assume", "presume", "suppose"]

shw = opt Nul (pr_letus >> pr_show >> after pr_by pr_that)
prf = dot (word "proof" >> pr_by) -/- pr_indeed -/- return Nul
pr_indeed = wordOf ["really", "indeed"] >> return Raw

pr_by = opt Raw $ word "by" >> (u1 -/- u2 -/- u3)
  where
    u1  = word "contradiction" >> return Raw
    u2  = word "case" >> word "analysis" >> return Raw
    u3  = word "induction" >> opt InS (word "on" >> it)
    it  = narrow $ liftM (Ind . snd) fo_term

qed = wordOf ["end", "qed", "trivial", "obvious"]
tsk = wordOf ["none", "check", "prove", "full"]
ext = wordOf ["quit", "exit", "stop"]

dot p = after p (char '.')

mark  = opt "" (token readWord)

link  = opt [] $ char '(' >> word "by" >> links
  where
    links = liftM2 (:) (token readWord) ltail
    ltail = (char ')' >> return []) -/- (char ',' >> links)

