{- |
Module      :  ./CASL/Simplify.hs
Description :  resolve empty conjunctions and other trivial cases
Copyright   :  (c) Christian Maeder, Uni Bremen 2005
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

Resolve empty conjunctions and other trivial cases
-}

module CASL.Simplify where

import CASL.AS_Basic_CASL
import CASL.Fold

import Common.Id
import Common.Utils (nubOrd)

negateFormula :: FORMULA f -> Maybe (FORMULA f)
negateFormula f = case f of
  Sort_gen_ax {} -> Nothing
  _ -> Just $ negateForm f nullRange

mkJunction :: Ord f => Junctor -> [FORMULA f] -> Range -> FORMULA f
mkJunction j fs ps = let
    (isTop, top, join) = case j of
        Con -> (is_False_atom, False, conjunctRange)
        Dis -> (is_True_atom, True, disjunctRange)
    in case nubOrd $ concatMap (\ f -> case f of
           Junction j2 ffs _ | j == j2 -> ffs
           Negation (Junction j2 ffs _) p | j /= j2 ->
             map (`negateForm` p) ffs
           Atom b _ | b /= top -> []
           _ -> [f]) fs of
         flat -> if any (\ f -> isTop f || elem (mkNeg f) flat) flat
           then Atom top ps else join flat ps

mkRelation :: Ord f => FORMULA f -> Relation -> FORMULA f -> Range -> FORMULA f
mkRelation f1 c f2 ps =
    let nf1 = negateForm f1 ps
        tf = Atom True ps
        equiv = c == Equivalence
    in case f1 of
      Atom b _
        | b -> f2
        | equiv -> negateForm f2 ps
        | otherwise -> tf
      _ -> case f2 of
           Atom b _
             | not b -> nf1
             | equiv -> f1
             | otherwise -> tf
           _ | f1 == f2 -> tf
             | nf1 == f2 -> if equiv then Atom False ps else f1
           _ -> Relation f1 c f2 ps

mkEquation :: Ord f => TERM f -> Equality -> TERM f -> Range -> FORMULA f
mkEquation t1 e t2 ps =
  if e == Strong && t1 == t2 then Atom True ps else Equation t1 e t2 ps

simplifyRecord :: Ord f => (f -> f) -> Record f (FORMULA f) (TERM f)
simplifyRecord mf = (mapRecord mf)
    { foldConditional = \ _ t1 f t2 ps -> case f of
      Atom b _ -> if b then t1 else t2
      _ -> Conditional t1 f t2 ps
    , foldQuantification = \ _ q vs qf ps ->
      let nf = Quantification q vs qf ps in
      case q of
      Unique_existential -> nf
      _ -> if null vs then qf else case (qf, q) of
           (Atom True _, Universal) -> qf
           (Atom False _, Existential) -> qf
           _ -> nf
    , foldJunction = const mkJunction
    , foldRelation = const mkRelation
    , foldNegation = const negateForm
    , foldEquation = const mkEquation
    }

simplifyTerm :: Ord f => (f -> f) -> TERM f -> TERM f
simplifyTerm = foldTerm . simplifyRecord

simplifyFormula :: Ord f => (f -> f) -> FORMULA f -> FORMULA f
simplifyFormula = foldFormula . simplifyRecord
