Section Micromega.
(* Assume we have a strict(ly?) ordered ring *)
Variable R : Type.
Variables rO rI : R.
Variables rplus rtimes rminus: R -> R -> R.
Variable ropp : R -> R.
Variables req rle rlt : R -> R -> Prop.
Variable sor : SOR rO rI rplus rtimes rminus ropp req rle rlt.
Notation "0" := rO.
Notation "1" := rI.
Notation "x + y" := (rplus x y).
Notation "x * y " := (rtimes x y).
Notation "x - y " := (rminus x y).
Notation "- x" := (ropp x).
Notation "x == y" := (req x y).
Notation "x ~= y" := (~ req x y).
Notation "x <= y" := (rle x y).
Notation "x < y" := (rlt x y).
(* Assume we have a type of coefficients C and a morphism from C to R *)
Variable C : Type.
Variables cO cI : C.
Variables cplus ctimes cminus: C -> C -> C.
Variable copp : C -> C.
Variables ceqb cleb : C -> C -> bool.
Variable phi : C -> R.
(* Power coefficients *)
Variable E : Type. (* the type of exponents *)
Variable pow_phi : N -> E.
Variable rpow : R -> E -> R.
Notation "[ x ]" := (phi x).
Notation "x [=] y" := (ceqb x y).
Notation "x [<=] y" := (cleb x y).
(* Let's collect all hypotheses in addition to the ordered ring axioms into one structure *)
Record SORaddon := mk_SOR_addon {
SORrm : ring_morph 0 1 rplus rtimes rminus ropp req cO cI cplus ctimes cminus copp ceqb phi;
SORpower : power_theory rI rtimes req pow_phi rpow;
SORcneqb_morph : forall x y : C, x [=] y = false -> [x] ~= [y];
SORcleb_morph : forall x y : C, x [<=] y = true -> [x] <= [y]
}.
Variable addon : SORaddon.
Add Relation R req
reflexivity proved by (@Equivalence_Reflexive _ _ (SORsetoid sor))
symmetry proved by (@Equivalence_Symmetric _ _ (SORsetoid sor))
transitivity proved by (@Equivalence_Transitive _ _ (SORsetoid sor))
as micomega_sor_setoid.
Add Morphism rplus with signature req ==> req ==> req as rplus_morph.
Add Morphism rtimes with signature req ==> req ==> req as rtimes_morph.
Add Morphism ropp with signature req ==> req as ropp_morph.
Add Morphism rle with signature req ==> req ==> iff as rle_morph.
Add Morphism rlt with signature req ==> req ==> iff as rlt_morph.
Add Morphism rminus with signature req ==> req ==> req as rminus_morph.
Definition cneqb (x y : C) := negb (ceqb x y).
Definition cltb (x y : C) := (cleb x y) && (cneqb x y).
Notation "x [~=] y" := (cneqb x y).
Notation "x [<] y" := (cltb x y).
Ltac le_less := rewrite (Rle_lt_eq sor); left; try assumption.
Ltac le_equal := rewrite (Rle_lt_eq sor); right; try reflexivity; try assumption.
Ltac le_elim H := rewrite (Rle_lt_eq sor) in H; destruct H as [H | H].
(* Begin Micromega *)
Definition PolC := Pol C. (* polynomials in generalized Horner form, defined in Ring_polynom or EnvRing *)
Definition PolEnv := Env R. (* For interpreting PolC *)
Definition eval_pol : PolEnv -> PolC -> R :=
Pphi rplus rtimes phi.
Inductive Op1 : Set := (* relations with 0 *)
| Equal (* == 0 *)
| NonEqual (* ~= 0 *)
| Strict (* > 0 *)
| NonStrict (* >= 0 *).
Definition NFormula := (PolC * Op1)%type. (* normalized formula *)
Definition eval_op1 (o : Op1) : R -> Prop :=
match o with
| Equal => fun x => x == 0
| NonEqual => fun x : R => x ~= 0
| Strict => fun x : R => 0 < x
| NonStrict => fun x : R => 0 <= x
end.
Definition eval_nformula (env : PolEnv) (f : NFormula) : Prop :=
let (p, op) := f in eval_op1 op (eval_pol env p).
(** Rule of "signs" for addition and multiplication. An arbitrary result is coded buy None. *)
Definition OpMult (o o' : Op1) : option Op1 :=
match o with
| Equal => Some Equal
| NonStrict =>
match o' with
| Equal => Some Equal
| NonEqual  => None
| Strict    => Some NonStrict
| NonStrict => Some NonStrict
end
| Strict => match o' with
| NonEqual => None
|  _       => Some o'
end
| NonEqual => match o' with
| Equal => Some Equal
| NonEqual => Some NonEqual
| _        => None
end
end.
Definition OpAdd (o o': Op1) : option Op1 :=
match o with
| Equal => Some o'
| NonStrict =>
match o' with
| Strict => Some Strict
| NonEqual => None
| _ => Some NonStrict
end
| Strict => match o' with
| NonEqual => None
|  _        => Some Strict
end
| NonEqual => match o' with
| Equal  => Some NonEqual
| _      => None
end
end.
Inductive Psatz : Type :=
| PsatzIn : nat -> Psatz
| PsatzSquare : PolC -> Psatz
| PsatzMulC : PolC -> Psatz -> Psatz
| PsatzMulE : Psatz -> Psatz -> Psatz
| PsatzAdd  : Psatz -> Psatz -> Psatz
| PsatzC    : C -> Psatz
| PsatzZ    : Psatz.
(** Given a list [l] of NFormula and an extended polynomial expression [e], if [eval_Psatz l e] succeeds (= Some f) then [f] is a logic consequence of the conjunction of the formulae in l. Moreover, the polynomial expression is obtained by replacing the (PsatzIn n) by the nth polynomial expression in [l] and the sign is computed by the "rule of sign" *)
(* Might be defined elsewhere *)
Definition map_option (A B:Type) (f : A -> option B) (o : option A) : option B :=
match o with
| None => None
| Some x => f x
end.
Arguments map_option [A B] f o.
Definition map_option2 (A B C : Type) (f : A -> B -> option C)
(o: option A) (o': option B) : option C :=
match o , o' with
| None , _ => None
| _ , None => None
| Some x , Some x' => f x x'
end.
Arguments map_option2 [A B C] f o o'.
Definition Rops_wd := mk_reqe (*rplus rtimes ropp req*)
(SORplus_wd sor)
(SORtimes_wd sor)
(SORopp_wd sor).
Definition pexpr_times_nformula (e: PolC) (f : NFormula) : option NFormula :=
let (ef,o) := f in
match o with
| Equal => Some (Pmul cO cI cplus ctimes ceqb e ef , Equal)
|   _   => None
end.
Definition nformula_times_nformula (f1 f2 : NFormula) : option NFormula :=
let (e1,o1) := f1 in
let (e2,o2) := f2 in
map_option  (fun x => (Some (Pmul cO cI cplus ctimes ceqb e1 e2,x)))    (OpMult o1 o2).
Definition nformula_plus_nformula (f1 f2 : NFormula) : option NFormula :=
let (e1,o1) := f1 in
let (e2,o2) := f2 in
map_option  (fun x => (Some (Padd cO cplus ceqb e1 e2,x)))    (OpAdd o1 o2).
Fixpoint eval_Psatz (l : list NFormula) (e : Psatz) {struct e} : option NFormula :=
match e with
| PsatzIn n => Some (nth n l (Pc cO, Equal))
| PsatzSquare e => Some (Psquare cO cI cplus ctimes ceqb e  , NonStrict)
| PsatzMulC re e => map_option (pexpr_times_nformula re) (eval_Psatz l e)
| PsatzMulE f1 f2 => map_option2 nformula_times_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
| PsatzAdd f1 f2  => map_option2 nformula_plus_nformula  (eval_Psatz l f1) (eval_Psatz l f2)
| PsatzC  c  => if cltb cO c then Some (Pc c, Strict) else None
(* This could be 0, or <> 0 -- but these cases are useless *)
| PsatzZ     => Some (Pc cO, Equal) (* Just to make life easier *)
end.
Fixpoint ge_bool (n m  : nat) : bool :=
match n with
| O   => match m with
|  O => true
| S _ => false
end
| S n  => match m with
| O => true
| S m => ge_bool n m
end
end.
Fixpoint xhyps_of_psatz (base:nat) (acc : list nat) (prf : Psatz)  : list nat :=
match prf with
| PsatzC _ | PsatzZ | PsatzSquare _ => acc
| PsatzMulC _ prf => xhyps_of_psatz base acc prf
| PsatzAdd e1 e2 | PsatzMulE e1 e2 => xhyps_of_psatz base (xhyps_of_psatz base acc e2) e1
| PsatzIn n => if ge_bool n base then (n::acc) else acc
end.
Fixpoint nhyps_of_psatz (prf : Psatz) : list nat :=
match prf with
| PsatzC _ | PsatzZ | PsatzSquare _ => nil
| PsatzMulC _ prf => nhyps_of_psatz prf
| PsatzAdd e1 e2 | PsatzMulE e1 e2 => nhyps_of_psatz e1 ++ nhyps_of_psatz e2
| PsatzIn n => n :: nil
end.
Fixpoint extract_hyps (l: list NFormula) (ln : list nat) : list NFormula  :=
match ln with
| nil => nil
| n::ln => nth n l (Pc cO, Equal) :: extract_hyps l ln
end.
Ltac inv H := inversion H ; try subst ; clear H.
(* roughly speaking, normalise_pexpr_correct is a proof of forall env p, eval_pexpr env p == eval_pol env (normalise_pexpr p) *)
(*****)
Definition paddC := PaddC cplus.
Definition psubC := PsubC cminus.
Definition PsubC_ok : forall c P env, eval_pol env (psubC  P c) == eval_pol env P - [c] :=
let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
(SORplus_wd sor)
(SORtimes_wd sor)
(SORopp_wd sor) in
PsubC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))
(SORrm addon).
Definition PaddC_ok : forall c P env, eval_pol env (paddC  P c) == eval_pol env P + [c] :=
let Rops_wd := mk_reqe (*rplus rtimes ropp req*)
(SORplus_wd sor)
(SORtimes_wd sor)
(SORopp_wd sor) in
PaddC_ok (SORsetoid sor) Rops_wd (Rth_ARth (SORsetoid sor) Rops_wd (SORrt sor))
(SORrm addon).
(* Check that a formula f is inconsistent by normalizing and comparing the resulting constant with 0 *)
Definition check_inconsistent (f : NFormula) : bool :=
let (e, op) := f in
match  e with
| Pc c =>
match op with
| Equal => cneqb c cO
| NonStrict => c [<] cO
| Strict => c [<=] cO
| NonEqual => c [=] cO
end
| _ => false (* not a constant *)
end.
Definition check_normalised_formulas : list NFormula -> Psatz -> bool :=
fun l cm =>
match eval_Psatz l cm with
| None => false
| Some f => check_inconsistent f
end.
(** Normalisation of formulae **)
Inductive Op2 : Set := (* binary relations *)
| OpEq
| OpNEq
| OpLe
| OpGe
| OpLt
| OpGt.
Definition eval_op2 (o : Op2) : R -> R -> Prop :=
match o with
| OpEq => req
| OpNEq => fun x y : R => x ~= y
| OpLe => rle
| OpGe => fun x y : R => y <= x
| OpLt => fun x y : R => x < y
| OpGt => fun x y : R => y < x
end.
Definition  eval_pexpr : PolEnv -> PExpr C -> R :=
PEeval rplus rtimes rminus ropp phi pow_phi rpow.
#[universes(template)]
Record Formula (T:Type) : Type := {
Flhs : PExpr T;
Fop : Op2;
Frhs : PExpr T
}.
Definition eval_formula (env : PolEnv) (f : Formula C) : Prop :=
let (lhs, op, rhs) := f in
(eval_op2 op) (eval_pexpr env lhs) (eval_pexpr env rhs).
(* We normalize Formulas by moving terms to one side *)
Definition norm := norm_aux cO cI cplus ctimes cminus copp ceqb.
Definition psub := Psub cO  cplus cminus copp ceqb.
Definition padd  := Padd cO  cplus ceqb.
Definition pmul := Pmul cO cI cplus ctimes ceqb.
Definition normalise (f : Formula C) : NFormula :=
let (lhs, op, rhs) := f in
let lhs := norm lhs in
let rhs := norm rhs in
match op with
| OpEq =>  (psub  lhs rhs, Equal)
| OpNEq => (psub lhs rhs, NonEqual)
| OpLe =>  (psub rhs lhs, NonStrict)
| OpGe =>  (psub lhs rhs, NonStrict)
| OpGt => (psub  lhs rhs, Strict)
| OpLt => (psub  rhs lhs, Strict)
end.
Definition negate (f : Formula C) : NFormula :=
let (lhs, op, rhs) := f in
let lhs := norm lhs in
let rhs := norm rhs in
match op with
| OpEq => (psub rhs lhs, NonEqual)
| OpNEq => (psub rhs lhs, Equal)
| OpLe => (psub lhs rhs, Strict) (* e <= e' == ~ e > e' *)
| OpGe => (psub rhs lhs, Strict)
| OpGt => (psub rhs lhs, NonStrict)
| OpLt => (psub lhs rhs, NonStrict)
end.

Theorem normalise_sound :
forall (env : PolEnv) (f : Formula C),
eval_formula env f -> eval_nformula env (normalise f).