{-
 *  SAD / Alice / Text -- main datastuctures and common functions
 *  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 Text where

import Control.Monad (liftM, liftM2)
import Data.List (union, nub, delete)

-- Section
data Block = Block {  blForm :: Formula,    blProf :: [Block],
                      blDecl :: [Formula],  blType :: BlType,
                      blTask :: BlTask,     blLine :: Int,
                      blMark :: String,     blLink :: [String],
                      blDpth :: Int,        blText :: String  }

data BlType = Assu | Chos | Affi | Defn deriving Eq

data BlTask = None | Chck | Prov | Full deriving (Eq, Ord)

-- Formula
data Formula  = All Formula Formula   | Exi Formula Formula
              | Iff Formula Formula   | Imp Formula Formula
              | Or  Formula Formula   | And Formula Formula
              | Not Formula           | Ann Annot   Formula
              | Trm String [Formula]  | Var String
              deriving Eq

data Annot  = DHD | DIG | DMS | DMP | DOT deriving (Eq,Show)

zTrue     = Trm "#T#" []
zFalse    = Trm "#F#" []
zEqu f g  = Trm "=" [f,g]
zLess f g = Trm "iLess" [f,g]

zHole     = Var "?"
zHoleMS   = Var "??"

hole (Var "?")  = True
hole _          = False


mapF :: (Formula -> Formula) -> Formula -> Formula
mapF fn (All v f)   = All (fn v) (fn f)
mapF fn (Exi v f)   = Exi (fn v) (fn f)
mapF fn (Iff f g)   = Iff (fn f) (fn g)
mapF fn (Imp f g)   = Imp (fn f) (fn g)
mapF fn (Or  f g)   = Or  (fn f) (fn g)
mapF fn (And f g)   = And (fn f) (fn g)
mapF fn (Not f)     = Not (fn f)
mapF fn (Ann a f)   = Ann a (fn f)
mapF fn (Trm t ts)  = Trm t (map fn ts)
mapF fn f           = f


subst :: Formula -> Formula -> Formula -> Formula
subst f v g@(All u _) | u == v    = g
subst f v g@(Exi u _) | u == v    = g
subst f v u@(Var _)   | u == v    = f
subst f v g           = mapF (subst f v) g

substH (Var "?")  = id
substH s  = subst s zHole


mapFM :: (Monad m) => (Formula -> m Formula) -> Formula -> m Formula
mapFM fn (All v f)  = liftM2 All (fn v) (fn f)
mapFM fn (Exi v f)  = liftM2 Exi (fn v) (fn f)
mapFM fn (Iff f g)  = liftM2 Iff (fn f) (fn g)
mapFM fn (Imp f g)  = liftM2 Imp (fn f) (fn g)
mapFM fn (Or  f g)  = liftM2 Or  (fn f) (fn g)
mapFM fn (And f g)  = liftM2 And (fn f) (fn g)
mapFM fn (Not f)    = liftM  Not (fn f)
mapFM fn (Ann a f)  = liftM (Ann a) (fn f)
mapFM fn (Trm t ts) = liftM (Trm t) (mapM fn ts)
mapFM fn f          = return f


free :: Formula -> [Formula]
free (All v f)  = delete v (free f)
free (Exi v f)  = delete v (free f)
free (Iff f g)  = union (free f) (free g)
free (Imp f g)  = union (free f) (free g)
free (Or  f g)  = union (free f) (free g)
free (And f g)  = union (free f) (free g)
free (Not f)    = free f
free (Ann _ f)  = free f
free (Trm _ ts) = nub (concatMap free ts)
free v          = [v]


decl :: [Formula] -> Formula -> [Formula]
decl vs (And f g) = decl vs f `union` decl vs g
decl vs (All v (Imp c f)) = decl (v:free c ++ vs) f
decl vs (Exi v (And c f)) = decl (v:free c ++ vs) f
decl vs (All v f@(All _ _)) = decl (v:vs) f
decl vs (Exi v f@(Exi _ _)) = decl (v:vs) f
decl vs (Trm ('a':_) (v@(Var _):_)) = nifilt v vs
decl vs (Trm "=" [v@(Var _), Trm _ _]) = nifilt v vs
decl vs (Ann _ f) = decl vs f
decl _ _ = []


overfree :: [Formula] -> Formula -> [Formula]
overfree vs (All v f)   = infilt v vs `union` overfree (v:vs) f
overfree vs (Exi v f)   = infilt v vs `union` overfree (v:vs) f
overfree vs (Iff f g)   = overfree vs f `union` overfree vs g
overfree vs (Imp f g)   = overfree vs f `union` overfree vs g
overfree vs (Or  f g)   = overfree vs f `union` overfree vs g
overfree vs (And f g)   = overfree vs f `union` overfree vs g
overfree vs (Not f)     = overfree vs f
overfree vs (Ann _ f)   = overfree vs f
overfree vs (Trm _ ts)  = nub $ concatMap (overfree vs) ts
overfree vs v           = nifilt v vs


wf :: [Formula] -> Formula -> String
wf vs f | null bvs          = ""
        | elem zHoleMS bvs  = "too few subjects for an m-predicate:" ++ inf
        | otherwise         = "free/overlapped variables:" ++ sbvs ++ inf
  where
    bvs = overfree vs f
    sbvs = concatMap ((' ':).show) bvs
    inf = "\n in translation: " ++ show f


infilt v vs = if elem v vs then [v] else []
nifilt v vs = if elem v vs then [] else [v]

nodups (v@(Var _) : vs) = v `notElem` vs && nodups vs
nodups (_ : _)  = False ; nodups _ = True


bool :: Formula -> Formula
bool (All v (Trm "#T#" [])) = zTrue
bool (All v (Trm "#F#" [])) = zFalse
bool (Exi v (Trm "#T#" [])) = zTrue
bool (Exi v (Trm "#F#" [])) = zFalse
bool (Iff (Trm "#T#" []) f) = f
bool (Iff f (Trm "#T#" [])) = f
bool (Iff (Trm "#F#" []) f) = bool (Not f)
bool (Iff f (Trm "#F#" [])) = bool (Not f)
bool (Imp (Trm "#T#" []) f) = f
bool (Imp f (Trm "#T#" [])) = zTrue
bool (Imp (Trm "#F#" []) f) = zTrue
bool (Imp f (Trm "#F#" [])) = bool (Not f)
bool (Or  (Trm "#T#" []) f) = zTrue
bool (Or  f (Trm "#T#" [])) = zTrue
bool (Or  (Trm "#F#" []) f) = f
bool (Or  f (Trm "#F#" [])) = f
bool (And (Trm "#T#" []) f) = f
bool (And f (Trm "#T#" [])) = f
bool (And (Trm "#F#" []) f) = zFalse
bool (And f (Trm "#F#" [])) = zFalse
bool (Ann a (Trm "#T#" [])) = zTrue
bool (Ann a (Trm "#F#" [])) = zFalse
bool (Not (Trm "#T#" []))   = zFalse
bool (Not (Trm "#F#" []))   = zTrue
bool f = f


-- Block stuff

declB :: Block -> [Formula]
declB b = decl (blDecl b) (blForm b)

formulate :: Block -> Formula
formulate (Block { blForm = f, blProf = bs })
  | hole f = compose bs | True = f

compose :: [Block] -> Formula
compose []        = zTrue
compose (b : [])  = formulate b
compose (b : bs)  | blType b == Assu
  = foldr All (Imp (blForm b) $ compose bs) $ declB b
                  | blType b == Chos
  = foldr Exi (And (blForm b) $ compose bs) $ declB b
                  | otherwise
  = And (formulate b) (compose bs)


-- Show Instances

instance Show Block where
  showsPrec _ (Block f ps _ Assu _ _ mr _ 0 _) | hole f =
    showString "Axiom" . showMark mr . showText ps . showChar '\n'
  showsPrec _ (Block f ps _ Defn _ _ mr _ 0 _) | hole f =
    showString "Definition" . showMark mr . showText ps . showChar '\n'
  showsPrec _ (Block f ps _ Affi _ _ mr _ 0 _) | hole f =
    showString "Proposition" . showMark mr . showText ps . showChar '\n'
  showsPrec _ (Block f ps _ Affi _ _ mr _ n _) | hole f =
    showIndent n . showString "block" . showMark mr .
      showText ps . showIndent n . showString "end.\n"
  showsPrec _ (Block f [] _ Affi _ _ _ _ n _) =
    showIndent n . shows f . showString ".\n"
  showsPrec _ (Block f ps _ Affi _ _ _ _ n _) =
    showIndent n . shows f . showString ".\n" .
      showIndent n . showString "proof.\n" .
      showText ps . showIndent n . showString "end.\n"
  showsPrec _ (Block f [] _ Assu _ _ _ _ n _) =
    showIndent n . showString "assume " . shows f . showString ".\n"
  showsPrec _ (Block f [] _ Chos _ _ _ _ n _) =
    showIndent n . showString "choose " . shows f . showString ".\n"
  showsPrec _ (Block f ps _ Chos _ _ _ _ n _) =
    showIndent n . showString "choose " . shows f . showString ".\n" .
      showIndent n . showString "proof.\n" .
      showText ps . showIndent n . showString "end.\n"

showMark "" = showString ".\n"
showMark mr = showChar ' ' . showString mr . showString ".\n"

showText ps = foldr (.) id $ map shows ps
showIndent n  = showString $ replicate (n * 2) ' '


instance Show Formula where
  showsPrec _ (All v f)   = showString "forall " . shows v . showChar ' ' . shows f
  showsPrec _ (Exi v f)   = showString "exists " . shows v . showChar ' ' . shows f
  showsPrec _ (Iff f g)   = showbin " iff " f g
  showsPrec _ (Imp f g)   = showbin " implies " f g
  showsPrec _ (Or  f g)   = showbin " or "  f g
  showsPrec _ (And f g)   = showbin " and " f g
  showsPrec _ (Not f)     = showString "not " . shows f
  showsPrec _ (Ann a f)   = {- shows f -- -} showbin " :: " a f
  showsPrec _ (Trm "=" [f,g]) = shows f . showString " = " . shows g
  showsPrec _ (Trm "#T#" [])  = showString "truth"
  showsPrec _ (Trm "#F#" [])  = showString "contradiction"
  showsPrec _ (Trm "#Th#" []) = showString "thesis"
  showsPrec _ (Trm t ts)  = showString t . showChar '(' . showls ts . showChar ')'
  showsPrec _ (Var v)     = showString v

showbin o f g = showChar '(' . shows f . showString o . shows g . showChar ')'

showls (l:[]) = shows l
showls (l:ls) = shows l . showChar ',' . showls ls
showls _ = id

