Require Import PeanoNat.
Local Open Scope nat_scope.
Require Import Verdi.Verdi.

Load nw_model_version_consistency.

(*ZVA Interface*)

Inductive inp: Type.
Inductive outp: Type.

Definition Inpt := list inp.
Definition Out := list outp.

Inductive Predicate: Set:=
|and : Predicate
|or : Predicate.

Definition Local_predicates:= list Predicate.

Inductive Key: Type.
Inductive Value: Type.
Inductive Fact := fact_cons: Key ->  Value -> Fact.

Variable keynull: Key.
Variable valuenull: Value.

Definition Certificate:= list Fact.

Variable beqKey : Key -> Key -> bool.
Variable beqValue : option Value -> option Value -> bool.

Axiom beqKey_eq:
forall x y, beqKey x y = true -> x = y.

Axiom beqValue_eq:
forall x y, beqValue x y = true -> x = y.

Axiom fact_eq_dec:
forall (x y : Fact), {x=y} + {x<>y}.

Definition fact_key (fact:Fact) :  Key :=
match fact with
  | fact_cons key value => key
end.

Definition fact_value (fact:Fact) : Value :=
match fact with
  | fact_cons key value => value
end.

(* get position of key in certificate c*)
Fixpoint get_pos_(pos:nat) (c : list Fact) (key: Key) : option nat :=
match c with
      | f :: fs => if (beqKey (fact_key f) key) then Some (pos) else get_pos_ (pos + 1) fs  key
      | nil =>  None
end.

Definition get_pos:= get_pos_ 0.

Notation "a == b" := (beq_nat a b) (at level 70).

(* return fact in certificate on position pos*)
Fixpoint findInCert (init: nat) (c : list Fact) (pos : option nat) : option (Fact) :=
    match c, pos with
      | _ , None => None
      | nil, _ => None
      | f :: fs, Some x => if init == x then
                    Some f
                  else
                    if init <? x then
                      None
                    else
                      findInCert (init + 1) fs pos
end.

Definition findValue (c :list Fact) (pos: option nat) : option Value  :=
match findInCert 1 c pos with
          | Some f => Some (fact_value f)
          | None => None
end.

(*get certificate of a component*)
Variable getCertificate: Component -> Certificate.

(* Overlap / Überlappung*)

(* get positions (x,y) of overlap in a variable*)
Definition overlap (c1 c2: list Fact) (key: Key): (option nat*option  nat) :=
match (get_pos c1 key), (get_pos c2 key) with

      | None, None  => (None, None)
      | x, None => (None, None)
      | None, y  => (None, None)
      | x, y => (x,y)

      end.

Definition overlapping_in_var (c1 c2: Certificate) (k:Key):=
exists (x y :nat), (Some x, Some y) = overlap c1 c2 k.

(* Connectivity / Zusammenhang*)

(* auf Pfad bezogen*)
Definition path_connected_in_var (comp1 comp2:Component) (vl : V_list) (el : E_list) (p : Path v a comp1 comp2  vl el) (k:Key) :=
forall (comp3 comp4:Component),In comp3 (comp1::vl) -> In comp4 (comp1::vl)
-> overlapping_in_var  (getCertificate comp3) (getCertificate comp4) k.

Definition all_fact_path_prop (comp1 comp2:Component) (vl : V_list) (el : E_list) (p : Path v a comp1 comp2  vl el):=
forall (k:Key), path_connected_in_var comp1 comp2 vl el p k .

Lemma pathprop_ind:
forall comp1 comp2 a0 vl el k x (p:Path v a comp1 comp2 (a0 :: vl) el) (p0:Path v a a0 comp2 vl x),
path_connected_in_var comp1 comp2 (a0 :: vl) el p k -> path_connected_in_var a0 comp2 vl x p0 k.
Proof.
intros.
unfold path_connected_in_var in *.
intros.
apply H .
unfold In.
right.
unfold In in H0.
trivial.
unfold In.
right.
unfold In in H1.
trivial.
Qed.

(* auf Netzwerk bezogen*)

Definition witness_connected_in_var (con : Connected v a) (k:Key):=
forall (comp1 comp2: Component), (v comp1) -> (v comp2) ->
{vl : V_list &  {el : E_list & { p: Path v a comp1 comp2 vl el &
path_connected_in_var comp1 comp2 vl el p k}}}.

Definition witness_connected (con : Connected v a):=
forall k, witness_connected_in_var con k.

(* Consistency / Konsistenz *)

Definition consistent_in_var (c1 c2: Certificate) (k:Key):=
forall (x y :nat ), ((Some x, Some y) = overlap c1 c2 k ->
eq (findValue c1 (Some x)) (findValue c2 (Some y))).

Definition consistent_in_all_var (c1 c2: Certificate) :=
forall (k:Key), consistent_in_var c1 c2 k.

Definition consistent_alt (c1 c2: Certificate):=
forall k, overlapping_in_var c1 c2 k ->
eq (findValue c1 (get_pos c1 k)) (findValue c2 (get_pos c2 k)).

Theorem consistency_defs:
forall c1 c2,
 consistent_alt  c1 c2 <-> consistent_in_all_var c1 c2.
Proof.
intros.
split.
intros.
unfold consistent_alt  in *.
unfold consistent_in_all_var in *.
unfold consistent_in_var.
intros.
assert (G:=H0).
unfold overlap in G.
repeat break_match.
inversion G.
rewrite <- Heqo. rewrite <- Heqo0. apply H.
unfold overlapping_in_var.
exists x. exists y. trivial.
discriminate.
discriminate.
discriminate.
intros.
unfold consistent_alt  in *.
unfold consistent_in_all_var in *.
unfold consistent_in_var in *.
intros.
unfold overlapping_in_var in *.
destruct H0.
destruct H0.
assert (G:=H0).
unfold overlap in H0.
repeat break_match.
inversion H0.
apply H with (k:=k) (x:=n) (y:=n0).
rewrite H2 in G. rewrite H3 in G; trivial.
discriminate.
discriminate.
discriminate.
Qed.

Definition one_neighbour_consistency (comp :Component)(comp1: Component) :=
In comp1 (neighbors g comp) -> consistent_in_all_var (getCertificate comp)(getCertificate comp1).

Definition all_neighbourhoods_consistent2 (comp :Component) :=
forall (comp1: Component), one_neighbour_consistency comp comp1.

Definition neighbourhood_consistent (comp :Component) :=
forall (comp1: Component), In comp1 (neighbors g comp) ->
consistent_in_all_var (getCertificate comp)(getCertificate comp1).

Lemma neighbourcon:
forall c, all_neighbourhoods_consistent2 c <-> neighbourhood_consistent c.
Proof.
intros.
split.
intros.
unfold all_neighbourhoods_consistent2 in *.
unfold neighbourhood_consistent.
unfold one_neighbour_consistency in H.
intros.
apply H.
trivial.
intros.
unfold all_neighbourhoods_consistent2 in *.
unfold neighbourhood_consistent in *.
unfold one_neighbour_consistency in *.
intros.
apply H.
trivial.
Qed.

Definition all_neighbourhoods_consistent :=
forall (comp:Component), (v comp) -> neighbourhood_consistent comp.

(** Network Consistency **)

Definition witness_consistent (con: Connected v a):=
forall (comp1 comp2: Component), (v comp1) -> (v comp2) -> consistent_in_all_var (getCertificate comp1) (getCertificate comp2).

(** Proofs **)

(* helping propertiesof overlap function*)

Lemma overlap_injective_1:
forall x y comp1 comp2 k,
(Some x, Some y) = overlap (getCertificate comp1) (getCertificate comp2) k <->
Some x = (get_pos (getCertificate comp1) k ) /\
Some y = (get_pos (getCertificate comp2) k).
Proof.
intros.
split.
intros.
unfold overlap in *.
repeat break_match.
inversion H.
auto.
inversion H.
inversion H.
inversion H.
(*2. implication *)
intros.
unfold overlap.
repeat break_match.
inversion H.
rewrite H0.
rewrite H1.
reflexivity.
inversion H.
inversion H1.
inversion H.
inversion H1.
inversion H.
inversion H2.
inversion H.
inversion H0.
Qed.

(* auf Pfad bezogen*)
Lemma overlap_injective:
forall x0 x1 x2 x3 comp1 comp2 comp3 k,
   (Some x0, Some x1) = overlap (getCertificate comp1) (getCertificate comp2) k /\
   (Some x2, Some x3) = overlap (getCertificate comp2) (getCertificate comp3) k ->
   x1=x2 .
Proof.
intros.
destruct H.
unfold overlap in *.
repeat break_match.
inversion H.
inversion H0.
reflexivity.

inversion H.
inversion H0.
inversion H.
inversion H0.
inversion H.
inversion H0.
inversion H.
Qed.

Lemma overlap_interchangeable:
forall x y comp1 comp2 k,
(Some x, Some y) = overlap (getCertificate comp1) (getCertificate comp2) k <->
(Some y, Some x) = overlap (getCertificate comp2) (getCertificate comp1) k.
Proof.
intros.
split.
intros.
unfold overlap in *.
repeat break_match.
inversion H.
trivial.
inversion H.
inversion H.
inversion H.
intros.
unfold overlap in *.
repeat break_match.
inversion H.
trivial.
inversion H.
inversion H.
inversion H.
Qed.

Lemma transitivity_of_consistent_in_var:
forall comp1 comp2 comp3 k x y vl el (p:Path v a x y vl el ),
v comp1 -> v comp2 -> v comp3 -> v x -> v y ->
In comp1 (x::vl) -> In comp2 (x::vl) -> In comp3 (x::vl) ->
path_connected_in_var x y vl el p k
->
consistent_in_var (getCertificate comp1) (getCertificate comp2) k /\
consistent_in_var (getCertificate comp2) (getCertificate comp3) k ->
consistent_in_var (getCertificate comp1) (getCertificate comp3) k.
Proof.
intros.
unfold path_connected_in_var in *.
destruct H8.

unfold consistent_in_var  in *.
unfold overlapping_in_var in *.
destruct H7 with (comp3:=comp1) (comp4:=comp2);trivial.
destruct H10.
assert (J:=H10).
destruct H7 with (comp3:=comp2) (comp4:=comp3);trivial.
destruct H11.
assert (L:=H11).
assert ( (Some x0, Some x1) =
 overlap (getCertificate comp1) (getCertificate comp2) k /\ (Some x2, Some x3) =
 overlap (getCertificate comp2) (getCertificate comp3) k) .
split.
trivial.
trivial.
apply overlap_injective in H12.
rewrite <- H12 in H11.
apply H8 in J.
apply H9 in H11.
intros.
assert (B:=H13).
apply overlap_interchangeable in B.
assert ((Some y0, Some x4) =
    overlap (getCertificate comp3) (getCertificate comp1) k /\
      (Some x0, Some x1) =
      overlap (getCertificate comp1) (getCertificate comp2) k).
split.
trivial.
trivial.

apply overlap_injective in H14.
symmetry in H14.
rewrite H14 in J.
assert ( (Some x2, Some x3) =
    overlap (getCertificate comp2) (getCertificate comp3) k /\ (Some y0, Some x4) =
    overlap (getCertificate comp3) (getCertificate comp1) k).
split.
trivial.
trivial.
apply overlap_injective in H15.
rewrite H11 in J.
rewrite <- H15.

trivial.
Qed.

(* reflexivity for consistent_in_all_var *)
Lemma consistent_in_var_reflexive:
forall comp k, consistent_in_var comp comp k.
Proof.
intros.
unfold consistent_in_var.
intros.
unfold overlap in *.
break_match.
inversion H.
reflexivity.
inversion H.
Qed.

(* commutativity for consistent_in_all_var *)
Lemma consistent_in_var_sym:
forall comp1 comp2 k,
consistent_in_var (getCertificate comp1) (getCertificate comp2) k <->  consistent_in_var (getCertificate comp2) (getCertificate comp1) k.
Proof.
intros.
split.
intros.
unfold consistent_in_var in *.
intros.
apply overlap_interchangeable in H0.
apply H in H0.
symmetry.
trivial.
intros.
unfold consistent_in_var in *.
intros.
apply overlap_interchangeable in H0.
apply H in H0.
symmetry.
trivial.
Qed.

Lemma path_one_var_consistency_ :
forall vl comp1 comp2 comp3 el k (p: Path v a comp1 comp2 vl el ), v comp1 ->
v comp2 -> v comp3 ->
path_connected_in_var comp1 comp2 vl el p k ->
all_neighbourhoods_consistent  ->
In comp3 vl ->
consistent_in_var (getCertificate comp3) (getCertificate comp1) k.
Proof.
intros  vl.
induction vl.
intros.
inversion H4.
intros.
destruct H4.

assert (Q:=p).
apply neighbourslist2 in Q.
unfold all_neighbourhoods_consistent in *.
unfold neighbourhood_consistent in *.
rewrite <- H4.

unfold consistent_in_all_var in *.
apply H3.
rewrite <- H4 in H1.
trivial.
trivial.

(*transitivität*)
assert (TRANS: consistent_in_var (getCertificate comp3) (getCertificate a0) k /\ consistent_in_var (getCertificate a0)(getCertificate comp1) k).

split.
(*1. fall : beide in vl, Anwendung der Hypothese*)
assert (Q:=p).
apply P_backstep in Q.
destruct Q.
apply IHvl with (comp2:=comp2)(el:=x)(p:=p0).
apply P_endx_inv in p0.
trivial.
trivial.
trivial.
apply pathprop_ind with (x:=x) (p0:=p0) in H2.
trivial.

trivial.
trivial.

assert (path:=p).
apply neighbourslist2 in path.
unfold all_neighbourhoods_consistent in *.
unfold neighbourhood_consistent in *.
unfold consistent_in_all_var in *.
apply H3.
assert (path':=p).
apply P_backstep in path'.
destruct path'.
apply P_endx_inv in p0.
trivial.
trivial.

apply transitivity_of_consistent_in_var  with (x:=comp1) (y:=comp2) (vl:=a0::vl) (el:=el) (p:=p) in TRANS.
trivial.

(*neu*)
trivial.
assert (G:=p).
apply P_backstep in G.
destruct G.
apply P_endx_inv in p0.
trivial.
trivial.
trivial.
trivial.
unfold In.
right.
right.
unfold In in H4.
trivial.
unfold In.
right.
auto.
unfold In.
auto.
trivial.
Qed.

(** Theorem **)

Theorem consistency_checkable:
witness_connected g -> all_neighbourhoods_consistent -> witness_consistent g.
Proof.
intros.
unfold witness_consistent .
intros.
case (C_eq_dec  comp1 comp2).
intros.
rewrite e.
unfold consistent_in_all_var.
intros.
apply consistent_in_var_reflexive.
intros.
apply Connected_path with (a:=a) (x:=comp1) in H2;trivial.
destruct H2.
destruct s.
unfold consistent_in_all_var.
intros.
apply consistent_in_var_sym.

unfold witness_connected in *.
unfold witness_connected_in_var in*.
destruct H with (k:=k) (comp1:=comp1) (comp2:=comp2).

trivial.
apply P_endy_inv in p.
trivial.
destruct s.
destruct s.

apply path_one_var_consistency_ with (comp3:=comp2) (comp1:=comp1) (comp2:=comp2) (vl:=x1) (el:=x2) (k:=k)(p:=x3).
trivial.
apply P_endy_inv in p.
trivial.
apply P_endy_inv in p.
trivial.
trivial.
trivial.
assert (lol:=x3).
apply P_iny_vl in lol.
trivial.
inversion lol.
contradiction.
unfold V_nil.
discriminate.
apply g.
Qed.


Require Import String.
Require Import Names.
Require Import PNames.
Require Import Bool.
Require Import Lambda.
Require Import Bool_Lambda.
Require Import Functors.
(* Require Import MonadLib. *)

Open Scope string_scope.

Section Type_Test_Section.
  (* Type Testing, of course. *)
  Definition D := BType :+: LType.

End Type_Test_Section.

Section Test_Section.

  Definition E (A : Set) := Bool :+: (Lambda D A).

  Global Instance Fun_E : forall (A : Set),
    Functor (E A).
  Proof.
    eauto with typeclass_instances.
  Defined.

  Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
    eauto 150 with typeclass_instances.
  Defined.

  Definition V := StuckValue :+: BotValue :+: (ClosValue E) :+: BoolValue.

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    eauto 150 with typeclass_instances.
  Defined.

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

   Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E _) SV))) (E nat).
    eauto 150 with typeclass_instances.
   Defined.

  Definition eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto 150 with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven!").

  Definition Eqv (A B : Set) := (NP_Functor_eqv E Bool A B) ::+:: (Lambda_eqv D E A B).
  Definition WFV := (WFValue_Clos D E V Eqv ((fun e => typeof _ _ (proj1_sig e)))) ::+::
    (WFValue_Bot D V) ::+:: (WFValue_VB D V).

  Instance eq_DType_eq_alg : (PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D).
    eauto 250 with typeclass_instances.
  Defined.

  Global Instance Bool_Soundness_alg P_bind P pb typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name
    (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P
      (E (typeofR D)) (Functor_Plus Bool (Lambda D (typeofR D))) pb typeof_rec eval_rec
      f_algebra f_algebra))) Bool.
  Proof.
    eauto 100 with typeclass_instances.
  Defined.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 350 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for Lambda :+: Boolean Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Require Import Ranalysis2.
Open Local Scope R_scope.

(** Division *)
Theorem derivable_pt_lim_div :
  forall (f1 f2:R -> R) (x l1 l2:R),
    derivable_pt_lim f1 x l1 ->
    derivable_pt_lim f2 x l2 ->
    f2 x <> 0 ->
    derivable_pt_lim (f1 / f2) x ((l1 * f2 x - l2 * f1 x) / Rsqr (f2 x)).
Proof.
  intros f1 f2 x l1 l2 H H0 H1.
  cut (derivable_pt f2 x);
    [ intro X | unfold derivable_pt in |- *; exists l2; exact H0 ].
  assert (H2 := continuous_neq_0 _ _ (derivable_continuous_pt _ _ X) H1).
  elim H2; clear H2; intros eps_f2 H2.
  unfold div_fct in |- *.
  assert (H3 := derivable_continuous_pt _ _ X).
  unfold continuity_pt in H3; unfold continue_in in H3; unfold limit1_in in H3;
    unfold limit_in in H3; unfold dist in H3.
  simpl in H3; unfold R_dist in H3.
  elim (H3 (Rabs (f2 x) / 2));
    [ idtac
      | unfold Rdiv in |- *; change (0 < Rabs (f2 x) * / 2) in |- *;
        apply Rmult_lt_0_compat;
          [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  clear H3; intros alp_f2 H3.
  cut
    (forall x0:R,
      Rabs (x0 - x) < alp_f2 -> Rabs (f2 x0 - f2 x) < Rabs (f2 x) / 2).
  intro H4.
  cut (forall a:R, Rabs (a - x) < alp_f2 -> Rabs (f2 x) / 2 < Rabs (f2 a)).
  intro H5.
  cut
    (forall a:R,
      Rabs a < Rmin eps_f2 alp_f2 -> / Rabs (f2 (x + a)) < 2 / Rabs (f2 x)).
  intro Maj.
  unfold derivable_pt_lim in |- *; intros.
  elim (H (Rabs (eps * f2 x / 8)));
    [ idtac
      | unfold Rdiv in |- *; change (0 < Rabs (eps * f2 x * / 8)) in |- *;
        apply Rabs_pos_lt; repeat apply prod_neq_R0;
          [ red in |- *; intro H7; rewrite H7 in H6; elim (Rlt_irrefl _ H6)
            | assumption
            | apply Rinv_neq_0_compat; discrR ] ].
  intros alp_f1d H7.
  case (Req_dec (f1 x) 0); intro.
  case (Req_dec l1 0); intro.
(***********************************)
(*              First case         *)
(*           (f1 x)=0  l1 =0       *)
(***********************************)
  cut (0 < Rmin eps_f2 (Rmin alp_f2 alp_f1d));
    [ intro
      | repeat apply Rmin_pos;
        [ apply (cond_pos eps_f2)
          | elim H3; intros; assumption
          | apply (cond_pos alp_f1d) ] ].
  exists (mkposreal (Rmin eps_f2 (Rmin alp_f2 alp_f1d)) H10).
  simpl in |- *; intros.
  assert (H13 := Rlt_le_trans _ _ _ H12 (Rmin_r _ _)).
  assert (H14 := Rlt_le_trans _ _ _ H12 (Rmin_l _ _)).
  assert (H15 := Rlt_le_trans _ _ _ H13 (Rmin_r _ _)).
  assert (H16 := Rlt_le_trans _ _ _ H13 (Rmin_l _ _)).
  assert (H17 := H7 _ H11 H15).
  rewrite formule; [ idtac | assumption | assumption | apply H2; apply H14 ].
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite H8.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite H8.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite H9.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2);
    try assumption || apply H2.
  apply H14.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
(***********************************)
(*           Second case           *)
(*           (f1 x)=0  l1<>0       *)
(***********************************)
  assert (H10 := derivable_continuous_pt _ _ X).
  unfold continuity_pt in H10.
  unfold continue_in in H10.
  unfold limit1_in in H10.
  unfold limit_in in H10.
  unfold dist in H10.
  simpl in H10.
  unfold R_dist in H10.
  elim (H10 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
  clear H10; intros alp_f2t2 H10.
  cut
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  intro H11.
  cut (0 < Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)).
  intro.
  exists (mkposreal (Rmin (Rmin eps_f2 alp_f1d) (Rmin alp_f2 alp_f2t2)) H12).
  simpl in |- *.
  intros.
  assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
  assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
  assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
  assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
  clear H14 H15 H16.
  rewrite formule; try assumption.
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite H8.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite H8.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
  apply H2; assumption.
  repeat apply Rmin_pos.
  apply (cond_pos eps_f2).
  apply (cond_pos alp_f1d).
  elim H3; intros; assumption.
  elim H10; intros; assumption.
  intros.
  elim H10; intros.
  case (Req_dec a 0); intro.
  rewrite H14; rewrite Rplus_0_r.
  unfold Rminus in |- *; rewrite Rplus_opp_r.
  rewrite Rabs_R0.
  apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc.
  repeat apply prod_neq_R0; try assumption.
  red in |- *; intro; rewrite H15 in H6; elim (Rlt_irrefl _ H6).
  apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption.
  apply H13.
  split.
  apply D_x_no_cond; assumption.
  replace (x + a - x) with a; [ assumption | ring ].
  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
  apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
    repeat apply prod_neq_R0.
  red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
  assumption.
  assumption.
  apply Rinv_neq_0_compat; repeat apply prod_neq_R0;
    [ discrR | discrR | discrR | assumption ].
(***********************************)
(*        Third case               *)
(*     (f1 x)<>0  l1=0  l2=0       *)
(***********************************)
  case (Req_dec l1 0); intro.
  case (Req_dec l2 0); intro.
  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
    [ idtac
      | apply Rabs_pos_lt; unfold Rdiv, Rsqr in |- *; repeat rewrite Rmult_assoc;
        repeat apply prod_neq_R0;
          [ assumption
            | assumption
            | red in |- *; intro; rewrite H11 in H6; elim (Rlt_irrefl _ H6)
            | apply Rinv_neq_0_compat; repeat apply prod_neq_R0; discrR || assumption ] ].
  intros alp_f2d H12.
  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)).
  intro.
  exists (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d)) H11).
  simpl in |- *.
  intros.
  assert (H15 := Rlt_le_trans _ _ _ H14 (Rmin_l _ _)).
  assert (H16 := Rlt_le_trans _ _ _ H14 (Rmin_r _ _)).
  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
  assert (H19 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
  assert (H20 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
  clear H15 H16.
  rewrite formule; try assumption.
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite H10.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite H9.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); assumption || idtac.
  apply H2; assumption.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
  apply H2; assumption.
  repeat apply Rmin_pos.
  apply (cond_pos eps_f2).
  elim H3; intros; assumption.
  apply (cond_pos alp_f1d).
  apply (cond_pos alp_f2d).
(***********************************)
(*      Fourth case                *)
(*    (f1 x)<>0  l1=0  l2<>0       *)
(***********************************)
  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x))));
    [ idtac
      | apply Rabs_pos_lt; unfold Rsqr, Rdiv in |- *;
        repeat rewrite Rinv_mult_distr; repeat apply prod_neq_R0;
          try assumption || discrR ].
  intros alp_f2d H11.
  assert (H12 := derivable_continuous_pt _ _ X).
  unfold continuity_pt in H12.
  unfold continue_in in H12.
  unfold limit1_in in H12.
  unfold limit_in in H12.
  unfold dist in H12.
  simpl in H12.
  unfold R_dist in H12.
  elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
  intros alp_f2c H13.
  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c))).
  intro.
  exists
    (mkposreal (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2c)))
      H14).
  simpl in |- *; intros.
  assert (H17 := Rlt_le_trans _ _ _ H16 (Rmin_l _ _)).
  assert (H18 := Rlt_le_trans _ _ _ H16 (Rmin_r _ _)).
  assert (H19 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
  assert (H20 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
  assert (H21 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
  assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
  assert (H23 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
  assert (H24 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
  clear H16 H17 H18 H19.
  cut
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  intro.
  rewrite formule; try assumption.
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite H9.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
  apply H2; assumption.
  intros.
  case (Req_dec a 0); intro.
  rewrite H17; rewrite Rplus_0_r.
  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0.
  apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *.
  repeat rewrite Rinv_mult_distr; try assumption.
  repeat apply prod_neq_R0; try assumption.
  red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6).
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; assumption.
  apply Rinv_neq_0_compat; assumption.
  discrR.
  discrR.
  discrR.
  discrR.
  discrR.
  apply prod_neq_R0; [ discrR | assumption ].
  elim H13; intros.
  apply H19.
  split.
  apply D_x_no_cond; assumption.
  replace (x + a - x) with a; [ assumption | ring ].
  repeat apply Rmin_pos.
  apply (cond_pos eps_f2).
  elim H3; intros; assumption.
  apply (cond_pos alp_f1d).
  apply (cond_pos alp_f2d).
  elim H13; intros; assumption.
  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *.
  apply Rabs_pos_lt.
  unfold Rsqr, Rdiv in |- *.
  repeat rewrite Rinv_mult_distr; try assumption || discrR.
  repeat apply prod_neq_R0; try assumption.
  red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6).
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; assumption.
  apply Rinv_neq_0_compat; assumption.
  apply prod_neq_R0; [ discrR | assumption ].
  red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6).
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; discrR.
  apply Rinv_neq_0_compat; assumption.
(***********************************)
(*         Fifth case              *)
(*    (f1 x)<>0  l1<>0  l2=0       *)
(***********************************)
  case (Req_dec l2 0); intro.
  assert (H11 := derivable_continuous_pt _ _ X).
  unfold continuity_pt in H11.
  unfold continue_in in H11.
  unfold limit1_in in H11.
  unfold limit_in in H11.
  unfold dist in H11.
  simpl in H11.
  unfold R_dist in H11.
  elim (H11 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
  clear H11; intros alp_f2t2 H11.
  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
  intros alp_f2d H12.
  cut (0 < Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))).
  intro.
  exists
    (mkposreal
      (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d (Rmin alp_f2d alp_f2t2))) H13).
  simpl in |- *.
  intros.
  cut
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  intro.
  assert (H17 := Rlt_le_trans _ _ _ H15 (Rmin_l _ _)).
  assert (H18 := Rlt_le_trans _ _ _ H15 (Rmin_r _ _)).
  assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
  assert (H20 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
  assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
  assert (H22 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
  assert (H23 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
  assert (H24 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
  clear H15 H17 H18 H21.
  rewrite formule; try assumption.
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite H10.
  unfold Rdiv in |- *; repeat rewrite Rmult_0_r || rewrite Rmult_0_l.
  rewrite Rabs_R0; rewrite Rmult_0_l.
  apply Rmult_lt_0_compat; [ assumption | apply Rinv_0_lt_compat; prove_sup ].
  rewrite <- Rabs_mult.
  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
  apply H2; assumption.
  intros.
  case (Req_dec a 0); intro.
  rewrite H17; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
    rewrite Rabs_R0.
  apply Rabs_pos_lt.
  unfold Rdiv in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
  unfold Rsqr in |- *.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H18; rewrite H18 in H6; elim (Rlt_irrefl _ H6)).
  elim H11; intros.
  apply H19.
  split.
  apply D_x_no_cond; assumption.
  replace (x + a - x) with a; [ assumption | ring ].
  repeat apply Rmin_pos.
  apply (cond_pos eps_f2).
  elim H3; intros; assumption.
  apply (cond_pos alp_f1d).
  apply (cond_pos alp_f2d).
  elim H11; intros; assumption.
  apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *.
  apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H12; rewrite H12 in H6; elim (Rlt_irrefl _ H6)).
(***********************************)
(*       Sixth case                *)
(*    (f1 x)<>0  l1<>0  l2<>0      *)
(***********************************)
  elim (H0 (Rabs (Rsqr (f2 x) * eps / (8 * f1 x)))).
  intros alp_f2d H11.
  assert (H12 := derivable_continuous_pt _ _ X).
  unfold continuity_pt in H12.
  unfold continue_in in H12.
  unfold limit1_in in H12.
  unfold limit_in in H12.
  unfold dist in H12.
  simpl in H12.
  unfold R_dist in H12.
  elim (H12 (Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2)))).
  intros alp_f2c H13.
  elim (H12 (Rabs (eps * Rsqr (f2 x) / (8 * l1)))).
  intros alp_f2t2 H14.
  cut
    (0 <
      Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
      (Rmin alp_f2c alp_f2t2)).
  intro.
  exists
    (mkposreal
      (Rmin (Rmin (Rmin eps_f2 alp_f2) (Rmin alp_f1d alp_f2d))
        (Rmin alp_f2c alp_f2t2)) H15).
  simpl in |- *.
  intros.
  assert (H18 := Rlt_le_trans _ _ _ H17 (Rmin_l _ _)).
  assert (H19 := Rlt_le_trans _ _ _ H17 (Rmin_r _ _)).
  assert (H20 := Rlt_le_trans _ _ _ H18 (Rmin_l _ _)).
  assert (H21 := Rlt_le_trans _ _ _ H18 (Rmin_r _ _)).
  assert (H22 := Rlt_le_trans _ _ _ H19 (Rmin_l _ _)).
  assert (H23 := Rlt_le_trans _ _ _ H19 (Rmin_r _ _)).
  assert (H24 := Rlt_le_trans _ _ _ H20 (Rmin_l _ _)).
  assert (H25 := Rlt_le_trans _ _ _ H20 (Rmin_r _ _)).
  assert (H26 := Rlt_le_trans _ _ _ H21 (Rmin_l _ _)).
  assert (H27 := Rlt_le_trans _ _ _ H21 (Rmin_r _ _)).
  clear H17 H18 H19 H20 H21.
  cut
    (forall a:R,
      Rabs a < alp_f2t2 ->
      Rabs (f2 (x + a) - f2 x) < Rabs (eps * Rsqr (f2 x) / (8 * l1))).
  cut
    (forall a:R,
      Rabs a < alp_f2c ->
      Rabs (f2 (x + a) - f2 x) <
      Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))).
  intros.
  rewrite formule; try assumption.
  apply Rle_lt_trans with
    (Rabs (/ f2 (x + h) * ((f1 (x + h) - f1 x) / h - l1)) +
      Rabs (l1 / (f2 x * f2 (x + h)) * (f2 x - f2 (x + h))) +
      Rabs (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) - f2 x) / h - l2)) +
      Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h)) * (f2 (x + h) - f2 x))).
  unfold Rminus in |- *.
  rewrite <-
    (Rabs_Ropp (f1 x / (f2 x * f2 (x + h)) * ((f2 (x + h) + - f2 x) / h + - l2)))
    .
  apply Rabs_4.
  repeat rewrite Rabs_mult.
  apply Rlt_le_trans with (eps / 4 + eps / 4 + eps / 4 + eps / 4).
  cut (Rabs (/ f2 (x + h)) * Rabs ((f1 (x + h) - f1 x) / h - l1) < eps / 4).
  cut (Rabs (l1 / (f2 x * f2 (x + h))) * Rabs (f2 x - f2 (x + h)) < eps / 4).
  cut
    (Rabs (f1 x / (f2 x * f2 (x + h))) * Rabs ((f2 (x + h) - f2 x) / h - l2) <
      eps / 4).
  cut
    (Rabs (l2 * f1 x / (Rsqr (f2 x) * f2 (x + h))) * Rabs (f2 (x + h) - f2 x) <
      eps / 4).
  intros.
  apply Rlt_4; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term4 x h eps l2 alp_f2 alp_f2c eps_f2 f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term3 x h eps l2 alp_f2 eps_f2 alp_f2d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term2 x h eps l1 alp_f2 alp_f2t2 eps_f2 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  rewrite <- Rabs_mult.
  apply (maj_term1 x h eps l1 alp_f2 eps_f2 alp_f1d f1 f2); try assumption.
  apply H2; assumption.
  apply Rmin_2; assumption.
  right; symmetry  in |- *; apply quadruple_var.
  apply H2; assumption.
  intros.
  case (Req_dec a 0); intro.
  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
    rewrite Rabs_R0; apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
  apply prod_neq_R0; [ discrR | assumption ].
  apply prod_neq_R0; [ discrR | assumption ].
  assumption.
  elim H13; intros.
  apply H20.
  split.
  apply D_x_no_cond; assumption.
  replace (x + a - x) with a; [ assumption | ring ].
  intros.
  case (Req_dec a 0); intro.
  rewrite H18; rewrite Rplus_0_r; unfold Rminus in |- *; rewrite Rplus_opp_r;
    rewrite Rabs_R0; apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H28; rewrite H28 in H6; elim (Rlt_irrefl _ H6)).
  discrR.
  assumption.
  elim H14; intros.
  apply H20.
  split.
  unfold D_x, no_cond in |- *; split.
  trivial.
  apply Rminus_not_eq_right.
  replace (x + a - x) with a; [ assumption | ring ].
  replace (x + a - x) with a; [ assumption | ring ].
  repeat apply Rmin_pos.
  apply (cond_pos eps_f2).
  elim H3; intros; assumption.
  apply (cond_pos alp_f1d).
  apply (cond_pos alp_f2d).
  elim H13; intros; assumption.
  elim H14; intros; assumption.
  change (0 < Rabs (eps * Rsqr (f2 x) / (8 * l1))) in |- *; apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr; try discrR || assumption.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H14; rewrite H14 in H6; elim (Rlt_irrefl _ H6)).
  change (0 < Rabs (Rsqr (f2 x) * f2 x * eps / (8 * f1 x * l2))) in |- *;
    apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr.
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H13; rewrite H13 in H6; elim (Rlt_irrefl _ H6)).
  apply prod_neq_R0; [ discrR | assumption ].
  apply prod_neq_R0; [ discrR | assumption ].
  assumption.
  apply Rabs_pos_lt.
  unfold Rdiv, Rsqr in |- *; rewrite Rinv_mult_distr;
    [ idtac | discrR | assumption ].
  repeat apply prod_neq_R0;
    assumption ||
      (apply Rinv_neq_0_compat; assumption) ||
        (apply Rinv_neq_0_compat; discrR) ||
          (red in |- *; intro H11; rewrite H11 in H6; elim (Rlt_irrefl _ H6)).
  intros.
  unfold Rdiv in |- *.
  apply Rmult_lt_reg_l with (Rabs (f2 (x + a))).
  apply Rabs_pos_lt; apply H2.
  apply Rlt_le_trans with (Rmin eps_f2 alp_f2).
  assumption.
  apply Rmin_l.
  rewrite <- Rinv_r_sym.
  apply Rmult_lt_reg_l with (Rabs (f2 x)).
  apply Rabs_pos_lt; assumption.
  rewrite Rmult_1_r.
  rewrite (Rmult_comm (Rabs (f2 x))).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r.
  apply Rmult_lt_reg_l with (/ 2).
  apply Rinv_0_lt_compat; prove_sup0.
  repeat rewrite (Rmult_comm (/ 2)).
  repeat rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  unfold Rdiv in H5; apply H5.
  replace (x + a - x) with a.
  assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_r _ _)); assumption.
  ring.
  discrR.
  apply Rabs_no_R0; assumption.
  apply Rabs_no_R0; apply H2.
  assert (H7 := Rlt_le_trans _ _ _ H6 (Rmin_l _ _)); assumption.
  intros.
  assert (H6 := H4 a H5).
  rewrite <- (Rabs_Ropp (f2 a - f2 x)) in H6.
  rewrite Ropp_minus_distr in H6.
  assert (H7 := Rle_lt_trans _ _ _ (Rabs_triang_inv _ _) H6).
  apply Rplus_lt_reg_r with (- Rabs (f2 a) + Rabs (f2 x) / 2).
  rewrite Rplus_assoc.
  rewrite <- double_var.
  do 2 rewrite (Rplus_comm (- Rabs (f2 a))).
  rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
  unfold Rminus in H7; assumption.
  intros.
  case (Req_dec x x0); intro.
  rewrite <- H5; unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0;
    unfold Rdiv in |- *; apply Rmult_lt_0_compat;
      [ apply Rabs_pos_lt; assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  elim H3; intros.
  apply H7.
  split.
  unfold D_x, no_cond in |- *; split.
  trivial.
  assumption.
  assumption.
Qed.

Lemma derivable_pt_div :
  forall (f1 f2:R -> R) (x:R),
    derivable_pt f1 x ->
    derivable_pt f2 x -> f2 x <> 0 -> derivable_pt (f1 / f2) x.
Proof.
  unfold derivable_pt in |- *.
  intros f1 f2 x X X0 H.
  elim X; intros.
  elim X0; intros.
  exists ((x0 * f2 x - x1 * f1 x) / Rsqr (f2 x)).
  apply derivable_pt_lim_div; assumption.
Qed.

Lemma derivable_div :
  forall f1 f2:R -> R,
    derivable f1 ->
    derivable f2 -> (forall x:R, f2 x <> 0) -> derivable (f1 / f2).
Proof.
  unfold derivable in |- *; intros f1 f2 X X0 H x.
  apply (derivable_pt_div _ _ _ (X x) (X0 x) (H x)).
Qed.

Lemma derive_pt_div :
  forall (f1 f2:R -> R) (x:R) (pr1:derivable_pt f1 x)
    (pr2:derivable_pt f2 x) (na:f2 x <> 0),
    derive_pt (f1 / f2) x (derivable_pt_div _ _ _ pr1 pr2 na) =
    (derive_pt f1 x pr1 * f2 x - derive_pt f2 x pr2 * f1 x) / Rsqr (f2 x).
Proof.
  intros.
  assert (H := derivable_derive f1 x pr1).
  assert (H0 := derivable_derive f2 x pr2).
  assert
    (H1 := derivable_derive (f1 / f2)%F x (derivable_pt_div _ _ _ pr1 pr2 na)).
  elim H; clear H; intros l1 H.
  elim H0; clear H0; intros l2 H0.
  elim H1; clear H1; intros l H1.
  rewrite H; rewrite H0; apply derive_pt_eq_0.
  assert (H3 := proj2_sig pr1).
  unfold derive_pt in H; rewrite H in H3.
  assert (H4 := proj2_sig pr2).
  unfold derive_pt in H0; rewrite H0 in H4.
  apply derivable_pt_lim_div; assumption.
Qed.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

From Equations Require Import Equations.

Variable test : forall n : nat, (nat -> bool) -> nat.

Equations f : nat -> nat :=
  f 0 := 0;
  f (S n) := f n.

Equations f' (n : nat) : nat :=
  f' n := test n (λ{ | 0 => true ;
                     | S n => false }).

Definition foo (x : nat) :=
  f' match x with 0 => 0 | S x => 0 end.

Equations decideeq (b b' : bool) : (b = b') + (~ b = b') :=
  decideeq true true   => inl eq_refl;
  decideeq false false => inl eq_refl;
  decideeq false true  => inr (λ{ | ! });
  decideeq true false  => inr (λ{ | ! }).


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

Require Import Ensembles.
Require Import Relations_1.
Require Import Partial_Order.
Require Import Cpo.
Require Import algpodefs.
Require Import Powerset.
Require Import Constructive_sets.
Require Import Finite_sets.
Require Import lpo.
Require Import lpo1.
Section Advanced_lemmas.
Variable U : Type.
Variable D : PO U.
Hint Resolve Lub_definition Upper_Bound_Couple_intro.

Lemma Lub_monotonic :
 forall A B : Ensemble U,
 Included U A B ->
 Included U B (Carrier_of U D) ->
 forall a b : U, Lub U D A a -> Lub U D B b -> Rel_of U D a b.
intros A B H' H'0 a b H'1 H'2; try assumption.
elim H'1; auto with sets.
intros H'3 H'4; apply H'4.
apply Upper_downward_stable with (B := B); auto with sets.
elim H'2; auto with sets.
Qed.

Lemma Compatible_lubs :
 forall A B C : Ensemble U,
 Included U A C ->
 Included U B C ->
 Included U C (Carrier_of U D) ->
 forall a b c : U,
 Lub U D A a -> Lub U D B b -> Lub U D C c -> Compatible U D a b.
intros A B C H' H'0 H'1 a b c H'2 H'3 H'4; red in |- *; simpl in |- *.
intros H'5 H'6; exists c; split.
apply Lub_is_in_Carrier with (X := C); auto with sets.
apply Upper_Bound_Couple_intro; auto with sets.
apply Lub_is_in_Carrier with (X := C); auto with sets.
apply Lub_monotonic with (A := A) (B := C); auto with sets.
apply Lub_monotonic with (A := B) (B := C); auto with sets.
Qed.

Lemma LUaux :
 forall A B : Ensemble U,
 Included U (Union U A B) (Carrier_of U D) ->
 forall a b bsup : U,
 Lub U D A a ->
 Lub U D B b -> Lub U D (Union U A B) bsup -> Lub U D (Couple U a b) bsup.
generalize Rel_of_transitive; intro RoT; red in RoT.
intros A B H' a b bsup H'0 H'1 H'2; try assumption.
elim H'0; elim H'1; elim H'2.
intros H'3 H'4 H'5 H'6 H'7 H'8; try assumption.
elim H'3; elim H'5; elim H'7.
intros H'9 H'10 H'11 H'12 H'13 H'14; try assumption.
apply Lub_definition; auto 8 with sets.
intros y H'15; apply H'4.
apply Upper_Bound_definition; auto with sets.
elim H'15; auto with sets.
elim (Upper_Bound_Couple_inv U D a b y);
 [ intros H'22 H'23; elim H'23; intros H'24 H'25; try exact H'24; clear H'23
 | idtac ]; auto with sets.
intros y0 H'16; elim H'16.
intros x H'17; apply RoT with (y := a); auto with sets.
intros x H'17; apply RoT with (y := b); auto with sets.
Qed.

Lemma LUaux2 :
 forall A B : Ensemble U,
 Included U (Union U A B) (Carrier_of U D) ->
 forall a b bsup : U,
 Lub U D A a ->
 Lub U D B b -> Lub U D (Couple U a b) bsup -> Lub U D (Union U A B) bsup.
generalize Rel_of_transitive; intro RoT; red in RoT.
intros A B H' a b bsup H'0 H'1 H'2; try assumption.
elim H'0; elim H'1; elim H'2.
intros H'3 H'4 H'5 H'6 H'7 H'8; try assumption.
elim H'5; elim H'7.
elim (Upper_Bound_Couple_inv U D a b bsup);
 [ intros H'15 H'16; elim H'16; intros H'17 H'18; try exact H'17; clear H'16
 | idtac ]; auto with sets.
intros H'9 H'10 H'11 H'12; try assumption.
apply Lub_definition; auto with sets.
apply Upper_Bound_definition; auto with sets.
intros y H'13; elim H'13.
intros x H'30; apply RoT with (y := a); auto with sets.
intros x H'30; apply RoT with (y := b); auto with sets.
intros y H'13; try assumption.
apply H'4.
elim H'13; auto 7 with sets.
Qed.

Theorem Lub_of_Union :
 Conditionally_complete U D ->
 forall A B : Ensemble U,
 Included U (Union U A B) (Carrier_of U D) ->
 forall x : U,
 In U (Carrier_of U D) x ->
 Upper_Bound U D (Union U A B) x ->
 forall a b : U,
 Lub U D A a ->
 Lub U D B b ->
 exists bsup : U, Lub U D (Union U A B) bsup /\ Lub U D (Couple U a b) bsup.
intro H'; elim H'.
intros H'0 A B H'1 x H'2 H'3 a b H'4 H'5; try assumption.
elim (H'0 (Union U A B)); [ intros bsup E; try exact E | idtac | idtac ];
 auto with sets.
2: exists x; try assumption.
exists bsup; split; [ try assumption | idtac ].
apply LUaux with (A := A) (B := B); auto with sets.
Qed.

Theorem Lub_of_compacts_is_compact :
 Conditionally_complete U D ->
 forall x y z : U,
 Included U (Couple U x y) (Approximants U D z) ->
 In U (Carrier_of U D) z ->
 exists bsup : U, Lub U D (Couple U x y) bsup /\ Approximant U D z bsup.
Proof.
intros H' x y z H'0 K; red in H'0.
elim (H'0 x); auto with sets.
intros c H'1 H'2.
elim (H'0 y); auto with sets.
intros c' H'3 H'4.
elim H'.
intro H'5; elim (H'5 (Couple U c c')); auto with sets.
2: elim H'1; elim H'3; exists z; auto with sets.
intros bsup H'6; elim H'6.
intros H'7 H'8; exists bsup; split; auto with sets.
apply Defn_of_Approximant; auto with sets.
apply Definition_of_compact.
apply Lub_is_in_Carrier with (X := Couple U c c'); auto with sets.
intros X H'9 H'10.
elim H'1.
intros H'11 H'12; try assumption.
elim H'3.
intros H'13 H'14; try assumption.
clear H'1 H'3.
elim H'10; intros bsup0 h; elim h; clear H'10 h.
intros H'1 H'3; try assumption.
generalize Rel_of_transitive; intro RoT; red in RoT.
elim (H'14 X); auto with sets.
intros x0 H'10; elim H'10; intros H'15 H'17; try exact H'17; clear H'10.
elim (H'12 X); auto with sets.
intros x1 H'10; elim H'10; intros H'18 H'20; try exact H'20; clear H'10.
elim H'9.
intros H'10 H'21 H'22; elim (H'22 x0 x1); auto with sets.
intros y' H'23; elim H'23; intros H'24 H'26; try exact H'24; clear H'23.
exists y'; split; auto with sets.
apply H'8.
elim (Upper_Bound_Couple_inv U D x0 x1 y');
 [ intros H'29 H'30; elim H'30; intros H'31 H'32; clear H'30 | idtac ];
 auto with sets.
apply Upper_Bound_Couple_intro; auto with sets.
apply RoT with (y := x1); auto with sets.
apply RoT with (y := x0); auto with sets.
red in |- *; simpl in |- *.
intros x2 H'23; elim H'23; auto with sets.
exists bsup0; split; auto with sets.
elim (Upper_Bound_Couple_inv U D c c' bsup);
 [ intros H'22 H'23; elim H'23; intros H'24 H'25; clear H'23 | idtac ];
 auto with sets.
apply RoT with (y := bsup); auto with sets.
exists bsup0; split; auto with sets.
elim (Upper_Bound_Couple_inv U D c c' bsup);
 [ intros H'20 H'21; elim H'21; intros H'22 H'23; clear H'21 | idtac ];
 auto with sets.
apply RoT with (y := bsup); auto with sets.
Qed.

Theorem approximants_closed_by_finite_lubs :
 Conditionally_complete U D ->
 forall (x : U) (C : Ensemble U),
 In U (Carrier_of U D) x ->
 Finite U C ->
 Included U C (Approximants U D x) ->
 exists bsup : U, Lub U D C bsup /\ Approximant U D x bsup.
intros H' x C H H'0; elim H'0.
elim (Bottom_is_compact U D);
 [ intros bot E; elim E; intros H'4 H'5; elim H'4; clear E | idtac ];
 auto with sets.
exists bot; split; auto with sets; auto with sets.
apply Lub_definition; auto with sets.
intros y H'1; elim H'1; auto with sets.
intros A H'1 H'2 x0 H'3.
cut (forall x : U, Union U A (Singleton U x) = Add U A x); auto with sets.
intro H'4; rewrite <- (H'4 x0).
clear H'4; intro H'4.
elim H'2; [ intros bsup E; elim E; intros H'6 H'7; clear E H'2 | clear H'2 ];
 auto with sets.
red in H'4.
lapply Lub_of_Union;
 [ intro H'2; lapply (H'2 A (Singleton U x0));
    [ intro H'9; lapply (H'9 x);
       [ intro H'11; lapply H'11;
          [ intro H'12; elim (H'12 bsup x0);
             [ intros bsup0 E; elim E; intros H'17 H'18; try exact H'17;
                clear E H'11
             | clear H'11
             | clear H'11 ]
          | clear H'11 ]
       | idtac ]
    | idtac ]
 | idtac ]; auto with sets.
exists bsup0; split; [ assumption | auto with sets ].
lapply Lub_of_compacts_is_compact;
 [ intro H'5; elim (H'5 bsup x0 x);
    [ intros bsup1 E; elim E; intros H'15 H'16; try exact H'16; clear E
    | idtac
    | idtac ]
 | idtac ]; auto with sets.
lapply (Lub_is_unique U D);
 [ intro H'11; rewrite (H'11 (Couple U bsup x0) bsup0 bsup1) | idtac ];
 auto with sets.
red in |- *; simpl in |- *.
intros x1 H'8; elim H'8; auto with sets.
elim H'7; auto with sets.
apply Singleton_has_lub.
lapply (H'4 x0); [ intro H'8; elim H'8 | idtac ]; auto with sets.
apply Upper_Bound_definition; auto with sets.
intros y H'5; try assumption.
lapply (H'4 y); [ intro H'10; elim H'10 | idtac ]; auto with sets.
red in |- *; simpl in |- *.
intros x1 H'5; try assumption.
lapply (H'4 x1); [ intro H'9; elim H'9 | idtac ]; auto with sets.
Qed.

Theorem Approximants_directed_set :
 Conditionally_complete U D ->
 forall x : U, In U (Carrier_of U D) x -> Directed U D (Approximants U D x).
Proof.
intros H' x H'0; constructor 1; auto with sets.
red in |- *; simpl in |- *; intros x0 H'1; elim H'1; auto with sets.
elim (Bottom_is_compact U D); auto with sets.
intros bot H'1; elim H'1; intros H'2 H'3; clear H'1.
apply Inhabited_intro with (x := bot); auto with sets.
apply Defn_of_Approximants; auto with sets.
elim H'2; auto with sets.
intros x1 x2 H'1; red in H'1; auto with sets.
generalize (H'1 x1); intro h; lapply h;
 [ intro H'2; clear h | clear h; try assumption ];
 auto 20 with sets.
generalize (H'1 x2); intro h; lapply h;
 [ intro H'3; clear h | clear h; try assumption ];
 auto 20 with sets.
elim H'3.
intros c H'4 H'5.
elim H'2.
intros c' H'6 H'7.
cut (Compatible U D c' c).
intro H'8; try assumption.
lapply Lub_of_compacts_is_compact; [ intro H'9; elim (H'9 c' c x) | idtac ];
 auto with sets.
intros x0 H'10; elim H'10; intros H'11 H'12; elim H'11; clear H'10.
intros H'10 H'13; exists x0; split; auto with sets.
elim H'12; auto with sets.
red in |- *; simpl in |- *.
intros x0 H'10; elim H'10; auto with sets.
red in |- *; simpl in |- *.
intros H'8 H'9; exists x; auto with sets.
Qed.

Theorem Inclusion_of_Approximants :
 Domain U D ->
 forall x y : U,
 In U (Carrier_of U D) x ->
 In U (Carrier_of U D) y ->
 Included U (Approximants U D x) (Approximants U D y) -> Rel_of U D x y.
Proof.
intros H' x y H'0 H'1 H'2; try assumption; auto with sets.
red in H'; elim H'; intros H'3 H'4; clear H'; red in H'4.
elim H'4; intros H' H'5; clear H'4; red in H'; auto with sets.
generalize (H' x); intro h; elim h; intros H'4 H'6; clear h; elim H'6;
 auto with sets.
clear H'6; intros H'7 H'8; apply H'8.
generalize (H' y); intro h; elim h; intros H'6 H'9; clear h; try exact H'9;
 auto with sets.
apply Upper_downward_stable with (Approximants U D y); auto with sets.
red in |- *; (intros x0 H'10; elim H'10); auto with sets.
red in |- *; (intros x0 H'10; elim H'10); auto with sets.
apply Upper_Bound_definition; auto with sets.
intros y0 H'10; elim H'10; auto with sets.
Qed.
Hint Resolve Inclusion_of_Approximants.

Theorem Less_imp_Inclusion_of_Approximants :
 Domain U D ->
 forall x y : U,
 In U (Carrier_of U D) x ->
 In U (Carrier_of U D) y ->
 Rel_of U D x y -> Included U (Approximants U D x) (Approximants U D y).
Proof.
intros H' x y H'0 H'1 H'2; red in |- *; simpl in |- *.
intros x0 H'3; elim H'3.
generalize Rel_of_transitive; intro RoT; red in RoT.
intros c H'4 H'5; try assumption.
apply Defn_of_Approximants; auto with sets.
apply RoT with (y := x); auto with sets.
Qed.

Theorem Approximants_define_element :
 Domain U D ->
 forall x y : U,
 In U (Carrier_of U D) x ->
 In U (Carrier_of U D) y -> Approximants U D x = Approximants U D y -> x = y.
intros H' x y H'0 H'1 H'2; try assumption.
cut (Same_set U (Approximants U D x) (Approximants U D y)).
intro H'3; elim H'3.
generalize (Rel_of_antisymmetric U D); auto with sets.
rewrite H'2; auto with sets.
Qed.
Hint Resolve Approximants_define_element.
Require Import Classical_sets.
Hint Unfold not.

Theorem Corollary1_1 :
 Domain U D ->
 forall x y : U,
 Compact U D x ->
 In U (Carrier_of U D) y ->
 Strict_Rel_of U D x y ->
 exists z : U, In U (Approximants U D y) z /\ Strict_Rel_of U D x z.
Proof.
unfold Strict_Rel_of in |- *.
intros H' x y H'0 H'1 H'2; elim H'2; intros H'3 H'4; try exact H'3; clear H'2.
lapply Less_imp_Inclusion_of_Approximants;
 [ intro H'2; lapply (H'2 x y);
    [ intro H'7; lapply H'7;
       [ intro H'8; lapply H'8;
          [ intro H'9; try exact H'9; clear H'8 H'7 | clear H'8 H'7 ]
       | clear H'7 ]
    | idtac ]
 | idtac ]; auto with sets.
elim
 (Strict_super_set_contains_new_element U (Approximants U D x)
    (Approximants U D y)); auto 8 with sets.
intros x0 H'5; elim H'5; clear H'5.
intro H'5; elim H'5; clear H'5.
intros c H'5 H'6 H'7; try assumption.
lapply Lub_of_compacts_is_compact; [ intro H'8; elim (H'8 x c y) | idtac ];
 auto with sets.
intros x1 H'11; elim H'11; intros H'12 H'13; elim H'12; clear H'11.
intros H'11 H'14; exists x1.
split; [ idtac | split; [ try assumption | idtac ] ]; auto with sets.
elim H'13; auto with sets.
elim H'11; auto with sets.
red in |- *; simpl in |- *; intro H'15; try exact H'15.
apply H'7.
rewrite H'15; auto with sets.
elim (Upper_Bound_Couple_inv U D x c x1);
 [ intros H'21 H'22; elim H'22; intros H'23 H'24; try exact H'23; clear H'22
 | idtac ]; auto with sets.
red in |- *; simpl in |- *.
intros x1 H'11; elim H'11; auto with sets.
apply Coherent_implies_Conditionally_Complete.
elim H'; auto with sets.
Qed.

Theorem Corollary1_2 :
 Domain U D ->
 forall x : U,
 In U (Carrier_of U D) x ->
 ~ Compact U D x -> ~ Finite U (Approximants U D x).
intros H' x H'0 H'1; red in |- *; simpl in |- *; intro H'2; try exact H'2.
apply H'1.
lapply approximants_closed_by_finite_lubs;
 [ intro H'3; elim (H'3 x (Approximants U D x)) | idtac ];
 auto with sets.
intros x0 H'4; elim H'4; intros H'5 H'6; try exact H'5; clear H'4.
elim H'.
intros H'4 H'7; elim H'7.
intro H'9; red in H'9.
elim (H'9 x); intros H'11 H'12; try exact H'12.
intro H'10; clear H'10.
lapply (Lub_is_unique U D);
 [ intro H'14; rewrite (H'14 (Approximants U D x) x x0) | idtac ];
 auto with sets.
elim H'6; auto with sets.
elim H'; auto with sets.
Qed.
End Advanced_lemmas.
Hint Resolve Inclusion_of_Approximants.
Hint Resolve Upper_Bound_Couple_intro.


Require Import dec.
Require Import finite.
Require Import foltl.
Require Import fosem.
Require Import vars.
Require Import varset.

Require Import Arith.
Require Import Eqdep_dec.
Include EqNotations.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Inductive Closure {T} (R: T -> T -> Prop): T -> T -> Prop :=
  Cl0: forall d1 d2, d1=d2 -> Closure R d1 d2
| ClS: forall d1 d2 d3, R d1 d2 -> Closure R d2 d3 -> Closure R d1 d3.

Section Propagation.

  Context {Ts: Type} {Tv: Ts->Type} {Tc: Ts->Type} {Tp: Type}.
  Variable Sg: @Sig Ts Tv Tc Tp.
  Variable s : Sort.
  Variables u v: variable s.
  Variable uv_ne: v <> u.
  Variable P: formula Sg.
  Variable Pu: not (vsIn Sg u (free Sg P)).
  Variable Pv: not (vsIn Sg v (free Sg P)).

  Lemma neq_uv: (~ isEq2 (U:=variable) s u s v).
  Proof.
    intro.
    inversion H; clear H.
    apply inj_pair2_eq_dec in H1; try apply eq_dec; subst v; now auto.
  Qed.

  Lemma neq_vu: (~ isEq2 (U:=variable) s v s u).
  Proof.
    intro.
    inversion H; clear H.
    apply inj_pair2_eq_dec in H1; try apply eq_dec; subst v; now auto.
  Qed.

  Class Binary := {
    b_pred: predicate;
    b_arity: pr_arity b_pred = 2;
    b_args: forall i, pr_args b_pred i = s
  }.

  Definition call (r: Binary) (u v: variable s): formula Sg :=
    Atom Sg (Literal _ (PApp _ 0 b_pred (fun i => rew <-(b_args i) in match (rew b_arity in i : Fin.t 2) return term Sg s with Fin.F1 => Var Sg s u | Fin.FS _ => Var Sg s v end))).

  Notation "'[' x ':=' y ']'" := (vsubst Sg x y).

  Definition Propagates r (x: variable s) (h: vsIn Sg x (free _ P)) :=
    All Sg s u (All _ s v (Imp _ (call r u v) (G _ (Imp _ ([x:=u] P)  (F _ ([x:=v]P)))))).

  Definition AbsClosure r t x (h: vsIn Sg x (free _ P)) :=
    Imp Sg (Propagates r x h) (Propagates t x h).

  Variable D: Dom Sg.
  Variable itp: Interp D.

  Definition rel (r: Binary) env t x y := fm_sem (Itp:=itp) Sg env (call r x y) t.

  Definition call_sem (r: Binary) t (d1 d2: ssem s): Prop :=
    psem b_pred t (fun i => rew <-[ssem](b_args i) in match (rew b_arity in i : Fin.t 2) return ssem s with Fin.F1 => d1 | Fin.FS _ => d2 end).

  Definition isClosure r r' := forall t x y, Closure (call_sem r t) x y <-> call_sem r' t x y.

  Lemma rel_sem r env t x y: rel r env t x y <-> call_sem r t (env s x) (env s y).
  Proof.
    unfold rel, call_sem, call; simpl.
    split; intro.
    match goal with
      H: psem _ _ ?f1 |- psem _ _ ?f2 => assert (f1=f2) as Hf; try (rewrite <-Hf; auto)
    end.
    apply functional_extensionality_dep; intro i.
    destruct r; simpl in *.
    revert b_args0 H i.
    unfold eq_rect_r, eq_rect.
    destruct itp; simpl.
    unfold tm_sem; simpl.
    generalize (psem b_pred0); clear psem.
    generalize (pr_args b_pred0).
    generalize b_arity0.
    rewrite b_arity0; intro.
    rewrite (proof_irrelevance _ _ eq_refl); simpl.
    clear b_arity1; intros.
    rewrite (b_args0 i); simpl.
    destruct i; now auto.

    match goal with
      H: psem _ _ ?f1 |- psem _ _ ?f2 => assert (f1=f2) as Hf; try (rewrite <-Hf; auto)
    end.
    apply functional_extensionality_dep; intro i.
    destruct r; simpl in *.
    revert b_args0 H i.
    unfold eq_rect_r, eq_rect.
    destruct itp; simpl.
    unfold tm_sem; simpl.
    generalize (psem b_pred0); clear psem.
    generalize (pr_args b_pred0).
    generalize b_arity0.
    rewrite b_arity0; intro.
    rewrite (proof_irrelevance _ _ eq_refl); simpl.
    clear b_arity1; intros.
    rewrite (b_args0 i); simpl.
    destruct i; now auto.

  Qed.

  Definition Propagates_sem {T} (P: nat -> T -> Prop) (R: nat -> T -> T -> Prop) t :=
    forall u v, R t u v -> (forall t', t'>=t -> P t' u -> exists t'', t'' >= t' /\ P t'' v).

  Definition AbsClosure_sem {T} (P: nat -> T -> Prop) (R R': nat -> T -> T -> Prop) t :=
    Propagates_sem P R t -> Propagates_sem P R' t.

  Definition isClosure_sem {T}  (R R': nat -> T -> T -> Prop) :=
    forall t x y, Closure (R t) x y <-> R' t x y.

  Lemma preTheorem8 {T} (Q: nat -> T -> Prop) (R R': nat -> T -> T -> Prop):
    isClosure_sem R R' -> forall t, AbsClosure_sem Q R R' t.
  Proof.
    unfold isClosure_sem, AbsClosure_sem, Propagates_sem; intros.
    apply H in H1; clear H.
    revert t' H2 H3; induction H1; intros.
    subst d1.
    exists t'; split; now auto.

    specialize (H0 _ _ H t' H2 H3).
    destruct H0 as [t'' [h1 h2]].
    assert (t'' >= t) by (apply le_trans with (m:=t'); auto).
    specialize (IHClosure t'' H0 h2).
    destruct IHClosure as [t1 [k1 k2]].
    exists t1; split; auto.
    apply le_trans with (m:=t''); auto.
  Qed.

  Lemma call_sem_equiv: forall env d1 d2 r t,
    fm_sem Sg (add Sg v d2 (add Sg u d1 env)) (call r u v) t <->
      call_sem r t d1 d2.
  Proof.
    intros.
    change (fm_sem Sg (add Sg v d2 (add Sg u d1 env)) (call r u v) t) with
      (rel r (add Sg v d2 (add Sg u d1 env)) t u v).
    rewrite rel_sem.
    rewrite add_eq.
    rewrite add_add_ne_swp; auto.
    rewrite add_eq.
    reflexivity.
    apply neq_vu.
  Qed.

  Lemma isClosure_equiv: forall (r r': Binary),
    isClosure r r' <-> isClosure_sem (call_sem r) (call_sem r').
  Proof.
    unfold isClosure, isClosure_sem; intros.
    reflexivity.
  Qed.

  Lemma add_add_ne_swp_eq : forall (env: Env Sg D) s (v1 v2: variable s) d1 d2, v1 <> v2 ->
    add _ v2 d2 (add _ v1 d1 env) s v1 = d1.
  Proof.
    intros.
    rewrite add_add_ne_swp.
    rewrite add_eq; auto.
    intro.
    inversion H0; clear H0.
    apply inj_pair2_eq_dec in H2; subst; auto.
    apply eq_dec.
  Qed.

  (* PaperTheorem 8 *)
  Theorem theorem8: forall r r' env,
    isClosure r r' -> forall x h t, fm_sem Sg env (AbsClosure r r' x h) t.
  Proof.
    intros.
    apply Imp_sem; intro.
    unfold Propagates in H0|-*.
    rewrite All_sem in *; intro d1.
    rewrite All_sem; intro d2.
    rewrite Imp_sem; intro.
    apply call_sem_equiv in H1.
    generalize (fun d => proj1 (All_sem _ D itp (add Sg u d env) _ _ _  t)  (H0 d)); clear H0; intros.
    setoid_rewrite Imp_sem in H0.
    setoid_rewrite call_sem_equiv in H0.
    setoid_rewrite G_sem in H0; setoid_rewrite G_sem.
    setoid_rewrite Imp_sem in H0; setoid_rewrite Imp_sem.
    setoid_rewrite F_sem in H0; setoid_rewrite F_sem.
    setoid_rewrite <-vsubst_sem in H0; setoid_rewrite <-vsubst_sem.
    setoid_rewrite add_eq in H0; setoid_rewrite add_eq.
    setoid_rewrite add_add_ne_swp_eq; auto.
    set (Q t d := fm_sem Sg (add Sg x d (add Sg v d2 (add Sg u d1 env))) P t).
    change (forall t' : nat, t' >= t -> Q t' d1 ->
                exists t'0 : nat, t'0 >= t' /\ Q t'0 d2).
    apply (preTheorem8 Q (call_sem r) (call_sem r')); auto.

    repeat intro.
    specialize (H0 u0 v0 H2 t' H3).
    rewrite add_add_ne_swp_eq in H0; auto.

    assert (forall t d d1 d2, fm_sem Sg (add Sg x d (add Sg v d1 (add Sg u d2 env))) P t <-> Q t d).
      intros.
      apply fm_sem_equiv; intros; auto.
      destruct (veq_dec Sg v1 x).
      injection e; intros; subst s0.
      apply inj_pair2_eq_dec in e; try apply eq_dec; subst v1.
      now do 2 rewrite add_eq.
      rewrite (add_ne2 _ _ (add Sg v d0 (add Sg u d3 env))); auto.
      rewrite (add_ne2 _ _ (add Sg v d2 (add Sg u d1 env))); auto.
      destruct (veq_dec Sg v1 v).
      injection e; intros; subst s0.
      apply inj_pair2_eq_dec in e; try apply eq_dec; subst v1.
      apply Pv in H5; tauto.
      rewrite (add_ne2 _ _ (add Sg u d3 env)); auto.
      rewrite (add_ne2 _ _ (add Sg u d1 env)); auto.
      destruct (veq_dec Sg v1 u).
      injection e; intros; subst s0.
      apply inj_pair2_eq_dec in e; try apply eq_dec; subst v1.
      apply Pu in H5; tauto.
      repeat rewrite add_ne2; auto.
    rewrite H5 in H0.
    setoid_rewrite H5 in H0.
    apply H0; auto.
  Qed.

End Propagation.


Require Import HoTT.Basics HoTT.Types.Bool.
Require Import HoTT.Classes.theory.rings
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.implementations.list.

Class AlmostNegate A := almost_negate : A -> A.

Class AlmostRing A {Aplus : Plus A} {Amult : Mult A}
  {Azero : Zero A} {Aone : One A} {Anegate : AlmostNegate A} :=
  { almost_ring_semiring : IsSemiRing A
  ; almost_ring_neg_pr : forall x : A, almost_negate x = (almost_negate 1) * x }.

Section almostring_mor.
Context {A B : Type} {Aplus : Plus A} {Bplus : Plus B}
  {Amult : Mult A} {Bmult : Mult B} {Azero : Zero A} {Bzero : Zero B}
  {Aone : One A} {Bone : One B} {Aneg : AlmostNegate A} {Bneg : AlmostNegate B}.

Class AlmostRingPreserving (f : A -> B) :=
  { almostring_mor_sr_mor : IsSemiRingPreserving f
  ; almostring_mor_neg : forall x, f (almost_negate x) = almost_negate (f x) }.
End almostring_mor.

Module Quoting.

Inductive Expr (V:Type0) :=
  | Var (v : V)
  | Zero
  | One
  | Plus (a b : Expr V)
  | Mult (a b : Expr V)
  | Neg (a : Expr V)
.

Arguments Var {V} v.
Arguments Zero {V}.
Arguments One {V}.
Arguments Plus {V} a b.
Arguments Mult {V} a b.
Arguments Neg {V} a.

Section contents.
Universe U.
Context (R:Type@{U}) `{AlmostRing R}.

Notation Vars V := (V -> R).

Fixpoint eval {V:Type0} (vs : Vars V) (e : Expr V) : R :=
  match e with
  | Var v => vs v
  | Zero => 0
  | One => 1
  | Plus a b => eval vs a + eval vs b
  | Mult a b => eval vs a * eval vs b
  | Neg a => almost_negate (eval vs a)
  end.

Lemma eval_ext {V:Type0} (vs vs' : Vars V) :
  pointwise_paths@{Set U} vs vs' ->
  pointwise_paths@{Set U} (eval vs) (eval vs').
Proof.
intros E e;induction e;simpl;auto;apply ap011;auto.
Qed.

Definition noVars : Vars Empty.
Proof. intros []. Defined.

Definition singleton x : Vars Unit := fun _ => x.

Definition merge {A B:Type0 } (va:Vars A) (vb:Vars B) : Vars (sum@{Set Set} A B)
  := fun i => match i with inl i => va i | inr i => vb i end.

Section Lookup.

  Class Lookup {A:Type0 } (x: R) (f: Vars A)
    := { lookup: A; lookup_correct: f lookup = x }.

  Global Arguments lookup {A} x f {_}.

  Context (x:R) {A B:Type0 } (va : Vars A) (vb : Vars B).

  Local Instance lookup_l `{!Lookup x va} : Lookup x (merge va vb).
  Proof.
  exists (inl (lookup x va)). apply lookup_correct.
  Defined.

  Local Instance lookup_r `{!Lookup x vb} : Lookup x (merge va vb).
  Proof.
  exists (inr (lookup x vb)). apply lookup_correct.
  Defined.

  Local Instance lookup_single : Lookup x (singleton x).
  Proof.
  exists tt. reflexivity.
  Defined.

End Lookup.

Fixpoint expr_map {V W:Type0 } (f : V -> W) (e : Expr V) : Expr W :=
  match e with
  | Var v => Var (f v)
  | Zero => Zero
  | One => One
  | Plus a b => Plus (expr_map f a) (expr_map f b)
  | Mult a b => Mult (expr_map f a) (expr_map f b)
  | Neg a => Neg (expr_map f a)
  end.

Lemma eval_map {V W:Type0 } (f : V -> W) v e
  : eval v (expr_map f e) = eval (Compose@{Set Set U} v f) e.
Proof.
induction e;simpl;try reflexivity;apply ap011;auto.
Qed.

Section Quote.

  Class Quote {V:Type0 } (l: Vars V) (n: R) {V':Type0 } (r: Vars V') :=
    { quote : Expr (V |_| V')
    ; eval_quote : @eval (V |_| V') (merge l r) quote = n }.

  Global Arguments quote {V l} n {V' r _}.
  Global Arguments eval_quote {V l} n {V' r _}.

  Definition sum_assoc {A B C}: (A |_| B) |_| C -> A |_| (B |_| C).
  Proof.
  intros [[?|?]|?];auto.
  Defined.

  Definition sum_aux {A B C}: (A |_| B) -> A |_| (B |_| C).
  Proof.
  intros [?|?];auto.
  Defined.

  Local Instance quote_zero (V:Type0) (v: Vars V): Quote v 0 noVars.
  Proof.
  exists Zero.
  reflexivity.
  Defined.

  Local Instance quote_one (V:Type0) (v: Vars V): Quote v 1 noVars.
  Proof.
  exists One.
  reflexivity.
  Defined.

  Lemma quote_plus_ok (V:Type0) (v: Vars V) n
    (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
    `{!Quote v n v'} `{!Quote (merge v v') m v''}
    : eval (merge v (merge v' v''))
      (Plus (expr_map sum_aux (quote n)) (expr_map sum_assoc (quote m))) =
      n + m.
  Proof.
  simpl.
  rewrite <-(eval_quote n), <-(eval_quote m),
    2!eval_map.
  apply ap011;apply eval_ext.
  - intros [?|?];reflexivity.
  - intros [[?|?]|?];reflexivity.
  Qed.

  Local Instance quote_plus (V:Type0) (v: Vars V) n
  (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
  `{!Quote v n v'} `{!Quote (merge v v') m v''}: Quote v (n + m) (merge v' v'').
  Proof.
  econstructor. apply quote_plus_ok.
  Defined.

  Lemma quote_mult_ok (V:Type0) (v: Vars V) n
    (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
    `{!Quote v n v'} `{!Quote (merge v v') m v''}
    : eval (merge v (merge v' v''))
      (Mult (expr_map sum_aux (quote n)) (expr_map sum_assoc (quote m))) =
      n * m.
  Proof.
  simpl.
  rewrite <-(eval_quote n), <-(eval_quote m),
    2!eval_map.
  apply ap011;apply eval_ext.
  - intros [?|?];reflexivity.
  - intros [[?|?]|?];reflexivity.
  Qed.

  Local Instance quote_mult (V:Type0) (v: Vars V) n
    (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
    `{!Quote v n v'} `{!Quote (merge v v') m v''}
    : Quote v (n * m) (merge v' v'').
  Proof.
  econstructor. apply quote_mult_ok.
  Defined.

  Lemma quote_neg_ok@{} (V:Type0) (v : Vars V) n (V':Type0) (v' : Vars V')
    `{!Quote v n v'}
    : eval (merge v v') (Neg (quote n)) = almost_negate n.
  Proof.
  simpl. apply ap,eval_quote.
  Qed.

  Local Instance quote_neg (V:Type0) (v : Vars V) n (V':Type0) (v' : Vars V')
    `{!Quote v n v'}
    : Quote v (almost_negate n) v'.
  Proof.
  exists (Neg (quote n)).
  apply quote_neg_ok.
  Defined.

  Local Instance quote_old_var (V:Type0) (v: Vars V) x {i: Lookup x v}
    : Quote v x noVars | 8.
  Proof.
  exists (Var (inl (lookup x v))).
  apply lookup_correct.
  Defined.

  Local Instance quote_new_var (V:Type0) (v: Vars V) x
    : Quote v x (singleton x) | 9.
  Proof.
  exists (Var (inr tt)).
  reflexivity.
  Defined.

End Quote.

Definition quote': forall x {V':Type0 } {v: Vars V'} {d: Quote noVars x v}, Expr _
  := @quote _ _.

Definition eval_quote': forall x {V':Type0} {v: Vars V'} {d: Quote noVars x v},
  eval (merge noVars v) (quote x) = x
  := @eval_quote _ _.

Class EqQuote {V:Type0 } (l: Vars V) (n m: R) {V':Type0 } (r: Vars V') :=
    { eqquote_l : Expr V
    ; eqquote_r : Expr (V |_| V')
    ; eval_eqquote : eval (merge l r) (expr_map inl eqquote_l)
                   = eval (merge l r) eqquote_r -> n = m }.

Lemma eq_quote_ok (V:Type0) (v: Vars V) n
  (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
  `{!Quote v n v'} `{!Quote (merge v v') m v''}
  : eval (merge v (merge v' v'')) (expr_map sum_aux (quote n))
  = eval (merge v (merge v' v'')) (expr_map sum_assoc (quote m))
  -> n = m.
Proof.
intros E.
rewrite <-(eval_quote n), <-(eval_quote m).
path_via (eval (merge v (merge v' v'')) (expr_map sum_aux (quote n)));
[|path_via (eval (merge v (merge v' v'')) (expr_map sum_assoc (quote m)))].
- rewrite eval_map. apply eval_ext.
  intros [?|?];reflexivity.
- rewrite eval_map. apply eval_ext.
  intros [[?|?]|?];reflexivity.
Qed.

Local Instance eq_quote (V:Type0) (v: Vars V) n
  (V':Type0) (v': Vars V') m (V'':Type0) (v'': Vars V'')
  `{!Quote v n v'} `{!Quote (merge v v') m v''}
  : EqQuote (merge v v') n m v''.
Proof.
econstructor.
intros E.
apply (@eq_quote_ok _ _ _ _ _ _ _ _ Quote0 Quote1).
etransitivity;[etransitivity;[|exact E]|].
- rewrite 2!eval_map. apply eval_ext. intros [?|?];reflexivity.
- rewrite (eval_map sum_assoc).
  apply eval_ext. intros [[?|?]|?];reflexivity.
Defined.

Definition sum_forget {A B} : Empty |_| A -> A |_| B.
Proof.
intros [[]|?];auto.
Defined.

Lemma quote_equality {V:Type0} {v: Vars V}
  {V':Type0} {v': Vars V'} (l r: R)
  `{!Quote noVars l v} `{!Quote v r v'}
  : let heap := (merge v v') in
  eval heap (expr_map sum_forget (quote l)) = eval heap (quote r) -> l = r.
Proof.
intros ? E.
rewrite <-(eval_quote l),<-(eval_quote r).
path_via (eval heap (expr_map sum_forget (quote l))).
rewrite eval_map. apply eval_ext.
intros [[]|?]. reflexivity.
Qed.

End contents.

Module Export Instances.
  Global Existing Instances lookup_l lookup_r lookup_single quote_zero quote_one quote_plus quote_mult quote_neg eq_quote.
  Global Existing Instance quote_old_var | 8.
  Global Existing Instance quote_new_var | 9.
End Instances.

End Quoting.


(** * Syntax of MMLL
This file defines the syntax of formulas in MMLL
(type [oo]). Predicate [isFormula] determines when a term is a valid
MMLL formula (ruling out exotic terms). Proofs usually proceed by
induction on the fact that a term satisfies this property.
 *)

Require Export LL.Misc.UtilsTactics.
Require Export LL.Misc.Hybrid.
Require Export LL.SL.SELLF.Signature.

Require Import Coq.Logic.FunctionalExtensionality.

Export ListNotations.
Set Implicit Arguments.

Class OLSig :=
  {
    (* Signature for atoms (judgments at the OL level) *)
    atm:Set;
    (* Type for constants (constructors for OL syntax) *)
    con:Set;
    (* predicate ruling out exotic terms for atoms *)
    uniform_atm : (expr con -> atm) -> Prop
  }.

Section LLSyntax.

  Context `{OLS: OLSig}.
  Context `{SI: SigSELL}.

  (** Connectives of the logic *)
  Inductive oo : Set :=
  | atom : atm -> oo
  | perp : atm -> oo
  | Top : oo
  | One : oo
  | Zero : oo
  | Bot : oo
  | AAnd : oo -> oo -> oo
  | MAnd : oo -> oo -> oo
  | AOr : oo -> oo -> oo
  | MOr : oo -> oo -> oo
  | Bang : subexp -> oo -> oo
  | Quest : subexp -> oo -> oo
  | All : (expr con -> oo) -> oo
  | Some : (expr con -> oo) -> oo.

  (** Complexity of formulas *)
  Fixpoint complexity (X:oo) :=
    match X with
    | atom A   => 1
    | perp A   => 1
    | One => 1
    | Bot => 1
    | Zero => 1
    | Top => 1
    | MAnd F G => 1+ complexity F + complexity G
    | AAnd F G => 1+ complexity F + complexity G
    | MOr F G => 1+ complexity F + complexity G
    | AOr F G => 1+ complexity F + complexity G
    | Bang a F   => 1+ complexity F
    | Quest a F  => 1+ complexity F
    | Some FX => 1+ complexity (FX (VAR con 0))
    | All FX => 1+ complexity (FX (VAR con 0))
    end.

     (** Complexity on list of formulas *)
  Fixpoint complexityL (L: list oo) :=
    match L with
    | nil => 0
    | a :: L' => complexity a + complexityL L'
    end.

  Lemma Complexity0 : forall F, complexity F > 0.
    induction F;simpl;lia.
  Qed.

  Lemma ComplexityL0 : forall L, complexityL L =0 -> L = [].
    intros;destruct L;simpl;auto.
    simpl in H.
    generalize (Complexity0 o);intros.
    lia.
  Qed.

  (** Classical linear logic dualities *)
  Fixpoint dual (X: oo) :=
    match X with
    | atom A   => perp A
    | perp A   => atom A
    | One => Bot
    | Bot => One
    | Zero => Top
    | Top => Zero
    | MAnd F G => MOr (dual  F) (dual G)
    | AAnd F G => AOr (dual  F) (dual G)
    | MOr F G => MAnd (dual  F) (dual G)
    | AOr F G => AAnd (dual  F) (dual G)
    | Bang a F   => Quest a (dual F)
    | Quest a F  => Bang a (dual   F)
    | Some X => All (fun x => dual  (X x))
    | All X => Some (fun x => dual (X x))
    end.

  (** Negation is involutive *)
  Theorem ng_involutive: forall F: oo, F = dual (dual F).
  Proof.
    intro.
    induction F; simpl; auto;
      try( try(rewrite <- IHF1); try(rewrite <- IHF2); try(rewrite <- IHF);auto);
      try(assert (o = fun x =>  dual (dual (o x))) by
             (extensionality e; apply H); rewrite <- H0; auto).
  Qed.

  Lemma DualComplexity : forall F, complexity F = complexity (dual F) .
    intros.
    induction F;intros;auto;
      try solve
          [simpl; try rewrite IHF; try rewrite IHF1; try rewrite IHF2;auto].
  Qed.

  (**  Linear Implication *)
  Definition Limp (F G : oo) : oo := MOr (dual F) G .
  Definition TypedFormula : Type := subexp * oo.

  (** Uniform Predicate (ruling out exotic terms) *)
  Inductive uniform_oo: (expr con -> oo) -> Prop :=
  | uniform_atom: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (atom (a x)))
  | uniform_perp: forall (a: expr con -> atm),
      uniform_atm a -> uniform_oo (fun x => (perp (a x)))
  | uniform_Top: uniform_oo (fun x => Top)
  | uniform_One: uniform_oo (fun x => One)
  | uniform_Bot: uniform_oo (fun x => Bot)
  | uniform_Zero: uniform_oo (fun x => Zero)
  | uniform_AAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AAnd (A x) (B x)))
  | uniform_MAnd: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MAnd (A x) (B x)))
  | uniform_AOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (AOr (A x) (B x)))
  | uniform_MOr: forall (A B: expr con -> oo),
      uniform_oo A -> uniform_oo B -> uniform_oo (fun x => (MOr (A x) (B x)))
  | uniform_Bang: forall (A: expr con -> oo) a,
      uniform_oo A -> uniform_oo (fun x => (Bang a (A x)))
  | uniform_Quest: forall (A: expr con -> oo) a,
      uniform_oo A -> uniform_oo (fun x => (Quest a (A x)))
  | uniform_All: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (All (fun y => (A y x))))
  | uniform_Some: forall (A: expr con -> expr con -> oo),
      (forall y:expr con, uniform_oo (fun x => (A y x))) ->
      uniform_oo (fun x => (Some (fun y => (A y x)))).

  (** Well formedness condition  *)
  Inductive isFormula: oo -> Prop  :=
  | wf_atm : forall (P1:atm), isFormula (atom P1)
  | wf_perp : forall (P1:atm), isFormula (perp P1)
  | wf_Top : isFormula Top
  | wf_One : isFormula One
  | wf_Zero : isFormula Zero
  | wf_Bot : isFormula Bot
  | wf_AAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AAnd A1 A2)
  | wf_MAnd : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MAnd A1 A2)
  | wf_AOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (AOr A1 A2)
  | wf_MOr : forall (A1 A2 :oo), isFormula A1  -> isFormula A2  -> isFormula (MOr A1 A2)
  | wf_Bang : forall (A1 :oo) a, isFormula A1 -> isFormula (Bang a A1)
  | wf_Quest : forall (A1 :oo) a, isFormula A1 -> isFormula (Quest a A1)
  | wf_All : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (All A)
  | wf_Some : forall (A : expr con -> oo), uniform_oo A -> (forall t: expr con, isFormula (A t)) -> isFormula (Some A).

  Hint Constructors isFormula : core.

  Lemma ComplexityUniformEq : forall FX x y , uniform_oo FX ->
                                            proper x -> proper y ->
                                            complexity (FX x) =  complexity (FX y).
    intros.
    induction H;subst;simpl;firstorder.
  Qed.

   Lemma ComplexityPerm: forall M N, Permutation M N ->
                                        complexityL M =  complexityL N.
    intros.
    induction H;subst;simpl;lia.
  Qed.

    Global Instance permComplexity   :
   Proper ((@Permutation oo) ==> eq) (complexityL).
    Proof.
    unfold Proper; unfold respectful.
      intros.
      apply ComplexityPerm;auto.
  Qed.

  (** Well formendness conditions for lists and arrows *)
  Definition isFormulaL  (L:list oo)  := Forall isFormula L.

  Global Instance perm_isFormulaL :
      Proper (@Permutation oo ==> Basics.impl)
             (isFormulaL  ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl .
      intros.
      unfold isFormulaL.
      rewrite <- H;auto.
    Qed.

  Lemma isFormulaIn : forall F L,
      isFormulaL L -> In F L -> isFormula F.
  Proof.
    intros. eapply @ForallIn with (F:=F) in H;auto.
  Qed.

  (** Arrows for the focused system
      - [UP] : negative phase
      - [DW] : positive phase
   *)
  Inductive Arrow  :=
  | UP (l : list oo) (* negative phase *)
  | DW (F : oo). (* positive phase *)

  (** Transforming arrows into lists of formulas *)
  Definition Arrow2LL (A: Arrow) : list oo :=
    match A  with
    | UP l => l
    | DW F => [F]
    end.

  (** Checking when a formulas has to lose focusing *)
  Inductive negativeFormula : oo -> Prop :=
  | RelNA1 : forall A,  negativeFormula (atom A)
  | RelTop : negativeFormula Top
  | RelBot : negativeFormula Bot
  | RelPar : forall F G, negativeFormula (MOr F G)
  | RelWith : forall F G, negativeFormula (AAnd F G)
  | RelQuest : forall F a, negativeFormula (Quest a F)
  | RelForall : forall FX, negativeFormula (All FX).

  (** Positive formulas (focusing persists *)
  Inductive positiveFormula : oo -> Prop :=
  | PosAt : forall A,  positiveFormula (perp A)
  | PosOne : positiveFormula One
  | PosZero : positiveFormula Zero
  | PosTensor : forall F G, positiveFormula (MAnd F G)
  | PosPlus : forall F G, positiveFormula (AOr F G)
  | PosBang : forall F a, positiveFormula (Bang a F)
  | PosEx : forall FX, positiveFormula (Some FX).

  (** Checking when a formulas has to be stored *)
  Inductive positiveLFormula : oo -> Prop :=
  | PosLAt : forall A,  positiveLFormula (atom A)
  | PosLPe : forall A,  positiveLFormula (perp A)
  | PosLOne : positiveLFormula One
  | PosLZero : positiveLFormula Zero
  | PosLTensor : forall F G, positiveLFormula (MAnd F G)
  | PosLPlus : forall F G, positiveLFormula (AOr F G)
  | PosLBang : forall F a, positiveLFormula (Bang a F)
  | PosLEx : forall FX, positiveLFormula (Some FX).

Theorem PositiveToLPositive : forall F,
      positiveFormula F -> positiveLFormula F.
    intros.
    inversion H;constructor.
  Qed.

  (** Every formula is either  a positive formula, or it must be released *)
  Theorem PositiveOrNegative : forall F,
      positiveFormula F \/ negativeFormula F.
    intros.
    destruct F;try (left;constructor);try(right;constructor).
  Qed.

Theorem PositiveNegativeSplit : forall M, exists M1 M2,
    Forall positiveFormula M1 /\ Forall negativeFormula M2 /\ Permutation M (M1++M2).
  Proof with sauto.
    induction M; intros...
    - exists nil.
      exists nil...
    - destruct (PositiveOrNegative a)...
      { exists (a::x).
        exists x0...
        rewrite H2... }
      { exists x.
        exists (a::x0)...
        rewrite H2... }
  Qed.

  (** Positive formulas cannot be released *)
   Theorem PositiveNotNegative: forall F,
      positiveFormula F -> ~ negativeFormula F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

 Theorem NegativeNotPositive : forall F,
      negativeFormula F -> ~ positiveFormula F.
    intros F H Hneg.
    inversion H;subst;inversion Hneg.
  Qed.

  (** The dual of a positive formula is a release formula *)
Theorem PositiveDualNegative : forall F,
      positiveFormula F -> negativeFormula (dual F).
    intros F Hpos.
    inversion Hpos;subst;constructor.
  Qed.

  Theorem NegativeDualPositive : forall F, negativeFormula F -> positiveFormula (dual F).
    intros F Hrel.
    inversion Hrel;subst;constructor.
  Qed.

  (** Postive atoms *)
  Inductive IsPositiveAtom : oo -> Prop :=
  | IsPAP : forall A, IsPositiveAtom (atom A).

  (** Negative atoms *)
  Inductive IsNegativeAtom : oo -> Prop :=
  | IsNAP : forall A, IsNegativeAtom (perp A).

Local Hint Constructors IsPositiveAtom IsNegativeAtom : core.

  Theorem NegativeAtomDec : forall F,
      IsNegativeAtom F \/ ~ IsNegativeAtom F.
    induction F;auto; try solve[right;intro H'; inversion H'].
  Qed.

  Theorem PositiveAtomDec : forall F,
      IsPositiveAtom F \/ ~ IsPositiveAtom F.
    destruct F;auto;right;intro H';inversion H'.
  Qed.

  (** List of positive atoms *)
  Definition IsPositiveAtomL  L : Prop := Forall IsPositiveAtom L.

 Lemma NotAsynchronousPosAtoms :
    forall F, positiveLFormula F -> positiveFormula F \/ IsPositiveAtom F.
    intros.
    inversion H;auto; first [left;constructor
                             | right;constructor ].
  Qed.

Theorem PositiveAtomToNegativeFormula : forall F,
      IsPositiveAtom F -> negativeFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem NetagiveAtomToPositiveFormula : forall F,
      IsNegativeAtom F -> positiveFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem PositiveAtomToPositiveLFormula : forall F,
      IsPositiveAtom F -> positiveLFormula F.
    intros.
    inversion H;constructor.
  Qed.

Theorem positiveNotAtom F: positiveFormula F -> IsPositiveAtom F -> False.
Proof.
  intros.
  inversion H0;subst.
  inversion H.
 Qed.

  End LLSyntax.

Global Hint Constructors uniform_oo : core.
Global Hint Resolve Complexity0
                    DualComplexity: core.

Module LLNotations .
  Notation "'⊥'" := Bot.
  Notation "'⊤'" := Top.
  Notation "'1'" := One.
  Notation "'0'" := Zero.
  Notation "A ⊗ B" := (MAnd A B ) (at level 50) .
  Notation "A ⅋ B" := (MOr A B) (at level 50) .
  Notation "A ⊕ B" := (AOr A B) (at level 50) .
  Notation "A & B" := (AAnd A B) (at level 50) .
  Notation "! A" := (Bang A) (at level 50) .
  Notation "? A" := (Quest A) (at level 50) .
  Notation " A ^ " := (dual A) (at level 10) .
  Notation "'∀{' FX '}'" := (All FX) (at level 10) .
  Notation "'∃{' FX '}'" := (Some FX) (at level 10) .
End LLNotations .

Global Hint Constructors IsPositiveAtom : core.

Global Hint Constructors
    negativeFormula
    positiveFormula
    positiveLFormula
    uniform_oo isFormula IsPositiveAtom
    IsNegativeAtom: core.

Global Hint Resolve
     PositiveToLPositive
     PositiveAtomToNegativeFormula
     PositiveAtomToPositiveLFormula
     NetagiveAtomToPositiveFormula
     positiveNotAtom: core.

Global Hint Unfold isFormulaL :core.