{-
 *  SAD / Alice / State -- defines the parser's state and reads the primitives
 *  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 State where

import Control.Monad (msum,liftM,liftM2)
import Data.Char (isAlpha)

import Text
import Parser

-- State definition

type FTL    = PM State

data Patt   = Wd [String] | Sm String | Vr | Nm deriving Eq

type Prim   = ([Patt], [Formula] -> Formula)

data State  = State {
  un_adj_expr, un_fun_expr, un_ntn_expr  :: [Prim],
  adj_expr, ver_expr, fun_expr, ntn_expr :: [Prim],
  m_un_adj_expr, m_adj_expr, m_ver_expr  :: [Prim],
  ppr_expr, ipr_expr, int_expr, ufn_expr :: [Prim],
  cfn_expr, lfn_expr, rfn_expr, ifn_expr :: [Prim],
  stHids :: [Formula],  stDecl :: [Formula],
  stGoal :: Block,      stThes :: Formula,
  stTask :: BlTask,     stDpth :: Int }

init_state  = State [] [] [] eq [] [] []
                    ue ue [] [] sp [] []
                    [] [] [] [] [] []
                    undefined zFalse
                    Full 0
  where
    eq  = [([Wd ["equal"], Wd ["to"], Vr], Trm "="),
            ([Wd ["nonequal"], Wd ["to"], Vr], Not . Trm "=")]
    ue  = [([Wd ["equal"]], Trm "="), ([Wd ["nonequal"]], Not . Trm "=")]
    se  = [([Sm "=", Vr], Trm "="), ([Sm "!=", Vr], Not . Trm "=")]
    sp  = ([Sm "-<-", Vr], Trm "iLess") : se


-- Declared variables, current task, current thesis, hidden variables

level txt = do  st <- getState id; setDpth (succ $ stDpth st); res <- txt
                t <- getTask; setState $ \ _ -> st { stTask = t }; return res

declared  = getState stDecl

declBy f  = do  dvs <- declared; let nvs = decl dvs f ++ dvs
                setState $ \ st -> st { stDecl = nvs }; return nvs

getTask   = getState stTask
setTask t = setState $ \ st -> st { stTask = t }

getWTask  = liftM wk getTask
  where wk Full = Chck ; wk Prov = None ; wk t = t

getSTask  = liftM wk getTask
  where wk Full = Prov ; wk Chck = None ; wk t = t

getDpth   = getState stDpth
setDpth d = setState $ \ st -> st { stDpth = d }

getThes   = getState stThes
setThes d = setState $ \ st -> st { stThes = d }

getGoal   = getState stGoal
setGoal d = setState $ \ st -> st { stGoal = d }

reset     = setState ( \ st -> st { stHids = pool } ) >> nulTxt >> getLin
  where
    pool  = map (\ n -> Var ('x':'_':show n)) [1..]

hidden    = do  (v:h) <- getState stHids
                setState $ \ st -> st { stHids = h }; return v


-- Parsers for syntactic primitives

type Term     = (Formula, Formula)              -- context, term | predicate
type Notion   = (Formula, Formula, Formula)     -- context, predicate, term

type MTerm    = (Formula, [Formula])            -- context, term | predicate
type MNotion  = (Formula, Formula, [Formula])   -- context, predicate, term

prim_un_adj   = prim_prd un_adj_expr
prim_adj      = prim_prd adj_expr
prim_ver      = prim_prd ver_expr

prim_m_un_adj = prim_m_prd m_un_adj_expr
prim_m_adj    = prim_m_prd m_adj_expr
prim_m_ver    = prim_m_prd m_ver_expr

prim_fun      = prim_prf fun_expr

prim_ufn      = liftM snd . prim_prf ufn_expr   -- T v
prim_cfn      = liftM snd . prim_prf cfn_expr   -- T ... T
prim_lfn      = liftM snd . prim_prf lfn_expr   -- T ... v
prim_rfn      = liftM snd . prim_prd rfn_expr   -- v ... T
prim_ifn      = liftM snd . prim_prd ifn_expr   -- v ... v

prim_ppr      = liftM snd . prim_prf ppr_expr
prim_ipr      = liftM snd . prim_prd ipr_expr
prim_int      = liftM snd . prim_prd int_expr

prim_prd e p  = getState e >>= msum . map expr
  where
    expr (pt, fm) = do  (q, ts) <- pattern p pt
                        f <- rehide (fm $ zHole:ts)
                        return (q, f)

prim_m_prd e p  = getState e >>= msum . map expr
  where
    expr (pt, fm) = do  (q, ts) <- pattern p pt
                        f <- rehide (fm $ zHole:zHoleMS:ts)
                        return (q, f)

prim_prf e p  = getState e >>= msum . map expr
  where
    expr (pt, fm) = do  (q, ts) <- pattern p pt
                        f <- rehide (fm ts)
                        return (q, f)

prim_un_fun p = getState un_fun_expr >>= msum . map expr
  where
    expr (pt, fm) = do  (q, v, ts) <- nt_patt p pt
                        f <- rehide (fm $ zHole:ts)
                        let fs = map (flip zEqu f) v
                        return (q, foldr1 And fs, v)

prim_un_ntn p = getState un_ntn_expr >>= msum . map expr
  where
    expr (pt, fm) = do  (q, v, ts) <- nt_patt p pt
                        let fn = fm . (:zHole:ts)
                        fs <- mapM (rehide . fn) v
                        return (q, foldr1 And fs, v)

prim_ntn p    = getState ntn_expr >>= msum . map expr
  where
    expr (pt, fm) = do  (q, vs, ts) <- nt_patt p pt
                        f <- rehide (fm $ zHole:ts)
                        return (q, f, vs)


-- Pattern parsing

nt_patt :: FTL Term -> [Patt] -> FTL (Formula, [Formula], [Formula])
nt_patt p ((Wd l):ls) = do  wordOf l; nt_patt p ls
nt_patt p (Nm:ls)     = do  vs <- varlist; (q, ts) <- pattern p ls
                            return (q, vs, ts)

in_patt :: FTL Term -> [Patt] -> FTL (Formula, Formula, [Formula])
in_patt p ((Sm s):ls) = do  string s; in_patt p ls
in_patt p (Vr:ls)     = do  v <- var; (q, ts) <- pattern p ls
                            return (q, v, ts)

pattern :: FTL Term -> [Patt] -> FTL (Formula, [Formula])
pattern p ((Wd l):ls) = do  wordOf l; pattern p ls
pattern p ((Sm s):ls) = do  string s; pattern p ls
pattern p (Vr:ls)     = do  (q, t) <- p; (q', ts) <- pattern p ls
                            return (substH q' q, t:ts)
pattern _ []          = return (zHole, [])


-- Service stuff

varlist = chain (char ',') var -|- liftM (:[]) hidden

var = do  v <- readWord; if (wf_var v) then space (Var v)
                else fail ("invalid variable " ++ show v)

wf_var (v:t)  = isAlpha v && null t

rehide (All v f)    = liftM2 (\ u g -> All u (subst u v g)) hidden (rehide f)
rehide (Exi v f)    = liftM2 (\ u g -> Exi u (subst u v g)) hidden (rehide f)
rehide f@(Trm _ _)  = return f
rehide f            = mapFM rehide f

