{-
 *  SAD / Alice / Reason -- verification cycle and "foreground" reasoning
 *  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 Reason where

import Control.Monad (when,foldM,mplus)
import Data.IORef (IORef, readIORef, modifyIORef)
import System.IO

import Text
import Explore

-- Main verification cycle

mCycle :: RVars -> Bool -> Bool -> String
              -> String -> IORef Int -> [Block] -> IO ()

mCycle _ _ _ _ _ _ [] = putStrLn "[Reason] no input"

mCycle ref vrb ign pn job gl bs =
    do  putStrLn $ "[Reason] " ++ job ++ " started"
        r <- rcycle [] bs; g <- readIORef gl
        let res = if g == 0 then " finished, no goals found"
                  else if r then " successful" else " failed"
        putStrLn $ "[Reason] " ++ job ++ res
  where
    rcycle cnt (bl:bs)  = process cnt bl <??>
                            rcycle cnt (blProf bl) <??> rcycle (bl:cnt) bs
    rcycle _ [] = return True

    process cnt bl@(Block fr pr dv ty ta li mr ls dp tx) = prc ty
      where
        prc Assu  | hole fr   = outS vrb dp pn "Axiom."
                  | otherwise = outA vrb dp pn fr

        prc Defn              = outS vrb dp pn "Definition."

        prc Chos              = outF vrb dp pn fr >>
                                  prove (foldr Exi fr (decl dv fr))

        prc Affi  | hole fr   = outS vrb dp pn $
                      if dp == 0 then "Proposition." else "block."
                  | null pr   = outF vrb dp pn fr >> prove fr
                  | otherwise = outF vrb dp pn fr >> outS vrb dp pn "proof."

        prove fr  | ta < Prov = return True | True =
          do  putStrLn $ "[Reason] line " ++
                            show li ++ ": goal: " ++ tx
              modifyIORef gl succ ; exTask ref cnt fr ls

    (<??>) = if ign then (<%%>) else (<&&>)


-- Splitter

exTask ref cnt f [] = splitG ref cnt (albet f)
exTask ref cnt f ls = splitG ref (filter (chk ls) cnt) (albet f)
  where
    chk ls (Block { blMark = m, blDpth = d })
      = if null m then d > 0 else head m == '_' || m `elem` ls

splitG ref cnt (Or  f g) = splitG ref (dumbF (neg f) : cnt) (albet g)
              <||> (dgo >> splitG ref (dumbF (neg g) : cnt) (albet f))
  where
    dgo = putStrLn $ "[Reason] trying an alternative subgoal"
    neg (Not x) = x ; neg x = Not x

splitG ref cnt (And f g) = splitG ref cnt (albet f)
              <&&> (dga >> splitG ref (dumbF f : cnt) (albet g))
  where
    dga = putStrLn $ "[Reason] passing to the next subgoal"

splitG _ _ (Trm "#T#" []) = dgt >> return True
  where
    dgt = putStrLn $ "[Reason] trivial"

splitG ref cnt f = explore ref cnt f


albet (All v f)       = albet f
albet (Not (Exi v f)) = albet (Not f)
albet (Iff f g)       = And (Imp f g) (Imp g f)
albet (Not (Iff f g)) = Or (And (Not f) g) (And f (Not g))
albet (Imp f g)       = Or (Not f) g
albet (Not (Imp f g)) = And f (Not g)
albet (Not (Or  f g)) = And (Not f) (Not g)
albet (Not (And f g)) = Or  (Not f) (Not g)
albet (Not (Not f))   = albet f
albet (Ann _ f)       = albet f
albet (Not (Ann _ f)) = albet f
albet f               = f


-- Chip and cut

chip d f t = foldr gchip (dequant (decl d f) t, True) (conj True f)
  where
    dequant vs (All u@(Var ('t':'_':x)) f)
      | Var x `elem` vs   = dequant vs $ subst (Var x) u f
      | otherwise         = All u (dequant vs f)
    dequant vs (Imp f g)  = Imp f (dequant vs g)
    dequant _  f          = f

gchip c (f, a) = let (g, b) = gch True f in (g, a && b)
  where
    gch True  (Or  f g) = xadd Or  (gch True  f) (gch True  g)
    gch True  (Imp f g) = xadd Imp (gch False f) (gch True  g)
    gch False (And f g) = xadd And (gch False f) (gch False g)

    gch sg (Not f)    = xpas Not (gch (not sg) f)
    gch sg (All v f)  = xpas (All v) (gch sg f)
    gch sg (Exi v f)  = xpas (Exi v) (gch sg f)

    gch False f | f == c      = (zTrue,  True)
    gch True  f | Not f == c  = (zFalse, True)
    gch _ f                   = (f, False)

    xadd f (s,a) (r,b)  = (bool $ f s r, a || b)
    xpas f (s,a)        = (bool $ f s, a)

cutt f t  = foldr gcutt t (conj True f)

gcutt (Trm "#F#" []) _  = zTrue
gcutt c f = gct True f
  where
    gct False (Or  f g) = bool $ Or  (gct False f) (gct False g)
    gct False (Imp f g) = bool $ Imp (gct True  f) (gct False g)
    gct True  (And f g) = bool $ And (gct True  f) (gct True  g)
    gct True  (Iff f g) | Imp f g == c  = Imp g f
                        | Imp g f == c  = Imp f g

    gct sg (Not f)    = bool $ Not (gct (not sg) f)
    gct sg (All v f)  = bool $ All v (gct sg f)
    gct sg (Exi v f)  = bool $ Exi v (gct sg f)

    gct True  f | f == c      = zTrue
    gct False f | Not f == c  = zFalse
    gct _ f                   = f

conj True (And f g)   = conj True f ++ conj True g
conj False (Imp f g)  = conj True f ++ conj False g
conj False (Or f g)   = conj False f ++ conj False g
conj sg (Not f)       = conj (not sg) f
conj True f           = [f]
conj _ f              = [Not f]


-- Service stuff

m <||> n  = do  r <- m; if r then return True else n
m <&&> n  = do  r <- m; if r then n else return False
m <%%> n  = do  r <- m; if r then n else n >> return False

dumbF f = Block f [] [] Affi None 0 "_" [] 0 ""

outA v n p f  = out v n p $ showString "assume " . shows f . showChar '.'
outP v n p f  = out v n p $ showString "postulate " . shows f . showChar '.'
outF v n p f  = out v n p $ shows f . showChar '.'
outS v n p s  = out v n p $ showString s

out v n p s   = do  when v $ putStrLn $ showString
                      (p ++ replicate (n * 2) ' ') . s $ ""
                    return True

