(************************************************************************)
(*         *      The Rocq Prover / The Rocq Development Team           *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-20019                            *)
(*                                                                      *)
(************************************************************************)
Set Implicit Arguments.
(** Formulae are either interpreted over Prop or bool. *)
Inductive kind : Type :=
|isProp
|isBool.
Register isProp as micromega.kind.isProp.
Register isBool as micromega.kind.isBool.
Inductive Trace (A : Type) :=
| null : Trace A
| push : A -> Trace A -> Trace A
| merge : Trace A -> Trace A -> Trace A
.
Section S.
Context {TA  : Type}. (* type of interpreted atoms *)
Context {TX  : kind -> Type}. (* type of uninterpreted terms (Prop) *)
Context {AA  : Type}. (* type of annotations for atoms *)
Context {AF  : Type}. (* type of formulae identifiers *)
Inductive GFormula  : kind -> Type :=
| TT   : forall (k: kind), GFormula k
| FF   : forall (k: kind), GFormula k
| X    : forall (k: kind), TX k -> GFormula k
| A    : forall (k: kind), TA -> AA -> GFormula k
| AND  : forall (k: kind), GFormula k -> GFormula k -> GFormula k
| OR   : forall (k: kind), GFormula k -> GFormula k -> GFormula k
| NOT  : forall (k: kind), GFormula k -> GFormula k
| IMPL : forall (k: kind), GFormula k -> option AF -> GFormula k -> GFormula k
| IFF  : forall (k: kind), GFormula k -> GFormula k -> GFormula k
| EQ   : GFormula isBool -> GFormula isBool -> GFormula isProp.
Register TT as micromega.GFormula.TT.
Register FF as micromega.GFormula.FF.
Register X  as micromega.GFormula.X.
Register A  as micromega.GFormula.A.
Register AND as micromega.GFormula.AND.
Register OR  as micromega.GFormula.OR.
Register NOT  as micromega.GFormula.NOT.
Register IMPL  as micromega.GFormula.IMPL.
Register IFF  as micromega.GFormula.IFF.
Register EQ  as micromega.GFormula.EQ.
Section MAPX.
Variable F : forall k, TX k -> TX k.
Fixpoint mapX (k:kind) (f : GFormula k) : GFormula k :=
match f with
| TT k => TT k
| FF k => FF k
| X x => X (F  x)
| A k a an => A k a an
| AND f1 f2 => AND (mapX f1) (mapX f2)
| OR f1 f2  => OR (mapX f1) (mapX f2)
| NOT f     => NOT (mapX f)
| IMPL f1 o f2 => IMPL (mapX f1) o (mapX f2)
| IFF f1 f2    => IFF (mapX f1) (mapX f2)
| EQ f1 f2           => EQ (mapX f1) (mapX f2)
end.
End MAPX.
Section FOLDANNOT.
Variable ACC : Type.
Variable F : ACC -> AA -> ACC.
Fixpoint foldA (k: kind) (f : GFormula k) (acc : ACC) : ACC :=
match f with
| TT _ => acc
| FF _ => acc
| X x => acc
| A _ a an => F acc an
| AND f1 f2
| OR f1 f2
| IFF f1 f2
| IMPL f1 _ f2 | EQ f1 f2 => foldA f1 (foldA f2 acc)
| NOT f     => foldA f acc
end.
End FOLDANNOT.
Definition cons_id (id : option AF) (l : list AF) :=
match id with
| None => l
| Some id => id :: l
end.
Fixpoint ids_of_formula (k: kind) (f:GFormula k) :=
match f with
| IMPL f id f' => cons_id id (ids_of_formula f')
|  _           => nil
end.
Fixpoint collect_annot (k: kind) (f : GFormula k) : list AA :=
match f with
| TT _ | FF _ | X _ => nil
| A _ _ a => a ::nil
| AND f1 f2
| OR  f1 f2
| IFF f1 f2 | EQ f1 f2
| IMPL f1 _ f2  => collect_annot f1 ++ collect_annot f2
| NOT  f  => collect_annot f
end.
Definition rtyp (k: kind) : Type := if k then Prop else bool.
Variable ex : forall (k: kind), TX k -> rtyp k. (* [ex] will be the identity *)
Section EVAL.
Variable ea : forall (k: kind), TA -> rtyp k.
Definition eTT (k: kind) : rtyp k :=
if k as k' return  rtyp k' then True else true.
Definition eFF (k: kind) : rtyp k :=
if k as k' return  rtyp k' then False else false.
Definition eAND (k: kind) : rtyp k -> rtyp k -> rtyp k :=
if k as k' return rtyp k' -> rtyp k' -> rtyp k'
then and else andb.
Definition eOR (k: kind) : rtyp k -> rtyp k -> rtyp k :=
if k as k' return rtyp k' -> rtyp k' -> rtyp k'
then or else orb.
Definition eIMPL (k: kind) : rtyp k -> rtyp k -> rtyp k :=
if k as k' return rtyp k' -> rtyp k' -> rtyp k'
then (fun x y => x -> y) else implb.
Definition eIFF (k: kind) : rtyp k -> rtyp k -> rtyp k :=
if k as k' return rtyp k' -> rtyp k' -> rtyp k'
then iff else eqb.
Definition eNOT (k: kind) : rtyp k -> rtyp k :=
if k as k' return rtyp k' -> rtyp k'
then not else negb.
Fixpoint eval_f (k: kind) (f:GFormula k) {struct f}: rtyp k :=
match f in GFormula k' return rtyp k' with
| TT tk => eTT tk
| FF tk => eFF tk
| A k a _ =>  ea k a
| X p => ex  p
| @AND k e1 e2 => eAND k (eval_f  e1) (eval_f e2)
| @OR k e1 e2  => eOR k (eval_f e1) (eval_f e2)
| @NOT k e     => eNOT k (eval_f e)
| @IMPL k f1 _ f2 => eIMPL k (eval_f f1)  (eval_f f2)
| @IFF k f1 f2    => eIFF k (eval_f f1) (eval_f f2)
| EQ f1 f2    => (eval_f f1) = (eval_f f2)
end.

(* Specifications: *)
Lemma eval_f_rew : forall k (f:GFormula k),
eval_f f =
match f in GFormula k' return rtyp k' with
| TT tk => eTT tk
| FF tk => eFF tk
| A k a _ =>  ea k a
| X p => ex  p
| @AND k e1 e2 => eAND k (eval_f  e1) (eval_f e2)
| @OR k e1 e2  => eOR k (eval_f e1) (eval_f e2)
| @NOT k e     => eNOT k (eval_f e)
| @IMPL k f1 _ f2 => eIMPL k (eval_f f1)  (eval_f f2)
| @IFF k f1 f2    => eIFF k (eval_f f1) (eval_f f2)
| EQ f1 f2    => (eval_f f1) = (eval_f f2)
end.