Require Import FOL Peano Tarski Deduction NumberTheory Synthetic Enumerability DecidabilityFacts Formulas Tennenbaum_diagonal Tennenbaum_insep Makholm McCarty Church Coding.

Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).

(** * Verification that all variants can be derived from WCT_Q. *)

(*  Statements are formatted rougly as follows:

    Lemma Name (Parameters) :
      Logical Assumptions ->
      Assumptions about the Model ->
      other Assumptions ->
      Conclusion.
    Proof. [...] Qed.
 *)

Module T.
Section Variants.

Instance ff : falsity_flag := falsity_on.
Context {Δ1 : Delta1}.

Variable D : Type.
Variable I : interp D.
Variable axioms : forall ax, PA ax -> ⊨ ax.

Hypothesis wct : WCT_Q.
Hypothesis delta1_definite : forall phi, delta1 phi -> Q ⊢I phi ∨ ¬ phi.
Definition obj_Insep := exists α β, def_obj_Insep α β.

Definition div e d := exists k : D, e i⊗ k = d.
Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
Definition Div_nat (d : D) := fun n => div_num n d.
Definition div_pi ψ n a :=  (inu n .: (fun _ => a)) ⊨ (∃ (ψ ∧ ∃ $1 ⊗ $0 == $3)).
Definition prime_form ψ := bounded 2 ψ /\ (forall x, Q ⊢I ∀ ψ[up (num x)..] <--> $0 == num (Irred x) ).

Lemma Irred_repr :
  ~~ exists ψ, prime_form ψ.
Proof.
  apply (DN_chaining (wct Irred)), DN.
  intros [phi Hphi].
  exists (∃ phi). split.
  - now constructor.
  - apply Hphi.
Qed.

Fact ψ_equiv n a ψ :
  prime_form ψ -> div_pi ψ n a <-> div_num (Irred n) a.
Proof.
  intros Hψ. unfold div_pi. cbn. split.
  - intros [d [->%ψ_repr H]]; auto.
  - intros. exists (inu (Irred n)). rewrite ψ_repr; auto.
Qed.

Fact MP_Discrete_stable_std :
  MP -> Discrete D -> Stable std.
Proof.
  intros mp [eq]%Discrete_sum e. unfold Stable.
  refine (MP_Dec_stable mp _ _).
  constructor. intros ?; apply eq.
Qed.

Fact stable_Std :
  Stable std -> stable (forall e, std e).
Proof.
  intros H h ?. apply H.
  now apply (DN_chaining h), DN.
Qed.

Lemma Dec_Div_nat_std :
  forall e, std e -> ~~ Dec (Div_nat e).
Proof.
  intros e [n <-].
  apply (DN_chaining (Irred_repr)), DN.
  intros [ψ ].
  constructor; intros x.
  destruct n.
  - left. exists (inu 0).
    now rewrite mult_zero_r.
  - destruct (dec_eq_nat (Mod x (S n)) 0) as [h|nh].
    + left. apply Mod_divides in h.
      destruct h as [k ->].
      exists (inu k). now rewrite inu_mult_hom, mult_comm.
    + right. intros [K HK]. apply nh.
      enough (exists k, inu k = K) as [k <-].
      * apply Mod_divides. exists k.
        rewrite mult_comm, <-inu_mult_hom in HK; auto.
        now apply inu_inj in HK; auto.
      * eapply std_mult'; eauto.
Qed.

Lemma Dec_div_reduction d ψ :
  prime_form ψ -> Dec (Div_nat d) -> Dec (fun n => div_pi ψ n d).
Proof.
  intros Hψ [H].
  constructor. intros n.
  destruct (H (Irred n)) as [h|nh].
  + left. apply ψ_equiv; auto.
  + right. intros [k ]%ψ_equiv; auto. apply nh.
    now exists k.
Qed.

Fact Std_is_Enumerable :
  (forall e, std e) -> Enumerable D.
Proof.
  intros H.
  exists (fun n => Some (inu n)).
  intros d. destruct (H d) as [n <-]; eauto.
Qed.

(* ** Variants of Tennenbaum's Theorem *)

Theorem Tennenbaum1 :
  MP ->
  Discrete D ->
  Enumerable D <-> forall e, std e.
Proof.
  intros mp eq.
  split.
  - intros ?.
    assert (~ exists e, ~ std e) as He.
    apply (DN_remove (Irred_repr)).
    intros [ψ ].
    { eapply Tennenbaum_diagonal' with (ψ0:=ψ); eauto. }
    intros e. apply MP_Discrete_stable_std; auto.
    intros nH. apply He. now exists e.
  - intros ?. now apply Std_is_Enumerable.
Qed.

Corollary Tennenbaum_insep :
  MP ->
  Discrete D ->
  (forall d, ~~Dec (Div_nat d)) -> (forall e, ~~std e).
Proof.
  intros mp eq DecDiv e.
  apply (DN_remove (Irred_repr)).
  intros [ψ ].
  refine (DN_remove (WCT_Inseparable _ _ wct) _); auto.
  - apply surj_form_.
  - apply enumerable_Q_prv.
  - intros ? He.
    eapply nonDecDiv; eauto.
    + now apply MP_Discrete_stable_std.
    + now exists e.
    + intros [d Hd]. apply (DecDiv d).
      intros h. apply Hd.
      now apply Dec_div_reduction.
Qed.

Theorem Tennenbaum2 :
  MP ->
  Discrete D ->
  (forall d, ~~Dec (Div_nat d)) <-> (forall e, std e).
Proof.
  intros mp eq. split.
  - intros ??. apply MP_Discrete_stable_std; auto.
    eapply Tennenbaum_insep; eauto.
  - intros ??. now apply Dec_Div_nat_std.
Qed.

Theorem Makholm :
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  nonStd D <-> exists d, ~ Dec (Div_nat d).
Proof.
  intros [ψ [H1 H2]] ?. split.
  - eapply Makholm; eauto.
  - intros [d Hd]. exists d.
  now intros ?%Dec_Div_nat_std.
Qed.

Lemma Tennenbaum3 :
  (UC nat bool) ->
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  ~ nonStd D.
Proof.
  intros ??? H.
  assert (nonStd D) as [e He]%Makholm by assumption; auto.
  refine (DN_Div_nat _ _ _ _ _ e _); auto.
Qed.

Lemma UC_Discrete :
  (forall X, UC X bool) -> Discrete D.
Proof.
  intros uc. unfold Discrete.
  apply UC_Def_Dec. apply uc.
  intros [x y]. destruct (@Peano.eq_dec D I axioms x y); now (left + right).
Qed.

Theorem McCarty :
  MP -> (forall X, UC X bool) ->
  (exists ψ, prime_form ψ /\ (obj_Coding ψ)) -> obj_Insep ->
  (forall e, std e).
Proof.
  intros ???? e.
  apply MP_Discrete_stable_std; auto.
  { now apply UC_Discrete. }
  intros He. apply Tennenbaum3; auto.
  now exists e.
Qed.

End Variants.
End T.

(*  Below, we list all major results again in a way that makes
    all their assumptions explicit.
 *)

Definition PA_model D I := forall ax, PA ax -> forall rho, @sat _ _ D I _ rho ax.

Theorem Tennenbaum2 {Δ1 : Delta1} D (I : interp D) :
 WCT_Q -> MP ->
 PA_model D I -> Discrete D ->
 (forall d, ~~Dec(T.Div_nat D I d)) <-> (forall e, std e).
Proof.
  intros; now apply T.Tennenbaum2.
Qed.

Theorem Makholm  {Δ1 : Delta1} D (I : interp D) ψ :
  WCT_Q -> T.obj_Insep ->
  PA_model D I ->
  T.prime_form ψ /\ obj_Coding ψ ->
  nonStd D -> exists d, ~ Dec (T.Div_nat D I d).
Proof.
  intros; eapply T.Makholm; eauto.
Qed.

Lemma Tennenbaum3 {Δ1 : Delta1} D (I : interp D) :
  WCT_Q -> (UC nat bool) -> T.obj_Insep ->
  PA_model D I ->
  (exists ψ, T.prime_form ψ /\ (obj_Coding ψ)) ->
  ~ nonStd D.
Proof.
  intros; apply T.Tennenbaum3; auto.
Qed.

Theorem McCarty {Δ1 : Delta1} D (I : interp D) :
  WCT_Q -> MP -> (forall X, UC X bool) ->
  PA_model D I ->
  (exists ψ, T.prime_form ψ /\ obj_Coding ψ) -> T.obj_Insep ->
  forall e, std e.
Proof.
  intros; apply T.McCarty; auto.
Qed.


From cgraphs.multiparty Require Import invariant langdef progress.
Require Import Coq.Logic.Classical.

(* This file contains the main theorems about MPGV. *)
(* This is the theorems part of section 5 in the paper. *)

(* The definitions used in this file can be found in definitions.v *)
(* The language definition can be found in langdef.v *)

(* Theorem 5.1 *)
Theorem global_progress e es h :
  typed ∅ e UnitT -> steps [e] ∅ es h ->
  (∃ es' h', step es h es' h') ∨ (h = ∅ ∧ ∀ e, e ∈ es -> e = Val UnitV).
Proof.
  intros. edestruct inv_global_progress; eauto using invariant_holds.
Qed.

(* Theorem 5.2 *)
Theorem reachability_deadlock_freedom es h :
  deadlock_free es h <-> fully_reachable es h.
Proof.
  unfold deadlock_free, fully_reachable.
  split.
  - intros. destruct (classic (reachable es h x)); eauto.
    assert (∃ s : gset object, ∀ x, x ∈ s <-> active es h x ∧ ¬ reachable es h x) as [s Hs].
    { edestruct activeset_exists. eapply subset_exists. naive_solver. }
    exfalso. eapply (H s).
    split; eauto.
    + set_solver.
    + naive_solver.
    + intros ???. assert (¬ reachable es h (Thread i)) by naive_solver.
      eauto using reachable.
    + intros ????.
      destruct (classic (Chan c ∈ s)); eauto. exfalso.
      eapply Hs in H2 as [].
      destruct (classic (reachable es h (Chan c))); eauto using reachable.
      assert (active es h (Chan c)).
      { destruct H3 as (?&?&?&?&?&?&?&?). eexists. eauto. }
      naive_solver.
    + intros. apply Hs in H2 as [].
      rewrite Hs.
      split. { by eapply obj_refs_active. }
      intro. eapply H4.
      eauto using reachable.
  - intros. intros [].
    eapply set_choose_L in dl_nonempty as [x Hx].
    assert (reachable es h x) as Q by eauto.
    induction Q; naive_solver.
Qed.

(* Theorem 5.3 *)
Theorem deadlock_freedom_and_full_reachability e es h :
  typed ∅ e UnitT -> steps [e] ∅ es h ->
  deadlock_free es h ∧ fully_reachable es h.
Proof.
  intros Htyped Hinv%invariant_holds; last done.
  split; [eapply reachability_deadlock_freedom|];
  unfold fully_reachable; eauto using strong_progress.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ Aprime O /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ C B /\ (wd_ C A /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ col_ O B Bprime))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* $Id: MoreFunctions.v,v 1.12 2003/03/13 12:06:20 lcf Exp $ *)

Require Export MoreIntervals.

Opaque Min Max.

Section Basic_Results.

(* Tex_Prose
\chapter{More about Functions}

Here we state all the main results about properties of functions that we already proved for compact intervals in the more general setting of arbitrary intervals.

\begin{convention} Let \verb!I:interval! and \verb!F,F',G,G'! be partial functions.
\end{convention}

\section{Continuity}
*)

Variable I:interval.

(* Tex_Prose
Trivial stuff.
*)

(* Begin_Tex_Verb *)
Lemma Continuous_imp_inc : (F:PartIR)
  (Continuous I F)->(included (iprop I) (Pred F)).
(* End_Tex_Verb *)
Intros; Elim H; Intros; Auto.
Qed.

(* Tex_Prose
\begin{convention} Assume that \verb!I! is compact and \verb!F! is continuous in \verb!I!.
\end{convention}
*)

Hypothesis cI:(compact_ I).
Variable F:PartIR.
Hypothesis contF:(Continuous I F).

(* Begin_Tex_Verb *)
Lemma continuous_compact :
  (H:?)(!Continuous_I (Lend cI) (Rend cI) H F).
(* End_Tex_Verb *)
Intros.
Elim contF; Intros incF contF'.
Contin.
Qed.

(* Begin_Tex_Verb *)
Hypothesis Hinc:(included (iprop I) (Pred F)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Continuous_I_imp_tb_image :
  (totally_bounded [x:IR]
    {y:IR & {Hy:(iprop I y) | x[=](F y (Hinc y Hy))}}).
(* End_Tex_Verb *)
Cut (Continuous_I (Lend_leEq_Rend ? cI) F); Intros.
Elim (Continuous_I_imp_tb_image ???? H); Intros.
Split; [Clear b | Clear a].
Elim a; Intros x Hx.
Elim Hx; Intros y Hy.
Elim Hy; Clear a Hx Hy; Intros Hy Hx.
Exists x; Exists y; Exists (compact_interval_inc ???? Hy).
EApply eq_transitive_unfolded.
Apply Hx.
Algebra.
Intros e He.
Elim (b e He); Intros l H0 H1.
Exists l; Clear b; [Clear H1 | Clear H0].
Intros x Hx.
Elim (H0 x Hx); Intros y Hy.
Elim Hy; Clear H0 Hy Hx; Intros Hy Hx.
Exists y; Exists (compact_interval_inc ???? Hy).
EApply eq_transitive_unfolded.
Apply Hx.
Algebra.
Intros.
Apply H1.
Clear H1.
Elim H0; Intros y Hy.
Elim Hy; Clear H0 Hy; Intros Hy Hx.
Exists y; Exists (interval_compact_inc ?? (Lend_leEq_Rend ? cI) ? Hy).
EApply eq_transitive_unfolded.
Apply Hx.
Algebra.
Apply continuous_compact.
Qed.

(* Begin_Tex_Verb *)
Definition FNorm :=
  (Norm_Funct (continuous_compact (Lend_leEq_Rend ? cI))).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma FNorm_bnd_AbsIR :
  (x:IR)(iprop I x)->(Hx:?)(AbsIR (F x Hx))[<=]FNorm.
(* End_Tex_Verb *)
Intros; Unfold FNorm.
Apply norm_bnd_AbsIR.
Apply interval_compact_inc; Auto.
Qed.

End Basic_Results.

Hints Resolve Continuous_imp_inc : included.

Section Other_Results.

(* Tex_Prose
The usual stuff.
*)

Variable I:interval.

Variables F,G:PartIR.

(* Begin_Tex_Verb *)
Lemma Continuous_wd :
  (Feq (iprop I) F G)->(Continuous I F)->(Continuous I G).
(* End_Tex_Verb *)
Intros.
Elim H; Intros H' eqFG.
Elim H'; Clear H H'; Intros incF incG.
Elim H0; Clear H0; Intros incF' contF.
Split.
Auto.
Intros.
Apply Continuous_I_wd with F.
FEQ.
Simpl; Algebra.
Auto.
Qed.

(* Begin_Tex_Verb *)
Hypothesis contF : (Continuous I F).
Hypothesis contG : (Continuous I G).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma included_imp_Continuous : (a,b,Hab:?)
  (included (compact a b Hab) (iprop I))->(Continuous_I Hab F).
(* End_Tex_Verb *)
Intros.
Elim contF; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Included_imp_Continuous : (J:interval)
  (included (iprop J) (iprop I))->(Continuous J F).
(* End_Tex_Verb *)
Intros.
Split.
Exact (included_trans ??? H (Continuous_imp_inc ?? contF)).
Intros.
Apply included_imp_Continuous; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_const : (c:IR)(Continuous I {-C-}c).
(* End_Tex_Verb *)
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_id : (Continuous I FId).
(* End_Tex_Verb *)
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_plus : (Continuous I F{+}G).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Elim contG; Intros incG' contG'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_inv : (Continuous I {--}F).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_minus : (Continuous I F{-}G).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Elim contG; Intros incG' contG'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_mult : (Continuous I F{*}G).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Elim contG; Intros incG' contG'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_nth : (n:nat)(Continuous I F{^}n).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_scal : (c:IR)(Continuous I c{**}F).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_abs : (Continuous I (FAbs F)).
(* End_Tex_Verb *)
Elim contF; Intros incF' contF'.
Split; Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_recip :
  (bnd_away_zero_in_P G (iprop I))->(Continuous I {1/}G).
(* End_Tex_Verb *)
Intro.
Elim contG; Intros incG' contG'.
Cut (x:IR)(iprop I x)->(Hx:?)(G x Hx)[#]Zero; Intros.
Split; Contin.
Apply bnd_imp_ap_zero with (Compact (leEq_reflexive ? x)); Auto.
Apply H; Auto.
Exact (compact_single_iprop I x H0).
Exact (compact_single_prop x).
Qed.

End Other_Results.

Hints Resolve continuous_compact Continuous_const Continuous_id Continuous_plus Continuous_inv
  Continuous_minus Continuous_mult Continuous_scal Continuous_nth Continuous_recip Continuous_abs : continuous.

Hints Immediate included_imp_Continuous Included_imp_Continuous : continuous.

Section Corollaries.

Variable I:interval.

Hypothesis cI:(compact_ I).
Variables F,G:PartIR.

Hypothesis contF : (Continuous I F).
Hypothesis contG : (Continuous I G).

(* Begin_Tex_Verb *)
Lemma Continuous_div :
  (bnd_away_zero_in_P G (iprop I))->(Continuous I F{/}G).
(* End_Tex_Verb *)
Intros.
Apply Continuous_wd with F{*}{1/}G.
FEQ.
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma FNorm_wd :
  (Feq (iprop I) F G)->(FNorm I cI F contF)[=](FNorm I cI G contG).
(* End_Tex_Verb *)
Intros; Unfold FNorm; Apply Norm_Funct_wd.
EApply included_Feq.
2: Apply H.
Included.
Qed.

End Corollaries.

Hints Resolve Continuous_div : continuous.

Section Sums.

Variable I:interval.

(* Begin_Tex_Verb *)
Lemma Continuous_Sumx : (n:nat)(f:(i:nat)(lt i n)->PartIR)
  ((i:nat)(Hi:?)(Continuous I (f i Hi)))->
  (Continuous I (FSumx n f)).
(* End_Tex_Verb *)
Intro; Induction n; Intros f contF.
Simpl; Contin.
Simpl; Contin.
Qed.

(* Tex_Prose
\begin{convention} Assume \verb!f! is a sequence of continuous functions.
\end{convention}
*)

Variable f:nat->PartIR.
Hypothesis contF : (n:nat)(Continuous I (f n)).

(* Begin_Tex_Verb *)
Lemma Continuous_Sum0 : (n:nat)(Continuous I (FSum0 n f)).
(* End_Tex_Verb *)
Intros.
Induction n.
EApply Continuous_wd.
Apply FSum0_0; Included.
Contin.
EApply Continuous_wd.
Apply FSum0_S; Included.
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma Continuous_Sum : (m,n:nat)(Continuous I (FSum m n f)).
(* End_Tex_Verb *)
Intros.
EApply Continuous_wd.
Apply Feq_symmetric; Apply FSum_FSum0'; Included.
Apply Continuous_minus; Apply Continuous_Sum0.
Qed.

End Sums.

Hints Resolve Continuous_Sum0 Continuous_Sumx Continuous_Sum : continuous.

Section Basic_Properties.

(* Tex_Prose
\section{Derivative}

Derivative is not that much different.

\begin{convention} From this point on we assume \verb!I! to be proper.
\end{convention}
*)

Variable I:interval.
Hypothesis pI:(proper I).

Variables F,G,H:PartIR.

(* Begin_Tex_Verb *)
Lemma Derivative_wdl : (Feq (iprop I) F G)->
  (Derivative I pI F H)->(Derivative I pI G H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros H0' Heq.
Elim H0'; Intros incF incG.
Elim H1; Intros incF' H1'.
Elim H1'; Intros incH' derF.
Split.
Auto.
Split.
Auto.
Intros; Apply Derivative_I_wdl with F; Auto.
Apply included_Feq with (iprop I); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_wdr : (Feq (iprop I) F G)->
  (Derivative I pI H F)->(Derivative I pI H G).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros H0' Heq.
Elim H0'; Intros incF incG.
Elim H1; Intros incF' H1'.
Elim H1'; Intros incH' derF.
Split.
Auto.
Split.
Auto.
Intros; Apply Derivative_I_wdr with F; Auto.
Apply included_Feq with (iprop I); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_unique : (Derivative I pI F G)->
  (Derivative I pI F H)->(Feq (iprop I) G H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF H0'.
Elim H0'; Intros incG derFG.
Elim H1; Intros incF' H1'.
Elim H1'; Intros incH derFH.
Apply included_Feq''; Intros.
Auto.
Apply Derivative_I_unique with F; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_inc :
  (Derivative I pI F G)->(included (iprop I) (Pred F)).
(* End_Tex_Verb *)
Intro.
Inversion_clear H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_inc' :
  (Derivative I pI F G)->(included (iprop I) (Pred G)).
(* End_Tex_Verb *)
Intro.
Inversion_clear H0.
Inversion_clear H2; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_Continuous :
  (Derivative I pI F G)->(Continuous I F).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF H'.
Elim H'; Intros incG derF.
Clear H0 H'.
Split; Intros.
Included.
Elim (compact_proper_in_interval ??? Hab H0 pI); Intros a' Ha.
Elim Ha; Clear Ha; Intros b' Hb.
Elim Hb; Clear Hb; Intros Hab' H2 H3.
Apply included_imp_contin with Hab:=(less_leEq ??? Hab').
Auto.
Apply deriv_imp_contin_I with Hab' G; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_Continuous' :
  (Derivative I pI F G)->(Continuous I G).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF H'.
Elim H'; Intros incG derF.
Clear H0 H'.
Split; Intros.
Included.
Elim (compact_proper_in_interval ??? Hab H0 pI); Intros a' Ha.
Elim Ha; Clear Ha; Intros b' Hb.
Elim Hb; Clear Hb; Intros Hab' H2 H3.
Apply included_imp_contin with Hab:=(less_leEq ??? Hab').
Auto.
Apply deriv_imp_contin'_I with Hab' F; Auto.
Qed.

End Basic_Properties.

Hints Immediate Derivative_imp_inc Derivative_imp_inc' : included.
Hints Immediate Derivative_imp_Continuous Derivative_imp_Continuous' : continuous.

Section More_Results.

Variable I:interval.
Hypothesis pI:(proper I).

(* Tex_Prose
\begin{convention} Assume that \verb!F'! and \verb!G'! are derivatives of \verb!F! and \verb!G!, respectively, in \verb!I!.
\end{convention}
*)

Variables F,F',G,G':PartIR.

Hypothesis derF : (Derivative I pI F F').
Hypothesis derG : (Derivative I pI G G').

(* Begin_Tex_Verb *)
Lemma included_imp_Derivative : (a,b,Hab:?)
  (included (compact a b (less_leEq ??? Hab)) (iprop I))->
    (Derivative_I Hab F F').
(* End_Tex_Verb *)
Intros.
Elim derF; Intros incF H'.
Elim H'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Included_imp_Derivative : (J,pJ:?)
  (included (iprop J) (iprop I))->(Derivative J pJ F F').
(* End_Tex_Verb *)
Intros.
Split.
Exact (included_trans ??? H (Derivative_imp_inc ???? derF)).
Split.
Exact (included_trans ??? H (Derivative_imp_inc' ???? derF)).
Intros.
Apply included_imp_Derivative; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_const :
  (c:IR)(Derivative I pI {-C-}c {-C-}Zero).
(* End_Tex_Verb *)
Intros; Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_id : (Derivative I pI FId {-C-}One).
(* End_Tex_Verb *)
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_plus : (Derivative I pI F{+}G F'{+}G').
(* End_Tex_Verb *)
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Elim derG; Intros incG H'.
Elim H'; Intros incG' derivG.
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_inv : (Derivative I pI {--}F {--}F').
(* End_Tex_Verb *)
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_minus : (Derivative I pI F{-}G F'{-}G').
(* End_Tex_Verb *)
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Elim derG; Intros incG H'.
Elim H'; Intros incG' derivG.
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_mult : (Derivative I pI F{*}G F{*}G'{+}F'{*}G).
(* End_Tex_Verb *)
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Elim derG; Intros incG H'.
Elim H'; Intros incG' derivG.
Split.
Included.
Split.
Apply included_FPlus; Included.
Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_scal : (c:IR)(Derivative I pI c{**}F c{**}F').
(* End_Tex_Verb *)
Intro.
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_nth : (n:nat)
  (Derivative I pI F{^}(S n) (nring (S n)){**}(F'{*}F{^}n)).
(* End_Tex_Verb *)
Elim derF; Intros incF H.
Elim H; Intros incF' derivF.
Split.
Included.
Split; Deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_recip : (bnd_away_zero_in_P G (iprop I))->
  (Derivative I pI {1/}G {--}(G'{/}(G{*}G))).
(* End_Tex_Verb *)
Elim derG; Intros incG H'.
Elim H'; Intros incG' derivG.
Clear derF derG H'.
Intro.
Cut (x:IR)(iprop I x)->(Hx:?)(Part G x Hx)[#]Zero; Intros.
Cut (x:IR)(iprop I x)->(Hx:?)(G{*}G x Hx)[#]Zero; Intros.
Split.
Included.
Split; Deriv.
Simpl; Apply mult_resp_ap_zero; Auto.
Included.
Qed.

End More_Results.

Section More_Corollaries.

Variable I:interval.
Hypothesis pI:(proper I).

Variables F,F',G,G':PartIR.

Hypothesis derF : (Derivative I pI F F').
Hypothesis derG : (Derivative I pI G G').

(* Begin_Tex_Verb *)
Hypothesis Gbnd:(bnd_away_zero_in_P G (iprop I)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Derivative_div :
  (Derivative I pI F{/}G (F'{*}G{-}F{*}G'){/}(G{*}G)).
(* End_Tex_Verb *)
Elim derF; Intros incF Hf.
Elim Hf; Intros incF' Hf'.
Elim derG; Intros incG derivG.
Elim derivG; Intros incG' Hg'.
Clear Hf derivG.
Cut (x:IR)(iprop I x)->(Hx:?)(Part G x Hx)[#]Zero; Intros.
Split.
Included.
Split.
Apply included_FDiv.
Apply included_FMinus; Included.
Included.
Intros; Simpl; Apply mult_resp_ap_zero; Auto.
Deriv.
Included.
Qed.

End More_Corollaries.

Section More_Sums.

Variable I:interval.
Hypothesis pI:(proper I).

(* Begin_Tex_Verb *)
Lemma Derivative_Sumx : (n:nat)(f,f':(i:nat)(lt i n)->PartIR)
  ((i:nat)(Hi,Hi':?)(Derivative I pI (f i Hi) (f' i Hi')))->
  (Derivative I pI (FSumx n f) (FSumx n f')).
(* End_Tex_Verb *)
Intro; Induction n; Intros f f' derF.
Simpl; Apply Derivative_const; Auto.
Simpl; Apply Derivative_plus; Auto.
Qed.

(* Begin_Tex_Verb *)
Variables f,f':nat->PartIR.
Hypothesis derF : (n:nat)(Derivative I pI (f n) (f' n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Derivative_Sum0 : (n:nat)
  (Derivative I pI (FSum0 n f) (FSum0 n f')).
(* End_Tex_Verb *)
Intros.
Induction n.
EApply Derivative_wdl.
Apply FSum0_0; Included.
EApply Derivative_wdr.
Apply FSum0_0; Included.
Apply Derivative_const.
EApply Derivative_wdl.
Apply FSum0_S; Included.
EApply Derivative_wdr.
Apply FSum0_S; Included.
Apply Derivative_plus; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_Sum : (m,n:nat)
  (Derivative I pI (FSum m n f) (FSum m n f')).
(* End_Tex_Verb *)
Intros.
EApply Derivative_wdl.
Apply Feq_symmetric; Apply FSum_FSum0'; Included.
EApply Derivative_wdr.
Apply Feq_symmetric; Apply FSum_FSum0'; Included.
Apply Derivative_minus; Apply Derivative_Sum0.
Qed.

End More_Sums.

Section Diffble_Basic_Properties.

(* Tex_Prose
\section{Differentiability}

\emph{Mutatis mutandis} for differentiability.
*)

Variable I:interval.
Hypothesis pI:(proper I).

(* Begin_Tex_Verb *)
Lemma Diffble_imp_inc : (F:PartIR)
  (Diffble I pI F)->(included (iprop I) (Pred F)).
(* End_Tex_Verb *)
Intros.
Inversion_clear H.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_imp_Diffble : (F,F':PartIR)
  (Derivative I pI F F')->(Diffble I pI F).
(* End_Tex_Verb *)
Intros.
Elim H; Intros incF H'.
Elim H'; Intros incF' derivF.
Split; Auto.
Intros; Apply deriv_imp_Diffble_I with F'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_wd : (F,H:PartIR)(Feq (iprop I) F H)->
  (Diffble I pI F)->(Diffble I pI H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros H2 eqFH.
Elim H2; Intros incF incH.
Inversion_clear H1.
Split; Auto.
Intros; Apply Diffble_I_wd with F; Auto.
Apply included_Feq with (iprop I); Auto.
Qed.

Variables F,G:PartIR.

Hypothesis diffF:(Diffble I pI F).
Hypothesis diffG:(Diffble I pI G).

(* Tex_Prose
\begin{convention} Assume \verb!F! and \verb!G! are differentiable in \verb!I!.
\end{convention}
*)

(* Begin_Tex_Verb *)
Lemma included_imp_Diffble : (a,b,Hab:?)
  (included (compact a b (less_leEq ??? Hab)) (iprop I))->
    (Diffble_I Hab F).
(* End_Tex_Verb *)
Intros.
Elim diffF; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Included_imp_Diffble : (J,pJ:?)
  (included (iprop J) (iprop I))->(Diffble J pJ F).
(* End_Tex_Verb *)
Intros.
Split.
Exact (included_trans ??? H (Diffble_imp_inc ? diffF)).
Intros; Apply included_imp_Diffble; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_const : (c:IR)(Diffble I pI {-C-}c).
(* End_Tex_Verb *)
Intro.
Split.
Included.
Intros; Apply Diffble_I_const.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_id : (Diffble I pI FId).
(* End_Tex_Verb *)
Split.
Included.
Intros; Apply Diffble_I_id.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_plus : (Diffble I pI F{+}G).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Elim diffG; Intros incG diffbleG.
Split.
Included.
Intros; Apply Diffble_I_plus; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_inv : (Diffble I pI {--}F).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Split.
Included.
Intros; Apply Diffble_I_inv; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_minus : (Diffble I pI F{-}G).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Elim diffG; Intros incG diffbleG.
Split.
Included.
Intros; Apply Diffble_I_minus; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_mult : (Diffble I pI F{*}G).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Elim diffG; Intros incG diffbleG.
Split.
Included.
Intros; Apply Diffble_I_mult; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_nth : (n:nat)(Diffble I pI F{^}n).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Split.
Included.
Intros; Apply Diffble_I_nth; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_scal : (c:IR)(Diffble I pI c{**}F).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Split.
Included.
Intros; Apply Diffble_I_scal; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_recip :
  (bnd_away_zero_in_P G (iprop I))->(Diffble I pI {1/}G).
(* End_Tex_Verb *)
Elim diffG; Intros incG diffbleG Gbnd.
Cut (x:IR)(iprop I x)->(Hx:?)(Part G x Hx)[#]Zero; Intros.
Split.
Included.
Intros; Apply Diffble_I_recip; Auto.
Included.
Qed.

End Diffble_Basic_Properties.

Hints Immediate Diffble_imp_inc : included.

Section Diffble_Corollaries.

Variable I:interval.
Hypothesis pI:(proper I).

Variables F,G:PartIR.

Hypothesis diffF:(Diffble I pI F).
Hypothesis diffG:(Diffble I pI G).

(* Begin_Tex_Verb *)
Lemma Diffble_div :
  (bnd_away_zero_in_P G (iprop I))->(Diffble I pI F{/}G).
(* End_Tex_Verb *)
Intro.
Apply Diffble_wd with F{*}{1/}G.
Apply eq_imp_Feq.
Apply included_FMult.
Apply Diffble_imp_inc with pI; Apply diffF.
Apply included_FRecip.
Apply Diffble_imp_inc with pI; Apply diffG.
Included.
Apply included_FDiv.
Apply Diffble_imp_inc with pI; Apply diffF.
Apply Diffble_imp_inc with pI; Apply diffG.
Included.
Intros; Simpl; Rational.
Apply Diffble_mult; Auto.
Apply Diffble_recip; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_Sum0 : (f:?)((n:nat)(Diffble I pI (f n)))->
  (n:nat)(Diffble I pI (FSum0 n f)).
(* End_Tex_Verb *)
Intros f hypF n.
Split.
Red; Simpl; Intros.
Elim (hypF n0); Intros.
Exact (a x H).
Intros; Apply Diffble_I_Sum0; Auto.
Intro; Elim (hypF n0); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_Sumx : (n:nat)(f:?)(good_fun_seq' n f)->
  ((i:nat)(Hi:?)(Diffble I pI (f i Hi)))->(Diffble I pI (FSumx n f)).
(* End_Tex_Verb *)
Intros n f Hgood hypF.
Split.
Red; Intros.
Apply FSumx_pred'; Auto.
Intros.
Elim (hypF i Hi); Auto.
Intros; Apply Diffble_I_Sumx.
Intros i Hi; Elim (hypF i Hi); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_Sum : (f:?)((n:nat)(Diffble I pI (f n)))->
  (m,n:nat)(Diffble I pI (FSum m n f)).
(* End_Tex_Verb *)
Intros f hypF m n.
EApply Diffble_wd.
Apply Feq_symmetric; Apply FSum_FSum0'.
Intro; Apply Diffble_imp_inc with pI; Auto.
Apply Diffble_minus; Apply Diffble_Sum0; Auto.
Qed.

End Diffble_Corollaries.

Section Nth_Derivative.

(* Tex_Prose
\section{N$^{\mathrm{th}}$ Derivative}

Higher order derivatives pose more interesting problems.  It turns out that it really becomes necessary to generalize our \verb!n_deriv! operator to any interval.
*)

Variable I:interval.
Hypothesis pI : (proper I).

Section Definitions.

(* Tex_Prose
\begin{convention} Let \verb!n:nat!, \verb!F:PartIR! and assume that \verb!F! is $n$-times differentiable in \verb!I!.
\end{convention}
*)

Variable n:nat.
Variable F:PartIR.
Hypothesis diffF:(Diffble_n n I pI F).

(* Begin_Tex_Verb *)
Definition N_Deriv_fun : (x:IR)(iprop I x)->IR.
(* End_Tex_Verb *)
Intros.
LetTac J:=(compact_in_interval I pI x H).
Elim diffF; Intros incF diffbleF.
LetTac a:=(Lend (compact_compact_in_interval I pI x H)).
LetTac b:=(Rend (compact_compact_in_interval I pI x H)).
Fold J in a b.
Cut a[<]b; Intros.
Cut (Diffble_I_n H0 n F); Intros.
Apply (Part (n_deriv_I ????? H1) x).
Apply n_deriv_inc.
Unfold a b J; Apply iprop_compact_in_interval_inc2.
Apply iprop_compact_in_interval.
Apply diffbleF.
Apply included_trans with (iprop J); Unfold a b J; Included.
Unfold a b J; Apply proper_compact_in_interval'.
Defined.

(* Begin_Tex_Verb *)
Lemma N_Deriv_char
(* End_Tex_Verb *)
 : (x,Hx,H:?)(N_Deriv_fun x Hx)[=]
  (Part (n_deriv_I ?? (proper_compact_in_interval' ???? (compact_compact_in_interval I pI x Hx)) n F H) x
    (n_deriv_inc ??????? (iprop_compact_in_interval_inc2 ???? (compact_compact_in_interval ????)
      (less_leEq ??? (proper_compact_in_interval' ???? (compact_compact_in_interval ????))) ? (iprop_compact_in_interval ????)))).
Intros.
Unfold N_Deriv_fun.
Elim diffF; Intros; Simpl.
Apply n_deriv_I_wd'.
Algebra.
Apply iprop_compact_in_interval'.
Apply iprop_compact_in_interval'.
Apply b.
Apply included_trans with (Compact (less_leEq ??? (proper_compact_in_interval' ???? (compact_compact_in_interval I pI x Hx)))).
2: Included.
Red; Intros.
Inversion_clear H0.
Split.
EApply leEq_wdl.
Apply H1.
EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft; Apply eq_imp_leEq.
Apply compact_in_interval_wd1; Algebra.
EApply leEq_wdr.
Apply H2.
Apply leEq_imp_Max_is_rht; Apply eq_imp_leEq.
Apply compact_in_interval_wd2; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma N_Deriv_strext : (x,y:IR)(Hx,Hy:?)
  (((N_Deriv_fun x Hx)[#](N_Deriv_fun y Hy))->(x[#]y)).
(* End_Tex_Verb *)
Intros.
Elim diffF; Intros incF diffbleF.
Cut (Diffble_I_n (proper_compact_in_interval2' ?????? (compact_compact_in_interval2 I pI x y Hx Hy)) n F); Intros.
Cut (Diffble_I_n (proper_compact_in_interval' ???? (compact_compact_in_interval I pI x Hx)) n F); Intros.
Cut (Diffble_I_n (proper_compact_in_interval' ???? (compact_compact_in_interval I pI y Hy)) n F); Intros.
Cut (Pred (n_deriv_I ????? H0) x); Intros.
Cut (Pred (n_deriv_I ????? H0) y); Intros.
Apply pfstrx with Hx:=H3 Hy:=H4.
EApply ap_well_def_lft_unfolded.
EApply ap_well_def_rht_unfolded.
Apply H.
EApply eq_transitive_unfolded.
Apply (N_Deriv_char y Hy H2).
Apply n_deriv_I_wd'.
Algebra.
Apply iprop_compact_in_interval_inc2; Apply iprop_compact_in_interval.
Apply iprop_compact_in_interval2_inc2; Apply iprop_compact_in_interval2y.
Apply included_imp_diffble_n with Hab':=(proper_compact_in_interval2' ?????? (compact_compact_in_interval2 I pI x y Hx Hy)).
2: Apply H0.
Red; Intros z Hz.
Inversion_clear Hz; Split.
EApply leEq_wdl.
Apply H5.
EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft.
Apply compact_in_interval_y_lft.
EApply leEq_wdr.
Apply H6.
Apply leEq_imp_Max_is_rht.
Apply compact_in_interval_y_rht.
EApply eq_transitive_unfolded.
Apply (N_Deriv_char x Hx H1).
Apply n_deriv_I_wd'.
Algebra.
Apply iprop_compact_in_interval_inc2; Apply iprop_compact_in_interval.
Apply iprop_compact_in_interval2_inc2; Apply iprop_compact_in_interval2x.
Apply included_imp_diffble_n with Hab':=(proper_compact_in_interval2' ?????? (compact_compact_in_interval2 I pI x y Hx Hy)).
2: Apply H0.
Red; Intros z Hz.
Inversion_clear Hz; Split.
EApply leEq_wdl.
Apply H5.
EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft.
Apply compact_in_interval_x_lft.
EApply leEq_wdr.
Apply H6.
Apply leEq_imp_Max_is_rht.
Apply compact_in_interval_x_rht.
Apply n_deriv_inc.
Apply iprop_compact_in_interval2_inc2; Apply iprop_compact_in_interval2y.
Apply n_deriv_inc.
Apply iprop_compact_in_interval2_inc2; Apply iprop_compact_in_interval2x.
Apply diffbleF.
Simpl; Included.
Apply diffbleF.
Simpl; Included.
Apply diffbleF.
Simpl; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma N_Deriv_wd : (x,y:IR)(Hx,Hy:?)(x[=]y)->
  (N_Deriv_fun x Hx)[=](N_Deriv_fun y Hy).
(* End_Tex_Verb *)
Intros.
Apply not_ap_imp_eq; Intro.
Cut x[#]y.
Apply eq_imp_not_ap; Auto.
Exact (N_Deriv_strext ???? H0).
Qed.

(* Begin_Tex_Verb *)
Definition N_Deriv : PartIR.
(* End_Tex_Verb *)
Apply Build_PartFunct with pfpfun:=N_Deriv_fun.
Apply iprop_wd.
Exact N_Deriv_strext.
Defined.

End Definitions.

Section Basic_Results.

(* Tex_Prose
All the usual results hold.
*)

(* Begin_Tex_Verb *)
Lemma Diffble_n_wd : (n:nat)(F,G:PartIR)(Feq (iprop I) F G)->
  (Diffble_n n I pI F)->(Diffble_n n I pI G).
(* End_Tex_Verb *)
Intros.
Elim H; Intros H1.
Elim H1; Intros incG incF.
Split.
Auto.
Intros; Apply Diffble_I_n_wd with F.
Apply included_Feq with (iprop I); Auto.
Elim H0; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_wdr : (n,F,G,H:?)(Feq (iprop I) G H)->
  (Derivative_n n I pI F G)->(Derivative_n n I pI F H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros H2 Heq.
Elim H2; Intros incG incH.
Elim H1; Intros incF H0'.
Elim H0'; Intros incG' derivF.
Clear H2 H0'.
Split; Auto.
Split; Auto.
Intros; Apply Derivative_I_n_wdr with G.
Apply included_Feq with (iprop I); Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_wdl : (n,F,G,H:?)(Feq (iprop I) F G)->
  (Derivative_n n I pI F H)->(Derivative_n n I pI G H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros H2 Heq.
Elim H2; Intros incG incH.
Elim H1; Intros incF H0'.
Elim H0'; Intros incG' derivF.
Clear H2 H0'.
Split; Auto.
Split; Auto.
Intros; Apply Derivative_I_n_wdl with F.
Apply included_Feq with (iprop I); Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_unique : (n:nat)(F,G,H:PartIR)
  (Derivative_n n I pI F G)->(Derivative_n n I pI F H)->
  (Feq (iprop I) G H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF H2.
Elim H2; Intros incG derivFG.
Elim H1; Intros incF' H3.
Elim H3; Intros incH derivFH.
FEQ.
Apply Feq_imp_eq with (Compact (less_leEq ??? (proper_compact_in_interval' ???? (compact_compact_in_interval I pI x H4)))).
Apply Derivative_I_n_unique with n F.
Apply derivFG.
Simpl; Included.
Apply derivFH.
Simpl; Included.
Apply interval_compact_inc.
Apply iprop_compact_in_interval.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_n_imp_Diffble : (n:nat)(lt O n)->(F:PartIR)
  (Diffble_n n I pI F)->(Diffble I pI F).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF diffF.
Split; Auto.
Intros; Apply Diffble_I_n_imp_diffble with n; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_Diffble : (n:nat)(lt O n)->(F,F':PartIR)
  (Derivative_n n I pI F F')->(Diffble I pI F).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF H1.
Elim H1; Intros incF' derivF.
Split; Auto.
Intros; Apply deriv_n_imp_diffble with n F'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma le_imp_Diffble_n : (m,n:nat)(le m n)->(F:PartIR)
  (Diffble_n n I pI F)->(Diffble_n m I pI F).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF diffF.
Split; Auto.
Intros; Apply le_imp_Diffble_I with n; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_n_imp_le : (n:nat)(lt O n)->(F,F':PartIR)
  (Diffble_n n I pI F)->(Derivative I pI F F')->
    (Diffble_n (pred n) I pI F').
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF diffF.
Elim H1; Intros incFa H2.
Elim H2; Intros incF' derivF.
Split; Auto.
Intros; Apply Diffble_I_imp_le with F; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Diffble_n_imp_inc : (n:nat)(F:PartIR)
  (Diffble_n n I pI F)->(included (iprop I) (Pred F)).
(* End_Tex_Verb *)
Intros.
Inversion_clear H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_Diffble_n : (n:nat)(F,F':PartIR)
  (Derivative_n n I pI F F')->(Diffble_n n I pI F).
(* End_Tex_Verb *)
Intros.
Elim H; Intros incF H1.
Elim H1; Intros incF' derivF.
Split; Auto.
Intros; Apply deriv_n_imp_Diffble_I_n with F'; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_inc : (n:nat)(F,F':PartIR)
  (Derivative_n n I pI F F')->(included (iprop I) (Pred F)).
(* End_Tex_Verb *)
Intros.
Inversion_clear H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_inc' : (n:nat)(F,F':PartIR)
  (Derivative_n n I pI F F')->(included (iprop I) (Pred F')).
(* End_Tex_Verb *)
Intros.
Inversion_clear H; Inversion_clear H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_imp_Derivative_n : (n,F,F',a,b,Hab:?)
  (Derivative_n n I pI F F')->
  (included (Compact (less_leEq ??? Hab)) (iprop I))->
  (!Derivative_I_n a b Hab n F F').
(* End_Tex_Verb *)
Intros.
Elim H; Intros incF H1.
Elim H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma included_imp_Diffble_n : (n,F,a,b,Hab:?)
  (Diffble_n n I pI F)->
  (included (Compact (less_leEq ??? Hab)) (iprop I))->
  (!Diffble_I_n a b Hab n F).
(* End_Tex_Verb *)
Intros.
Elim H; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Included_imp_Derivative_n : (n:nat)(J,pJ:?)(F,F':PartIR)
  (included (iprop J) (iprop I))->(Derivative_n n I pI F F')->
  (Derivative_n n J pJ F F').
(* End_Tex_Verb *)
Intros.
Inversion_clear H0.
Inversion_clear H2.
Split.
Included.
Split.
Included.
Intros; Apply H3.
Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Included_imp_Diffble_n : (n:nat)(J,pJ:?)(F:PartIR)
  (included (iprop J) (iprop I))->
  (Diffble_n n I pI F)->(Diffble_n n J pJ F).
(* End_Tex_Verb *)
Intros.
Inversion_clear H0.
Split.
Included.
Intros; Apply H2.
Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_plus : (J,pJ,n,m,k,F,G,H:?)
  (Derivative_n m J pJ F G)->(Derivative_n n J pJ G H)->
  k=(plus m n)->(Derivative_n k J pJ F H).
(* End_Tex_Verb *)
Intros.
Elim H0; Intros incF Hf.
Elim Hf; Intros incG derFG.
Elim H1; Intros incG' Hg.
Elim Hg; Intros incH derGH.
Clear Hf Hg.
Split; Auto.
Split; Auto.
Intros; Apply Derivative_I_n_plus with n m G; Auto.
Qed.

End Basic_Results.

Section More_Results.

(* Tex_Prose
Some new results hold, too:
*)

(* Begin_Tex_Verb *)
Lemma N_Deriv_Feq : (n,F,diffF,a,b,Hab,H:?)
  (incN:(included (Compact (less_leEq ??? Hab))
                  (Pred (N_Deriv n F diffF))))
  (Feq (Compact (less_leEq ??? Hab))
       (N_Deriv n F diffF) (n_deriv_I a b Hab n F H)).
(* End_Tex_Verb *)
Intros.
FEQ.
Apply n_deriv_inc.
Simpl.
Cut (!Diffble_I_n ?? (proper_compact_in_interval' ???? (compact_compact_in_interval I pI x Hx)) n F); Intros.
EApply eq_transitive_unfolded.
Apply (N_Deriv_char n F diffF x Hx H1).
Apply n_deriv_I_wd'; Auto.
Algebra.
Apply iprop_compact_in_interval_inc2; Apply iprop_compact_in_interval.
Apply included_imp_Diffble_n; Auto.
Apply included_interval'.
Apply (included_compact_in_interval I pI x Hx).
Apply (iprop_compact_in_interval_inc1 ???? (compact_compact_in_interval I pI x Hx)
  (Lend_leEq_Rend ? (compact_compact_in_interval I pI x Hx))).
Apply compact_inc_lft.
Apply (included_compact_in_interval I pI x Hx).
Apply (iprop_compact_in_interval_inc1 ???? (compact_compact_in_interval I pI x Hx)
  (Lend_leEq_Rend ? (compact_compact_in_interval I pI x Hx))).
Apply compact_inc_rht.
Apply incN; Apply compact_inc_lft.
Apply incN; Apply compact_inc_rht.
Elim diffF; Intros incF diffbleF.
Apply diffbleF; Auto.
EApply included_trans.
Apply iprop_compact_in_interval_inc1.
Included.
Qed.

(* Begin_Tex_Verb *)
Lemma N_Deriv_lemma : (n:nat)(F:PartIR)(H:(Diffble_n n I pI F))
  (Derivative_n n I pI F (N_Deriv ?? H)).
(* End_Tex_Verb *)
Intros.
Elim H; Intros incF diffF.
Split; Auto.
Split; Included.
Intros.
Cut (Diffble_I_n Hab n F); Intros; Auto.
EApply Derivative_I_n_wdr.
Apply Feq_symmetric; Apply (N_Deriv_Feq n F (incF,diffF) ?? Hab H1 H0).
Apply n_deriv_lemma.
Qed.

(* Begin_Tex_Verb *)
Lemma N_Deriv_S : (n:nat)(F:PartIR)
  (H:(Diffble_n n I pI F))(H':(Diffble_n (S n) I pI F))
  (Derivative I pI (N_Deriv ?? H) (N_Deriv ?? H')).
(* End_Tex_Verb *)
Intros.
Split; Included.
Split; Included.
Elim H; Intros incF diffFn.
Elim H'; Intros incF' diffFSn.
Intros.
Cut (Diffble_I_n Hab n F); Intros; Auto.
Cut (Diffble_I_n Hab (S n) F); Intros; Auto.
EApply Derivative_I_wdl.
Apply Feq_symmetric; Apply (N_Deriv_Feq n F (incF,diffFn) ?? Hab H1 H0).
EApply Derivative_I_wdr.
Apply Feq_symmetric; Apply (N_Deriv_Feq ?? (incF',diffFSn) ?? Hab H2 H0).
Apply n_Sn_deriv.
Qed.

(* Begin_Tex_Verb *)
Lemma N_Deriv_plus :
  (m,n:nat)(F:PartIR)(H:(Diffble_n n I pI F))
  (H':(Diffble_n (plus m n) I pI F))
  (Derivative_n m I pI (N_Deriv ?? H) (N_Deriv ?? H')).
(* End_Tex_Verb *)
Intros.
Split; Included.
Split; Included.
Intros.
Cut (Diffble_I_n Hab n F); Intros.
Cut (Diffble_I_n Hab (plus m n) F); Intros.
EApply Derivative_I_n_wdl.
Apply Feq_symmetric; Apply (N_Deriv_Feq n F H ?? Hab H1 H0).
EApply Derivative_I_n_wdr.
Apply Feq_symmetric; Apply (N_Deriv_Feq ?? H' ?? Hab H2 H0).
Apply n_deriv_plus.
Elim H'; Auto.
Elim H; Auto.
Qed.

(* Tex_Prose
Some useful characterization results.
*)

(* Begin_Tex_Verb *)
Lemma Derivative_n_O : (F:?)
  (included (iprop I) (Pred F))->(Derivative_n O I pI F F).
(* End_Tex_Verb *)
Intros.
Split; Included.
Split; Included.
Intros.
Red; Apply Feq_reflexive; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_Sn : (F,n,fn,fSn:?)
  (Derivative_n n I pI F fn)->
  (Derivative_n (S n) I pI F fSn)->(Derivative I pI fn fSn).
(* End_Tex_Verb *)
Intros.
Cut (Diffble_n n I pI F); [Intro | EApply Derivative_n_imp_Diffble_n; Apply H].
Cut (Diffble_n (S n) I pI F); [Intro | EApply Derivative_n_imp_Diffble_n; Apply H0].
Apply Derivative_wdl with (N_Deriv ?? H1).
Apply Derivative_n_unique with n F.
Apply N_Deriv_lemma.
Auto.
Apply Derivative_wdr with (N_Deriv ?? H2).
Apply Derivative_n_unique with (S n) F.
Apply N_Deriv_lemma.
Auto.
Apply N_Deriv_S.
Qed.

End More_Results.

Section Derivating_Diffble.

(* Tex_Prose
As a special case we get a differentiation operator\ldots
*)

Variable F:PartIR.

(* Begin_Tex_Verb *)
Hypothesis diffF:(Diffble I pI F).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Diffble_imp_Diffble_n : (Diffble_n (1) I pI F).
(* End_Tex_Verb *)
Elim diffF; Intros incF diffbleF.
Split; Auto.
Intros; Exists (diffbleF a b Hab H).
Simpl; Included.
Qed.

(* Begin_Tex_Verb *)
Definition Deriv := (N_Deriv (1) F Diffble_imp_Diffble_n).
(* End_Tex_Verb *)

End Derivating_Diffble.

Section Corollaries.

(* Tex_Prose
\ldots for which the expected property also holds.
*)

(* Begin_Tex_Verb *)
Lemma Deriv_lemma : (F:PartIR)(diffF:?)(Derivative I pI F (Deriv F diffF)).
(* End_Tex_Verb *)
Intros; Unfold Deriv.
Apply Derivative_wdl with (N_Deriv (0) F (le_imp_Diffble_n (0) (1) (le_n_Sn (0)) F (Diffble_imp_Diffble_n ? diffF))).
Apply Derivative_n_unique with (0) F.
Apply N_Deriv_lemma.
Apply Derivative_n_O; Elim diffF; Auto.
Apply N_Deriv_S.
Qed.

(* Tex_Prose
Some more interesting properties.
*)

(* Begin_Tex_Verb *)
Lemma Derivative_n_1 : (F,G:?)(Derivative I pI F G)->
  (Derivative_n (1) I pI F G).
(* End_Tex_Verb *)
Intros.
Cut (Diffble I pI F); Intros.
Apply Derivative_n_wdr with (Deriv ? H0).
Apply Derivative_unique with pI F.
Apply Deriv_lemma.
Auto.
Unfold Deriv; Apply N_Deriv_lemma.
Apply Derivative_imp_Diffble with G; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_chain : (F,f:?)
  (Feq (iprop I) F (f O))->
  ((n:nat)(Derivative I pI (f n) (f (S n))))->
  (n:nat)(Derivative_n n I pI F (f n)).
(* End_Tex_Verb *)
Intros.
Induction n.
Apply Derivative_n_wdr with F.
Auto.
Apply Derivative_n_O.
Inversion_clear H; Inversion_clear H1; Auto.
Apply Derivative_n_plus with (1) n (f n); Auto.
Apply Derivative_n_1; Auto.
Rewrite plus_sym; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_Continuous : (n,F,G:?)(lt O n)->
  (Derivative_n n I pI F G)->(Continuous I F).
(* End_Tex_Verb *)
Intros.
Cut (Diffble I pI F); Intros.
Apply Derivative_imp_Continuous with pI (Deriv ? H1).
Apply Deriv_lemma.
Apply Diffble_n_imp_Diffble with n; Auto.
Apply Derivative_n_imp_Diffble_n with G; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Derivative_n_imp_Continuous' : (n,F,G:?)(lt O n)->
  (Derivative_n n I pI F G)->(Continuous I G).
(* End_Tex_Verb *)
Intros.
Cut (Diffble_n (pred n) I pI F); Intros.
Apply Derivative_imp_Continuous' with pI (N_Deriv ?? H1).
Apply Derivative_wdr with (N_Deriv ?? (Derivative_n_imp_Diffble_n ??? H0)).
Apply Derivative_n_unique with n F; Auto; Apply N_Deriv_lemma.
Cut n=(S (pred n)); [Intro | Apply S_pred with O; Auto].
Generalize H0.
Pattern 1 3 4 n; Rewrite H2.
Intro; Apply N_Deriv_S.
Apply le_imp_Diffble_n with n.
Auto with arith.
Apply Derivative_n_imp_Diffble_n with G; Auto.
Qed.

End Corollaries.

End Nth_Derivative.

Hints Resolve Derivative_const Derivative_id Derivative_plus Derivative_inv Derivative_minus Derivative_mult
  Derivative_scal Derivative_nth Derivative_recip Derivative_div Derivative_Sumx Derivative_Sum0 Derivative_Sum : derivate.

Hints Immediate Derivative_n_imp_inc Derivative_n_imp_inc' Diffble_n_imp_inc : included.

Hints Resolve Deriv_lemma N_Deriv_lemma : derivate.

Hints Immediate Derivative_n_imp_Continuous Derivative_n_imp_Continuous' : continuous.


Require Import Gappa_common.
Require Import Gappa_pred_bnd.

Theorem bnd_of_nzr_rel :
 forall a b : R, forall zi : FF,
 NZR b -> REL a b zi ->
 BND ((a - b) / b) zi.
Proof.
intros a b zi Hb (x,(Hr1,Hr2)).
cutrewrite ((a - b) / b = x)%R.
exact Hr1.
rewrite Hr2.
field.
exact Hb.
Qed.

Theorem rel_of_nzr_bnd :
  forall a b : R, forall zi : FF,
  NZR b -> BND ((a - b) / b) zi ->
  REL a b zi.
Proof.
intros a b zi Hb Hr.
exists ((a - b) / b)%R.
split.
exact Hr.
now field.
Qed.

Definition one_plus (xi : FF) :=
  makepairF (Fplus2 (Float2 1 0) (lower xi)) (Fplus2 (Float2 1 0) (upper xi)).

Lemma one_plus_correct :
  forall x xi,
  BND x xi ->
  BND (1 + x) (one_plus xi).
Proof.
intros x xi Hx.
apply IRplus with (xl := 1%R) (xu := 1%R) (4 := Hx) ; simpl.
rewrite Fplus2_correct.
apply Rplus_le_compat_r.
unfold float2R, Defs.F2R. simpl.
rewrite Rmult_1_l.
apply Rle_refl.
rewrite Fplus2_correct.
apply Rplus_le_compat_r.
unfold float2R, Defs.F2R. simpl.
rewrite Rmult_1_l.
apply Rle_refl.
split ; apply Rle_refl.
Qed.

Theorem bnd_of_bnd_rel_p :
  forall x y : R, forall yi ei xi : FF,
  BND y yi -> REL x y ei ->
  mul_pp_helper yi (one_plus ei) xi = true ->
  BND x xi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
rewrite He2.
apply mul_pp with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Theorem bnd_of_bnd_rel_o :
  forall x y : R, forall yi ei xi : FF,
  BND y yi -> REL x y ei ->
  mul_op_helper yi (one_plus ei) xi = true ->
  BND x xi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
rewrite He2.
apply mul_op with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Theorem bnd_of_bnd_rel_n :
  forall x y : R, forall yi ei xi : FF,
  BND y yi -> REL x y ei ->
  mul_np_helper yi (one_plus ei) xi = true ->
  BND x xi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
rewrite He2.
apply mul_np with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Lemma rel_swap :
  forall x y e ei,
  BND e ei ->
  x = (y * (1 + e))%R ->
  Fpos (lower (one_plus ei)) = true ->
  y = (x / (1 + e))%R.
Proof.
intros x y e ei He Hx Hb.
rewrite Hx.
field.
apply Rgt_not_eq.
apply Rlt_gt.
assert (H := one_plus_correct _ _ He).
destruct H as (H,_).
apply Rlt_le_trans with (2 := H).
now apply Fpos_correct.
Qed.

Theorem bnd_of_rel_bnd_p :
  forall x y : R, forall xi ei yi : FF,
  BND x xi -> REL x y ei ->
  div_pp_helper xi (one_plus ei) yi = true ->
  BND y yi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
destruct (andb_prop _ _ Hb) as (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1).
apply div_pp with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Theorem bnd_of_rel_bnd_o :
  forall x y : R, forall xi ei yi : FF,
  BND x xi -> REL x y ei ->
  div_op_helper xi (one_plus ei) yi = true ->
  BND y yi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
destruct (andb_prop _ _ Hb) as (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1).
apply div_op with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Theorem bnd_of_rel_bnd_n :
  forall x y : R, forall xi ei yi : FF,
  BND x xi -> REL x y ei ->
  div_np_helper xi (one_plus ei) yi = true ->
  BND y yi.
Proof.
intros x y yi ei xi Hy (e,(He1,He2)) Hb.
destruct (andb_prop _ _ Hb) as (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
generalize (andb_prop _ _ H1). clear H1. intros (H1,_).
rewrite rel_swap with (1 := He1) (2 := He2) (3 := H1).
apply div_np with (1 := Hy) (3 := Hb).
apply one_plus_correct with (1 := He1).
Qed.

Theorem rel_refl :
  forall a : R, forall zi : FF,
  contains_zero_helper zi = true ->
  REL a a zi.
Proof.
intros a zi Hb.
exists R0.
split.
now apply contains_zero.
ring.
Qed.

Lemma error_of_rel_generic :
 forall f,
 forall t: (forall x y : R, forall xi yi zi : FF,
            BND x xi -> BND y yi -> f xi yi zi = true ->
            BND (x * y) zi),
 forall a b : R, forall xi yi zi : FF,
 REL a b xi -> BND b yi ->
 f xi yi zi = true ->
 BND (a - b) zi.
Proof.
intros f t a b xi yi zi (x,(Hr1,Hr2)).
cutrewrite (a - b = x * b)%R.
now apply t.
rewrite Hr2.
ring.
Qed.

Definition error_of_rel_pp := error_of_rel_generic mul_pp_helper mul_pp.
Definition error_of_rel_po := error_of_rel_generic mul_po_helper mul_po.
Definition error_of_rel_pn := error_of_rel_generic mul_pn_helper mul_pn.
Definition error_of_rel_op := error_of_rel_generic mul_op_helper mul_op.
Definition error_of_rel_oo := error_of_rel_generic mul_oo_helper mul_oo.
Definition error_of_rel_on := error_of_rel_generic mul_on_helper mul_on.
Definition error_of_rel_np := error_of_rel_generic mul_np_helper mul_np.
Definition error_of_rel_no := error_of_rel_generic mul_no_helper mul_no.
Definition error_of_rel_nn := error_of_rel_generic mul_nn_helper mul_nn.

Definition rel_subset_helper (xi zi : FF) :=
 Fle2 (lower zi) (lower xi) &&
 Fle2 (upper xi) (upper zi).

Theorem rel_subset :
  forall x xr : R, forall xi zi : FF,
  REL x xr xi ->
  rel_subset_helper xi zi = true ->
  REL x xr zi.
Proof.
intros x xr xi zi (xe,(Hx1,Hx2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Fle2_correct in H1.
apply Fle2_correct in H2.
exists xe.
split.
apply IRsubset with (1 := H1) (2 := H2) (3 := Hx1).
exact Hx2.
Qed.

Definition intersect_rr_helper (xf yf : float2) (zi : FF) :=
  Fle2 (lower zi) (upper zi) &&
  Fle2 (lower zi) yf &&
  Fle2 xf (upper zi).

Theorem intersect_rr :
  forall z1 z2 : R, forall xi yi zi : FF,
  REL z1 z2 xi -> REL z1 z2 yi ->
  intersect_rr_helper (upper xi) (lower yi) zi = true ->
  REL z1 z2 zi.
Proof.
intros z1 z2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Fle2_correct in H1.
apply Fle2_correct in H2.
apply Fle2_correct in H3.
case (Req_dec z2 0) ; intro.
exists (float2R (lower zi)).
split.
split.
apply Rle_refl.
exact H1.
rewrite Hx2.
rewrite H.
repeat rewrite Rmult_0_l.
apply refl_equal.
exists xe.
split.
split.
apply Rle_trans with (1 := H2).
replace xe with ye.
apply Hy1.
apply Rplus_eq_reg_l with 1%R.
apply Rmult_eq_reg_l with (2 := H).
now rewrite <- Hy2.
now apply Rle_trans with (2 := H3).
exact Hx2.
Qed.

Definition intersect_rr0_helper (xf yf : float2) (zi : FF) :=
  Flt2 xf yf &&
  Fneg0 (lower zi) &&
  Fpos0 (upper zi).

Theorem intersect_rr0 :
  forall z1 z2 : R, forall xi yi zi : FF,
  REL z1 z2 xi -> REL z1 z2 yi ->
  intersect_rr0_helper (upper xi) (lower yi) zi = true ->
  BND z2 zi.
Proof.
intros z1 z2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Flt2_correct in H1.
apply Fneg0_correct in H2.
apply Fpos0_correct in H3.
destruct (Req_dec z2 0) as [Hz|Hz].
rewrite Hz.
now split.
elim (Rle_not_lt xe ye).
apply Req_le.
apply Rplus_eq_reg_l with 1%R.
apply Rmult_eq_reg_l with (2 := Hz).
now rewrite <- Hy2.
apply Rle_lt_trans with (1 := proj2 Hx1).
apply Rlt_le_trans with (2 := proj1 Hy1).
exact H1.
Qed.

Theorem absurd_intersect_rr :
  forall z1 z2 : R, forall xi yi : FF,
  REL z1 z2 xi -> REL z1 z2 yi -> NZR z2 ->
  Flt2 (upper xi) (lower yi) = true ->
  False.
Proof.
intros z1 z2 xi yi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hz Hb.
generalize (Flt2_correct _ _ Hb). clear Hb. intro H.
generalize (Rle_lt_trans _ _ _ (proj2 Hx1) H). clear H. intro H.
replace xe with ye in H.
generalize (Rlt_le_trans _ _ _ H (proj1 Hy1)). clear H. intro H.
elim (Rlt_irrefl _ H).
clear H.
apply sym_eq.
apply Rplus_eq_reg_l with 1%R.
apply Rmult_eq_reg_l with (2 := Hz).
now rewrite <- Hx2.
Qed.

Definition mul_rr_helper (xi yi zi : FF) :=
  Fle2_m1 (lower xi) &&
  Fle2_m1 (lower yi) &&
  Fle2 (lower zi) (Fplus2 (Fplus2 (lower xi) (lower yi))
                          (Fmult2 (lower xi) (lower yi))) &&
  Fle2 (Fplus2 (Fplus2 (upper xi) (upper yi))
               (Fmult2 (upper xi) (upper yi))) (upper zi).

Theorem mul_rr :
  forall x1 x2 y1 y2 : R, forall xi yi zi : FF,
  REL x1 x2 xi -> REL y1 y2 yi ->
  mul_rr_helper xi yi zi = true ->
  REL (x1 * y1) (x2 * y2) zi.
Proof.
intros x1 x2 y1 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Fle2_m1_correct in H1.
apply Fle2_m1_correct in H2.
generalize (Fle2_correct _ _ H3).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H3. intro H3.
generalize (Fle2_correct _ _ H4).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H4. intro H4.
exists (xe + ye + xe * ye)%R.
split.
apply IRcompose with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx1) (6 := Hy1).
rewrite Hx2.
rewrite Hy2.
ring.
Qed.

Definition div_rr_helper (xi yi zi : FF) :=
  Fle2_m1 (lower xi) &&
  Flt2_m1 (lower yi) &&
  Fle2 (upper xi) (Fplus2 (Fplus2 (lower yi) (upper zi))
                          (Fmult2 (lower yi) (upper zi))) &&
  Fle2 (Fplus2 (Fplus2 (upper yi) (lower zi))
               (Fmult2 (upper yi) (lower zi))) (lower xi).

Theorem div_rr :
  forall x1 x2 y1 y2 : R, forall xi yi zi : FF,
  REL x1 x2 xi -> REL y1 y2 yi -> NZR y2 ->
  div_rr_helper xi yi zi = true ->
  REL (x1 / y1) (x2 / y2) zi.
Proof.
intros x1 x2 y1 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hy4 Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Fle2_m1_correct in H1.
apply Flt2_m1_correct in H2.
generalize (Fle2_correct _ _ H3).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H3. intro H3.
generalize (Fle2_correct _ _ H4).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H4. intro H4.
exists ((xe - ye) / (1 + ye))%R.
split.
apply IRcompose_inv with (1 := H1) (2 := H2) (3 := H4) (4 := H3) (5 := Hx1) (6 := Hy1).
rewrite Hx2.
rewrite Hy2.
field.
split.
apply Rgt_not_eq.
apply Rlt_le_trans with (2 := Rplus_le_compat_l R1 _ _ (proj1 Hy1)).
rewrite <- (Rplus_opp_r 1).
apply Rplus_lt_compat_l with (1 := H2).
exact Hy4.
Qed.

Definition inv_r_helper (xi zi : FF) :=
  Flt2_m1 (lower xi) &&
  Fpos0 (Fplus2 (Fplus2 (lower xi) (upper zi)) (Fmult2 (lower xi) (upper zi))) &&
  Fneg0 (Fplus2 (Fplus2 (upper xi) (lower zi)) (Fmult2 (upper xi) (lower zi))).

Theorem inv_r :
  forall x1 x2 y : R, forall xi zi : FF,
  REL x1 x2 xi -> NZR x2 ->
  inv_r_helper xi zi = true ->
  REL (y / x1) (y / x2) zi.
Proof.
intros x1 x2 y xi zi (xe,(Hx1,Hx2)) Hx3 Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Flt2_m1_correct in H1.
generalize (Fpos0_correct _ H2).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H2. intro H2.
generalize (Fneg0_correct _ H3).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H3. intro H3.
exists ((0 - xe) / (1 + xe))%R.
split.
apply IRcompose_inv with (xl := R0) (xu := R0) (2 := H1) (3 := H3) (4 := H2) (6 := Hx1).
apply Rge_le, Ropp_0_le_ge_contravar, Rle_0_1.
split ; apply Rle_refl.
rewrite Hx2.
field.
split.
apply Rgt_not_eq.
apply Rlt_le_trans with (2 := Rplus_le_compat_l R1 _ _ (proj1 Hx1)).
rewrite <- (Rplus_opp_r 1).
apply Rplus_lt_compat_l with (1 := H1).
exact Hx3.
Qed.

Theorem compose :
  forall x1 x2 y2 : R, forall xi yi zi : FF,
  REL x1 x2 xi -> REL x2 y2 yi ->
  mul_rr_helper xi yi zi = true ->
  REL x1 y2 zi.
Proof.
intros x1 x2 y2 xi yi zi (xe,(Hx1,Hx2)) (ye,(Hy1,Hy2)) Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb,H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1,H2).
apply Fle2_m1_correct in H1.
apply Fle2_m1_correct in H2.
generalize (Fle2_correct _ _ H3).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H3. intro H3.
generalize (Fle2_correct _ _ H4).
repeat rewrite Fplus2_correct.
rewrite Fmult2_correct. clear H4. intro H4.
exists (xe + ye + xe * ye)%R.
split.
apply IRcompose with (1 := H1) (2 := H2) (3 := H3) (4 := H4) (5 := Hx1) (6 := Hy1).
rewrite Hx2.
rewrite Hy2.
ring.
Qed.

Theorem compose_swap :
  forall x y r1 r2 : R, forall xi yi zi : FF,
  REL x (y * r2) xi -> REL r1 (1 / r2) yi -> NZR r2 ->
  mul_rr_helper xi yi zi = true ->
  REL (x * r1) y zi.
Proof.
intros x y r1 r2 xi yi zi Hx Hy Hr Hb.
generalize (mul_rr _ _ _ _ _ _ _ Hx Hy Hb).
replace (y * r2 * (1 / r2))%R with y.
easy.
now field.
Qed.

Definition FImult2 (x : float2) (yi : FF) :=
  let (yl,yu) := yi in
  if Fpos0 x then makepairF (Fmult2 x yl) (Fmult2 x yu)
  else makepairF (Fmult2 x yu) (Fmult2 x yl).

Lemma FImult2_correct :
  forall (x : float2) yi y, BND y yi ->
  BND (x * y) (FImult2 x yi).
Proof.
intros x (yl,yu) y Hy.
unfold FImult2.
replace (Fpos0 x) with (Zle_bool 0 (Fnum x)) by now unfold Fpos0 ; case (Fnum x).
case Zle_bool_spec ; split ; simpl ; rewrite Fmult2_correct.
apply monotony_1p.
now apply Float_prop.F2R_ge_0.
apply Hy.
apply monotony_1p.
now apply Float_prop.F2R_ge_0.
apply Hy.
apply monotony_1n.
apply Float_prop.F2R_le_0.
now apply Zlt_le_weak.
apply Hy.
apply monotony_1n.
apply Float_prop.F2R_le_0.
now apply Zlt_le_weak.
apply Hy.
Qed.

Definition add_rr_helper (xi yi qi zi : FF) :=
  let xql := FImult2 (lower qi) xi in
  let xqu := FImult2 (upper qi) xi in
  let yql := FImult2 (Fminus2 (Float2 1 0) (lower qi)) yi in
  let yqu := FImult2 (Fminus2 (Float2 1 0) (upper qi)) yi in
  Fle2 (lower zi) (Fplus2 (lower xql) (lower yql)) &&
  Fle2 (lower zi) (Fplus2 (lower xqu) (lower yqu)) &&
  Fle2 (Fplus2 (upper xql) (upper yql)) (upper zi) &&
  Fle2 (Fplus2 (upper xqu) (upper yqu)) (upper zi).

Theorem add_rr :
  forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF,
  REL x1 x2 xi -> REL y1 y2 yi -> BND (x2 / (x2 + y2)) qi -> NZR (x2 + y2) ->
  add_rr_helper xi yi qi zi = true ->
  REL (x1 + y1) (x2 + y2) zi.
Proof.
intros x1 x2 y1 y2 xi yi qi zi (ex,(Hx1,Hx2)) (ey,(Hy1,Hy2)) Hq Zxy Hb.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1, H2).
apply Fle2_correct in H1. rewrite Fplus2_correct in H1.
apply Fle2_correct in H2. rewrite Fplus2_correct in H2.
apply Fle2_correct in H3. rewrite Fplus2_correct in H3.
apply Fle2_correct in H4. rewrite Fplus2_correct in H4.
assert (H5 := FImult2_correct (lower qi) xi _ Hx1).
assert (H6 := FImult2_correct (upper qi) xi _ Hx1).
assert (H7 := FImult2_correct (Fminus2 (Float2 1 0) (lower qi)) yi _ Hy1).
assert (H8 := FImult2_correct (Fminus2 (Float2 1 0) (upper qi)) yi _ Hy1).
assert (H9 : float2R (Float2 1 0) = R1) by apply Rmult_1_r.
assert (Ha : (float2R (Fminus2 (Float2 1 0) (lower qi)) = 1 - lower qi)%R).
now rewrite Fminus2_correct, H9.
assert (Hb : (float2R (Fminus2 (Float2 1 0) (upper qi)) = 1 - upper qi)%R).
now rewrite Fminus2_correct, H9.
exists ((x1 + y1) / (x2 + y2) - 1)%R.
split.
2: now field.
rewrite Hx2, Hy2.
replace ((x2 * (1 + ex) + y2 * (1 + ey)) / (x2 + y2) - 1)%R with
  (ey + x2 / (x2 + y2) * (ex - ey))%R by now field.
unfold BND in Hq.
destruct (Rle_or_lt (ex - ey) 0) as [He|He].
split.
apply Rle_trans with (ey + upper qi * (ex - ey))%R.
replace (ey + upper qi * (ex - ey))%R with (upper qi * ex + (1 - upper qi) * ey)%R by ring.
apply Rle_trans with (1 := H2).
apply Rplus_le_compat.
apply H6.
rewrite <- Hb.
apply H8.
apply Rplus_le_compat_l.
now apply monotony_2n.
apply Rle_trans with (ey + lower qi * (ex - ey))%R.
apply Rplus_le_compat_l.
now apply monotony_2n.
replace (ey + lower qi * (ex - ey))%R with (lower qi * ex + (1 - lower qi) * ey)%R by ring.
apply Rle_trans with (2 := H3).
apply Rplus_le_compat.
apply H5.
rewrite <- Ha.
apply H7.
apply Rlt_le in He.
split.
apply Rle_trans with (ey + lower qi * (ex - ey))%R.
replace (ey + lower qi * (ex - ey))%R with (lower qi * ex + (1 - lower qi) * ey)%R by ring.
apply Rle_trans with (1 := H1).
apply Rplus_le_compat.
apply H5.
rewrite <- Ha.
apply H7.
apply Rplus_le_compat_l.
now apply monotony_2p.
apply Rle_trans with (ey + upper qi * (ex - ey))%R.
apply Rplus_le_compat_l.
now apply monotony_2p.
replace (ey + upper qi * (ex - ey))%R with (upper qi * ex + (1 - upper qi) * ey)%R by ring.
apply Rle_trans with (2 := H4).
apply Rplus_le_compat.
apply H6.
rewrite <- Hb.
apply H8.
Qed.

Theorem sub_rr :
  forall x1 x2 y1 y2 : R, forall xi yi qi zi : FF,
  REL x1 x2 xi -> REL y1 y2 yi -> BND (x2 / (x2 - y2)) qi -> NZR (x2 - y2) ->
  add_rr_helper xi yi qi zi = true ->
  REL (x1 - y1) (x2 - y2) zi.
Proof.
intros x1 x2 y1 y2 xi yi qi zi Hx (ey,(Hy1,Hy2)) Hq Zxy Hb.
apply add_rr with (1 := Hx) (3 := Hq) (4 := Zxy) (5 := Hb).
exists ey.
split.
exact Hy1.
rewrite Hy2.
ring.
Qed.

Definition mul_helper (xi yi zi : FF) :=
  let xly := FImult2 (lower xi) yi in
  let xuy := FImult2 (upper xi) yi in
  Fle2 (lower zi) (lower xly) &&
  Fle2 (lower zi) (lower xuy) &&
  Fle2 (upper xly) (upper zi) &&
  Fle2 (upper xuy) (upper zi).

Theorem bnd_div_of_rel_bnd_div :
  forall x1 x2 y : R, forall xi yi zi : FF,
  REL x1 x2 xi -> BND (x2 / y) yi -> NZR y ->
  mul_helper xi yi zi = true ->
  BND ((x1 - x2) / y) zi.
Proof.
intros x1 x2 y xi yi zi (ex,(Hx1,Hx2)) Hxy Zy Hb.
rewrite Hx2.
replace ((x2 * (1 + ex) - x2) / y)%R with (ex * (x2 / y))%R by now field.
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H4).
generalize (andb_prop _ _ Hb). clear Hb. intros (Hb, H3).
generalize (andb_prop _ _ Hb). clear Hb. intros (H1, H2).
apply Fle2_correct in H1.
apply Fle2_correct in H2.
apply Fle2_correct in H3.
apply Fle2_correct in H4.
assert (H5 := FImult2_correct (lower xi) yi _ Hxy).
assert (H6 := FImult2_correct (upper xi) yi _ Hxy).
destruct (Rle_or_lt 0 (x2 / y)) as [Hy|Hy].
split.
apply Rle_trans with (1 := H1).
apply Rle_trans with (1 := proj1 H5).
now apply monotony_2p.
apply Rle_trans with (2 := H4).
apply Rle_trans with (2 := proj2 H6).
now apply monotony_2p.
apply Rlt_le in Hy.
split.
apply Rle_trans with (1 := H2).
apply Rle_trans with (1 := proj1 H6).
now apply monotony_2n.
apply Rle_trans with (2 := H3).
apply Rle_trans with (2 := proj2 H5).
now apply monotony_2n.
Qed.


Require Import Lists.List Lists.ListSet Vector Arith.PeanoNat AbstractRelation Tribool Common.

Module Type RC.
  Import Db.

  Inductive tm :=
  | cst     : BaseConst -> tm
  | null    : tm
  | pred    : forall n, (forall l : list BaseConst, length l = n -> bool) -> list tm -> tm
  | var     : nat -> tm
  | mktup   : list (Name * tm) -> tm
  | proj    : tm -> Name -> tm
  | tab     : Name -> tm
  | nil     : bool -> Scm -> tm      (* is set, schema *)
  | single  : bool -> tm -> tm       (* is_set *)
  | union   : tm -> tm -> tm
  | inters  : tm -> tm -> tm
  | diff    : tm -> tm -> tm
  | comprn  : tm -> tm -> tm
  | cwhere  : tm -> tm -> tm
  | dist    : tm -> tm
  | prom    : tm -> tm
  | empty   : bool -> tm -> tm

  | rctrue  : tm
  | rcfalse : tm
  | isnull  : tm -> tm
  | istrue  : tm -> tm
  | rcand   : tm -> tm -> tm
  | rcor    : tm -> tm -> tm
  | rcnot   : tm -> tm
  .

  Inductive j_var (a : Name) : Scm -> Prop :=
  | j_varhd   : forall s, ~ List.In a s -> j_var a (a::s)
  | j_varcons : forall b s, a <> b -> j_var a s -> j_var a (b::s).

  Inductive j_base (d : Db.D) : list Scm -> tm -> Prop :=
  | j_cst  : forall g c, j_base d g (cst c)
  | j_null : forall g, j_base d g null
  | j_proj : forall g t x s, j_tuple d g t s -> j_var x s -> j_base d g (proj t x)

  with j_tuple (d : Db.D) : list Scm -> tm -> Scm -> Prop :=
  | j_tmvar : forall g n s, List.nth_error g n = Some s -> j_tuple d g (var n) s
  | j_mktup : forall g bl,
      List.NoDup (List.map fst bl) ->
      (forall t, List.In t (List.map snd bl) -> j_base d g t)
      -> j_tuple d g (mktup bl) (List.map fst bl).

  Inductive j_cond (d : Db.D) : list Scm -> tm -> Prop :=
  | j_empty : forall g q b s, j_coll d g q b s -> j_cond d g (empty b q)
  | j_pred : forall g n p tl,
      (forall t, List.In t tl -> j_base d g t) -> length tl = n
      -> j_cond d g (pred n p tl)
  | j_true : forall g, j_cond d g rctrue
  | j_false : forall g, j_cond d g rcfalse
  | j_isnull : forall g t, j_base d g t -> j_cond d g (isnull t)
  | j_istrue : forall g c, j_cond d g c -> j_cond d g (istrue c)
  | j_and : forall g c1 c2, j_cond d g c1 -> j_cond d g c2 -> j_cond d g (rcand c1 c2)
  | j_or : forall g c1 c2, j_cond d g c1 -> j_cond d g c2 -> j_cond d g (rcor c1 c2)
  | j_not : forall g c, j_cond d g c -> j_cond d g (rcnot c)

  with j_coll (d : Db.D) : list Scm -> tm -> bool -> Scm -> Prop :=
  | j_tab : forall g x s, Db.db_schema d x = Some s -> j_coll d g (tab x) false s
  | j_nil : forall g b s, List.NoDup s -> j_coll d g (nil b s) b s
  | j_single : forall g b t s, j_tuple d g t s -> j_coll d g (single b t) b s
  | j_union : forall g q1 q2 b s, j_coll d g q1 b s -> j_coll d g q2 b s -> j_coll d g (union q1 q2) b s
  | j_inters : forall g q1 q2 b s , j_coll d g q1 b s -> j_coll d g q2 b s -> j_coll d g (inters q1 q2) b s
  | j_diff : forall g q1 q2 b s, j_coll d g q1 b s -> j_coll d g q2 b s -> j_coll d g (diff q1 q2) b s
  | j_comprn : forall g q1 q2 b s1 s2, j_coll d g q2 b s2 -> j_coll d (s2::g) q1 b s1 -> j_coll d g (comprn q1 q2) b s1
  | j_cwhere : forall g q s c b, j_coll d g q b s -> j_cond d g c -> j_coll d g (cwhere q c) b s
  | j_dist : forall g q s, j_coll d g q false s -> j_coll d g (dist q) true s
  | j_prom : forall g q s, j_coll d g q true s -> j_coll d g (prom q) false s.

  Fixpoint bigunion (b : bool) (s : Scm) (ql : list tm) : tm :=
    match ql with
    | List.nil => nil b s
    | q0::ql0 => union q0 (bigunion b s ql0)
    end.

  Fixpoint multi_comprn q ql : tm :=
    match ql with
    | List.nil => q
    | q0::ql0 => multi_comprn (comprn q q0) ql0
    end.

  Definition not_union t :=
    match t with
    | union _ _ => false
    | _ => true
    end.

  (* normal forms *)
  Inductive j_nbase (d : Db.D) : list Scm -> tm -> Prop :=
  | j_ncst  : forall g c, j_nbase d g (cst c)
  | j_nnull  : forall g, j_nbase d g null
  | j_nproj : forall g n x s, List.nth_error g n = Some s -> j_var x s -> j_nbase d g (proj (var n) x).

  Definition j_nbasel d g tl := forall t, List.In t tl -> j_nbase d g t.

  Inductive j_ntuple (d : Db.D) : list Scm -> tm -> Scm -> Prop :=
  | j_nmktup : forall g bl,
      List.NoDup (List.map fst bl) -> j_nbasel d g (List.map snd bl)
      -> j_ntuple d g (mktup bl) (List.map fst bl).

  Inductive j_ncond (d : Db.D) : list Scm -> tm -> Prop :=
  | j_nempty : forall g q b s, j_ncoll d g q b s -> j_ncond d g (empty b q)
  | j_npred : forall g n p tl,
      j_nbasel d g tl -> length tl = n
      -> j_ncond d g (pred n p tl)
  | j_ntrue : forall g, j_ncond d g rctrue
  | j_nfalse : forall g, j_ncond d g rcfalse
  | j_nisnull : forall g t, j_nbase d g t -> j_ncond d g (isnull t)
  | j_nistrue : forall g c, j_ncond d g c -> j_ncond d g (istrue c)
  | j_nand : forall g c1 c2, j_ncond d g c1 -> j_ncond d g c2 -> j_ncond d g (rcand c1 c2)
  | j_nor : forall g c1 c2, j_ncond d g c1 -> j_ncond d g c2 -> j_ncond d g (rcor c1 c2)
  | j_nnot : forall g c, j_ncond d g c -> j_ncond d g (rcnot c)

  with j_ncoll (d : Db.D) : list Scm -> tm -> bool -> Scm -> Prop :=
  | j_ncnil : forall g b s, List.NoDup s -> j_ncoll d g (nil b s) b s
  | j_ncdisjunct : forall g t b s, not_union t = true -> j_ndisjunct d g t b s -> j_ncoll d g t b s
  | j_ncunion : forall g t1 t2 b s,
      j_ndisjunct d g t1 b s ->
      j_ncoll d g t2 b s
      -> j_ncoll d g (union t1 t2) b s

  with j_ndisjunct (d : Db.D) : list Scm -> tm -> bool -> Scm -> Prop :=
  | j_nsingle : forall g b tup c,
      forall s, j_ntuple d g tup s -> j_ncond d g c
      -> j_ndisjunct d g (cwhere (single b tup) c) b s
  | j_ncomprn : forall g q1 q2,
      forall b s s2, j_ngen d g q2 b s2 -> j_ndisjunct d (s2::g) q1 b s
      -> j_ndisjunct d g (comprn q1 q2) b s

  with j_ngen (d : Db.D) : list Scm -> tm -> bool -> Scm -> Prop :=
  | j_ntab : forall g x s, Db.db_schema d x = Some s -> j_ngen d g (tab x) false s
  | j_nprom : forall g q s, j_ncoll d g q true s -> j_ngen d g (prom q) false s
  | j_nbagdiff : forall g q1 q2 s,
      j_ncoll d g q1 false s -> j_ncoll d g q2 false s
      -> j_ngen d g (diff q1 q2) false s
  | j_ndtab : forall g x s, Db.db_schema d x = Some s -> j_ngen d g (dist (tab x)) true s
  | j_nddiff : forall g q1 q2 s,
      j_ncoll d g q1 false s -> j_ncoll d g q2 false s
      -> j_ngen d g (dist (diff q1 q2)) true s
  .

  Scheme jnw_ind_mut := Induction for j_ncond      Sort Prop
  with jnc_ind_mut   := Induction for j_ncoll      Sort Prop
  with jnd_ind_mut   := Induction for j_ndisjunct  Sort Prop
  with jng_ind_mut   := Induction for j_ngen       Sort Prop.

  Combined Scheme j_norm_ind_mut from jnw_ind_mut, jnc_ind_mut, jnd_ind_mut, jng_ind_mut.

End RC.


Require Export pcf_subpo.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section PCFPO_representation.

(** a lot of notation to make things readable *)

Notation "'TY'" := PCF.TY.

Notation "'IP'" := (IO TY).
Notation "a '~>' b" := (PCF.arrow a b) (at level 69, right associativity).
(* Notation "a ~> b" := (Module_Hom a b) (at level 50).*)
(*Notation "a 'x' b" := (Prod_Mod _ a b) (at level 30).*)

Notation "a 'x' b" := (product (*C:= MOD _ _*) a b) (at level 30).

(* Notation "P ^ z" := (FIB_MOD _ z P). *)
Notation "P [ z ]" := (FIB_MOD _ z P) (at level 35).

(*Notation "P ''' s" := (DER_MOD _ _ s P ) (at level 25).*)
Notation "'d' P // s" := (DER_MOD _ _ s P) (at level 25).
(*Notation " '*' " := (Term (*C:=MOD _ _*)).*)
Notation "'*'" := (Term (C:=MOD _ SO)).
Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.

Notation "f 'X' g" := (product_mor (*C:= MOD _ _ *) _ f g)(at level 30).

Notation "'FM'" := (#(FIB_MOD _ _ )).
Notation "'FPB'":= (FIB_PB _ _ _ ).
Notation "'PRPB'":= (PROD_PB _ _ _ _ ).
Notation "'PBF'":= (PB_FIB _ _ _ ).
Notation "'PBM'":= (#(PB_MOD _ _ )).
Notation "'DM'":= (#(DER_MOD _ _ _ )).
Notation "'DPB'":= (DER_PB _ _ _ ).
Notation "y [* := z ]":= (IOsubstar z  y)(at level 55).
(** a monad is a representation if it is accompagnied by
    - a lot of morphisms of modules
    - beta-reduction
*)

Class PCFPO_rep_struct (P : Monad IP) := {
  App : forall r s, (P[r~>s]) x (P[r]) ---> P[s];
  Abs : forall r s, (d P // r)[s] ---> P[r ~> s];
  Rec : forall t, P[t ~> t] ---> P[t];
  ttt :  * ---> P[Bool];
  fff :  * ---> P[Bool];
  nats: forall m:nat, * ---> P[Nat];
  succ: * ---> P[Nat ~> Nat];
  zero : * ---> P[Nat ~> Bool];
  condN: * ---> P[Bool ~> Nat ~> Nat ~> Nat];
  condB: * ---> P[Bool ~> Bool ~> Bool ~> Bool];
  Bottom: forall t, * ---> P[t];

  beta: forall r s V y z,
        App r s V (Abs r s V y, z) <<  (*IPsubstar z _ y*) y[*:= z] ;

  propag_App1: forall r s V y y' z,
        y << y' -> App r s V (y,z) << App _ _ _ (y',z) ;

  propag_App2: forall r s V y z z',
        z << z' -> App r s V (y,z) << App _ _ _ (y,z') ;

  propag_Abs: forall r s V y y',
        y << y' -> Abs r s V y << Abs _ _ _ y' ;

  propag_Rec: forall s V y y',
        y << y' -> Rec s V y << Rec _ _ y'

(*
  these two are not necessary, since we are over PO

  beta_refl : forall r V (y : P V r), y << y ;

  beta_trans : forall r V (a b c : P V r),
          a << b -> b << c -> a << c
*)
}.

Record PCFPO_rep := {
  pcfpo_rep_monad :> Monad IP;
  pcfpo_rep_struct :> PCFPO_rep_struct pcfpo_rep_monad
}.

Existing Instance pcfpo_rep_struct.

(** morphisms of representations *)

Section PCFPO_rep_Hom.

Variables P R : PCFPO_rep.

Section Rep_Hom_Class.

Variable Sig : Monad_Hom P R.

Notation "'sig'":= (PbMod_ind_Hom Sig).

(** for the constants we need a special morphism of modules

    [* ---> (\Sigma * ) *]

    being the empty product  *)

Lemma id_Term_PB_struct:
   Module_Hom_struct (S:= Term (C:= MOD _ SO))  (T:=(PB_MOD Sig SO Term))
                 (fun r => id SO_TERM).
Proof.
  constructor.
  intros.
  rewrite idl.
  rewrite idr.
  apply hom_refl.
Qed.

Definition PBT : Term ---> (PB_MOD Sig SO Term) :=
      Build_Module_Hom id_Term_PB_struct.

(*
Notation "'FM'" := (!(FIB_MOD _ _ )).
Notation "'FPB'":= (FIB_PB _ _ _ ).
Notation "'PRPB'":= (PROD_PB _ _ _ _ ).
Notation "'PBF'":= (PB_FIB _ _ _ ).
Notation "'sig'":= (PbMod_ind_Hom Sig).
Notation "'PBM'":= (!(PB_MOD _ _ )).
Notation "'DM'":= (!(DER_MOD _ _ _ )).
Notation "'DPB'":= (DER_PB _ _ _ ).
*)

(** Sig : P -> R is a morphism of representations if it makes commute
    all these weird diagrams
*)

Class PCFPO_rep_Hom_struct := {
  App_Hom: forall r s,
        App r s ;; FM sig  ==
          (FM sig ;; FPB) X (FM sig ;; FPB);;
                   PRPB ;; PBM (App r s) ;; PBF        ;

  Abs_Hom: forall r s,
         Abs r s ;; FM sig ==
          FM (DM sig ;; DPB) ;; FPB ;; PBM (Abs r s) ;; PBF  ;

  Rec_Hom: forall t,
         Rec t ;; FM sig ==
            FM sig ;; FPB ;; PBM (Rec t) ;; PBF ;

  ttt_Hom: ttt ;; FM sig ==
          PBT ;; PBM ttt ;; PBF ;

  fff_Hom: fff ;; FM sig ==
          PBT ;; PBM fff ;; PBF ;

  nats_Hom : forall m,
         nats m ;; FM sig ==
            PBT ;; PBM (nats m) ;; PBF ;

  succ_Hom: succ ;; FM sig ==
          PBT ;; PBM succ ;; PBF  ;

  zero_Hom: zero ;; FM sig ==
          PBT ;; PBM zero ;; PBF  ;

  condN_Hom: condN ;; FM sig ==
          PBT ;; PBM condN ;; PBF  ;

  condB_Hom: condB ;; FM sig ==
          PBT ;; PBM condB ;; PBF ;

  Bottom_Hom: forall t,
          Bottom t ;; FM sig ==
          PBT ;; PBM (Bottom t) ;; PBF

}.

End Rep_Hom_Class.

(** the type of morphismes of representations P -> R *)

Record PCFPO_rep_Hom := {
  rep_Hom_monad :> Monad_Hom P R ;
  rep_Hom_monad_struct :> PCFPO_rep_Hom_struct rep_Hom_monad
}.

End PCFPO_rep_Hom.
(*Existing Instance MONAD_struct.*)
Existing Instance rep_Hom_monad_struct.

(** on our way to a category of representations:
    - an equality on morphisms of reps*)

(** two morphisms are equal if their monad homs are equal,
     proof of "equivalence relation" is more or less already done in
           Monad_Hom_equiv *)

(*
Definition eq_Rep (P R: PCFPO_rep) : relation (PCFPO_rep_Hom P R) :=
       fun a c => rep_Hom_monad a == rep_Hom_monad c.
*)

Lemma eq_Rep_equiv (P R: PCFPO_rep) :
     Equivalence (A:=PCFPO_rep_Hom P R)
         (fun a c => rep_Hom_monad a == rep_Hom_monad c).
Proof.
 intros P R.
 set (H:= Monad_Hom_equiv P R).
 destruct H as [Hr Hs Ht].
 constructor;
 simpl in *.
 unfold Reflexive; intros. apply Hr.
 unfold Symmetric; intros r s; apply Hs.
 unfold Transitive; intros r s t; apply Ht.
Qed.

Definition eq_Rep_oid (P R : PCFPO_rep) := Build_Setoid (eq_Rep_equiv P R).

(** Identity Representation *)

Lemma Rep_id_struct (P : PCFPO_rep) :
         PCFPO_rep_Hom_struct (Monad_Hom_id P).
Proof.
  intro P;
  unfold Monad_Hom_id.
  simpl.
  constructor;
  simpl;
  intros;
  try rewrite <- surjective_pairing;
  auto.
Qed.

Definition Rep_id (P: PCFPO_rep) := Build_PCFPO_rep_Hom (Rep_id_struct P).

(** Composition of Representations *)
Section Rep_comp.
Variables P Q R: PCFPO_rep.
Variable M: PCFPO_rep_Hom P Q.
Variable N: PCFPO_rep_Hom Q R.

Program Instance Rep_comp_struct :
      PCFPO_rep_Hom_struct (Monad_Hom_comp M N).
Next Obligation.
Proof.
  set (HM:=App_Hom (Sig := M)).
  set (HN:=App_Hom (Sig := N)).
  simpl in *.
  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Abs_Hom (Sig := M)).
  set (HN:=Abs_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Rec_Hom (Sig := M)).
  set (HN:=Rec_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=ttt_Hom (Sig := M)).
  set (HN:=ttt_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=fff_Hom (Sig := M)).
  set (HN:=fff_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=nats_Hom (Sig := M)).
  set (HN:=nats_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=succ_Hom (Sig := M)).
  set (HN:=succ_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=zero_Hom (Sig := M)).
  set (HN:=zero_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=condN_Hom (Sig := M)).
  set (HN:=condN_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=condB_Hom (Sig := M)).
  set (HN:=condB_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.
Next Obligation.
  set (HM:=Bottom_Hom (Sig := M)).
  set (HN:=Bottom_Hom (Sig := N)).
  simpl in *.

  rewrite HM.
  rewrite HN.
  auto.
Qed.

Definition Rep_comp := Build_PCFPO_rep_Hom Rep_comp_struct.

End Rep_comp.

(** category of representations *)

Program Instance PCFPO_REP_struct : Cat (fun a c => PCFPO_rep_Hom a c) := {
  mor_oid a c := eq_Rep_oid a c;
  id a := Rep_id a;
  comp P Q R f g := Rep_comp f g
}.
Next Obligation.
Proof.
  unfold Proper in *; do 2 red.
  simpl.
  intros y z h y' z' h' e r t.
  rewrite h.
  rewrite h'.
  auto.
Qed.

Definition PCFPO_REP := Build_Category PCFPO_REP_struct.

End PCFPO_representation.

Existing Instance pcfpo_rep_struct.


Add LoadPath "../../ml_proof".

Require Import ZArith.
Require Import List.
Require Import FMapPositive.

Require Import generic.
Require Import matchinglreduction.
Require Import matchinglproofsystem.
Require Import matchinglpartialcorrectness.

Require Import domains.
Require Import model.

Import ImpLang.
Module Import ImpReduction := MatchLReduction ImpLang.
Module Import ImpProof := MatchLProofSystem ImpLang.
Module Import ImpCorrectness := MatchLPartialCorrectness ImpLang.

Import Base BaseF BaseM BaseS.

Import TermAbbrevs.

Require Import kstyle.

Set Implicit Arguments.

Open Scope k_scope.

Import TermAbbrevs.

Open Scope kt_scope.

Inductive Krules : Rule -> Prop :=
  (* lookup *)
  | r_lookup : forall x rest env, Krules
   (Pattern (KCfg (kra (KExp (EVar x)) rest) env),
    Pattern (KCfg (kra (KExp (ECon (Lookup env x))) rest) env))
  (* assign *)
  | r_assign : forall x i rest env, Krules
  (Pattern (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env),
   Pattern (KCfg (kra (KStmt Skip) rest) (Update env x i)))
  (* plus *)
  | r_plus : forall i j rest env, Krules
  (Pattern (KCfg (kra (KExp (EPlus (ECon i) (ECon j))) rest) env),
   Pattern (KCfg (kra (KExp (ECon (PlusZ i j))) rest) env))
  (* div *)
  | r_div : forall i j rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv (ECon i) (ECon j))) rest) env))
    (Equals (Bool true) (Nez j)),
   Pattern (KCfg (kra (KExp (ECon (DivZ i j))) rest) env))
  (* le *)
  | r_le : forall i j rest env, Krules
  (Pattern (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env),
   Pattern (KCfg (kra (KBExp (BCon (Zleb i j))) rest) env))
  (* and true *)
  | r_and_t : forall b rest env, Krules
  (Pattern (KCfg (kra (KBExp (BAnd (BCon (Bool true)) b)) rest) env),
   Pattern (KCfg (kra (KBExp b) rest) env))
  (* and false *)
  | r_and_f : forall b rest env,  Krules
  (Pattern (KCfg (kra (KBExp (BAnd (BCon (Bool false)) b)) rest) env),
   Pattern (KCfg (kra (KBExp (BCon (Bool false))) rest) env))
  | r_skip : forall rest env, Krules
  (* skip *)
  (Pattern (KCfg (kra (KStmt Skip) rest) env),
   Pattern (KCfg rest env))
  (* if true *)
  | r_if_t : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (SIf (BCon (Bool true)) s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s1) rest) env))
  (* if false *)
  | r_if_f : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (SIf (BCon (Bool false)) s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s2) rest) env))
  | r_while : forall b s rest env, Krules
  (Pattern (KCfg (kra (KStmt (SWhile b s)) rest) env),
   Pattern (KCfg (kra (KStmt (SIf b (Seq s (SWhile b s)) Skip)) rest) env))
  (* heating and cooling *)
  (* plus *)
  | r_heat_plus_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EPlus e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ + e2)) rest)) env))  | r_heat_plus_r : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EPlus e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (e + □)) rest)) env))
  | r_cool_plus_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ + e)) rest)) env),
   Pattern (KCfg (kra (KExp (EPlus (ECon i) e)) rest) env))
  | r_cool_plus_r : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e + □)) rest)) env),
   Pattern (KCfg (kra (KExp (EPlus e (ECon i))) rest) env))
  (* div *)
  | r_heat_div_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv e e2)) rest) env))
    (Equals (Bool true)(negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ / e2)) rest)) env))
  | r_heat_div_r : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KExp (EDiv e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (e / □)) rest)) env))
  | r_cool_div_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ / e)) rest)) env),
   Pattern (KCfg (kra (KExp (EDiv (ECon i) e)) rest) env))
  | r_cool_div_r : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e / □)) rest)) env),
   Pattern (KCfg (kra (KExp (EDiv e (ECon i))) rest) env))
  (* le is seqstrict *)
  | r_heat_le_l : forall e e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BLe e e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (□ <= e2)) rest)) env))
  | r_heat_le_r : forall i e2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BLe (ECon i) e2)) rest) env))
    (Equals (Bool true) (negb (isEVal e2))),
   Pattern (KCfg (kra (KExp e2) (kra (KFreezer (i <= □)) rest)) env))
  | r_cool_le_l : forall i e rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ <= e)) rest)) env),
   Pattern (KCfg (kra (KBExp (BLe (ECon i) e)) rest) env))
  | r_cool_le_r : forall j i rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon j)) (kra (KFreezer (i <= □)) rest)) env),
   Pattern (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env))
  (* and only left-strict *)
  | r_heat_and : forall b1 b2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KBExp (BAnd b1 b2)) rest) env))
    (Equals (Bool true) (negb (isBool b1))),
   Pattern (KCfg (kra (KBExp b1) (kra (KFreezer (□ && b2)) rest)) env))
  | r_cool_and : forall b b2 rest env, Krules
  (Pattern (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (□ && b2)) rest)) env),
   Pattern (KCfg (kra (KBExp (BAnd (BCon b) b2)) rest) env))
  (* assign *)
  | r_heat_assign : forall x e rest env, Krules
  (And
    (Pattern (KCfg (kra (KStmt (SAssign x e)) rest) env))
    (Equals (Bool true) (negb (isEVal e))),
   Pattern (KCfg (kra (KExp e) (kra (KFreezer (x :=□)) rest)) env))
  | r_cool_assign : forall i x rest env, Krules
  (Pattern (KCfg (kra (KExp (ECon i)) (kra (KFreezer (x :=□)) rest)) env),
   Pattern (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env))
  (* if *)
  | r_heat_if : forall b s1 s2 rest env, Krules
  (And
    (Pattern (KCfg (kra (KStmt (SIf b s1 s2)) rest) env))
    (Equals (Bool true) (negb (isBool b))),
   Pattern (KCfg (kra (KBExp b) (kra (KFreezer (if□then s1 else s2)) rest)) env))
  | r_cool_if : forall b s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (if□then s1 else s2)) rest)) env),
   Pattern (KCfg (kra (KStmt (SIf (BCon b) s1 s2)) rest) env))
  (* seq *)
  | r_heat_seq : forall s1 s2 rest env, Krules
  (Pattern (KCfg (kra (KStmt (Seq s1 s2)) rest) env),
   Pattern (KCfg (kra (KStmt s1) (kra (KStmt s2) rest)) env))
  .

Local Open Scope positive_scope.
Definition Ev := 1.
Definition envv := 2.
Definition xv := 3.
Definition yv := 4.
Definition bv := 5.
Definition rv := 6.
Definition iv := 7.
Definition jv := 8.
Definition sv := 9.
Definition s1v := 10.
Definition s2v := 11.
Definition env'v := 12.

Definition E := TMVar Ev.
Definition env := TMVar envv.
Definition x := TMVar xv.
Definition y := TMVar yv.
Definition b := TMVar bv.
Definition r := TMVar rv.
Definition i := TMVar iv.
Definition j := TMVar jv.
Definition s := TMVar sv.
Definition s1 := TMVar s1v.
Definition s2 := TMVar s2v.
Definition env' := TMVar env'v.

Definition pvi : T := Id (domains.var 1).
Definition pvj : T := Id (domains.var 2).

(* Plan: add sort predicates like IsVar, etc,
  prove lemmas relating them to environment structure -
  and use the add x (find x m) m == m to put results in
  nice form. Then validity is nice and simple.
  *)

Definition hasSort s (result : option M) :=
  match result with
    | Some gamma => s = projT1 gamma
    | None => False
  end.

Fixpoint haveSorts ss rs {struct ss} :=
  match ss, rs with
    | nil, nil => True
    | s :: ss', res :: rs' => hasSort s res /\ haveSorts ss' rs'
    | _, _ => False
  end.

Lemma vinit' gamma s args vals op :
  Some gamma = opapply s args vals op ->
  hasSort s (opapply s args vals op).
Proof.
  revert vals; induction args; destruct vals; simpl;[congruence..|].
  destruct o as [[xs xv]|];
  [destruct (ImpLabels.sort_dec a xs);[destruct e|]|];
  [auto|congruence..].
Qed.

Lemma vinit gamma l args :
  Some gamma = lapply l args ->
    hasSort (projT1 (projT2 (label_sem l))) (lapply l args).
Proof.
  unfold lapply, ImpLabels.label_sem.
  destruct (label_sem l) as [arg [res op]].
  apply vinit'.
Qed.

Lemma vbreak s args vals op :
  hasSort s (opapply s args vals op) ->
  haveSorts args vals.
Proof.
  revert vals; induction args; destruct vals; simpl; trivial.
  destruct o as [[vs vv]|].
  destruct (ImpLabels.sort_dec a vs).
  destruct e.
  simpl. specialize (IHargs (op vv) vals). intuition.
  destruct 1.
  destruct 1.
Qed.

Lemma valid_refl : forall f,
  Valid (Implies f f).
Proof.
  unfold Valid, Satisfies. simpl. trivial.
Qed.

Lemma valid_add : forall f g,
  (Valid (Implies f g)) ->
  Valid (Implies f (And f g)).
Proof.
  unfold Valid, Satisfies. simpl. intuition.
Qed.

Lemma alf (Sys : System) pre cond post:
  Sys (And pre cond,post) ->
  forall psi, patternless psi ->
  Valid (Implies (And pre psi) cond) ->
  forall strict,
  PS strict Sys (And pre psi) (And post psi).
Proof.
  intros.
  apply ps_conseq
    with (phi1':=And (And pre cond) psi)(phi2':=(And post psi)).
  revert H1. unfold Valid, Satisfies. simpl. intuition.

  apply ps_lf. apply ps_axiom. auto.

  assumption.

  apply valid_refl.
Qed.
Implicit Arguments alf [Sys pre cond post psi strict].

Lemma conseq_l : forall phi1 phi1',
  Valid (Implies phi1 phi1') ->
  forall phi2 Sys strict,
  PS strict Sys phi1' phi2 -> PS strict Sys phi1 phi2.
Proof.
  intros. eauto using ps_conseq, valid_refl.
Qed.

(* Tactics for execution *)
Ltac valid_dec := subst;unfold Valid, Satisfies; intros; simpl; intuition.
Hint Unfold cons_System.
Hint Extern 5 (Valid _) => valid_dec.
Hint Extern 3 (patternless _) => (simpl;tauto).

Ltac unabbrev :=
  repeat match goal with
    [ T : Term positive , teq : ?T = _ |- _] =>
    rewrite teq
  end.
Ltac reabbrev :=
  repeat match goal with
    [ T : Term positive , teq : ?T = _ |- _] =>
    rewrite <- teq
  end.

Ltac step :=
eapply ps_trans;[solve[eauto 20 using ps_axiom,ps_lf,alf,Krules]|].

Ltac run := unabbrev;repeat step;instantiate;reabbrev.

(*
Lemma use_has
match PositiveMap.find envv rho with
       | Some gamma => sStore = projT1 gamma
       | None => False
       end
 *)

Lemma domain_reasoning_1
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))) :
   Valid
     (Implies
(And
           (And
              (Pattern
                 (KCfg
                    (kra
                       (KStmt
                          (SIf
                             (BCon
                                (Zleb (Val 1)
                                   (Lookup (Update (Update env pvi x) pvj y)
                                      pvi)))
                             (Seq loopBody (SWhile loopTest loopBody)) Skip))
                       kdot) (Update (Update env pvi x) pvj y)))
              (And (And (HasSort sVal x) (HasSort sVal y))
                 (HasSort sStore env))) (Equals (Bool true) (Zleb (Val 0) x)))

        (Or
           (And
              (And
                 (Pattern
                    (KCfg
                       (kra
                          (KStmt
                             (SIf (BCon (Bool true))
                                (Seq loopBody (SWhile loopTest loopBody))
                                Skip)) kdot)
                       (Update (Update env pvi x) pvj y)))
                 (And (And (HasSort sVal x) (HasSort sVal y))
                    (HasSort sStore env)))
              (Equals (Bool true) (Zleb (Val 0) (PlusZ x (Val (-1))))))
           (Pattern
              (KCfg
                 (kra
                    (KStmt
                       (SIf (BCon (Bool false))
                          (Seq loopBody (SWhile loopTest loopBody)) Skip))
                    kdot) (Update (Update env pvi (Val 0)) pvj (PlusZ x y)))))).

Opaque PositiveMap.find.
Opaque PositiveMap.add.
subst;unfold Valid, Satisfies; intros; simpl; intuition.
repeat
(match goal with
  | [H : exists v, PositiveMap.find _ _ = Some (existT _ _ _)
    |- _] => let v := fresh v in let Hlookup := fresh Hlookup in
             destruct H as [v Hlookup];rewrite Hlookup in * |- *
  end).
cbv [lapply ImpLabels.label_sem label_sem label projT1 projT2 eq_rec eq_rect] in H.
simpl in * |- *.

rewrite PositiveMap.gso in H by discriminate.
rewrite PositiveMap.gss in H.
remember (Zle_bool 1 v0) as bresult in H.
pose proof (Zle_cases 1%Z v0) as Hle.
rewrite <- Heqbresult in Hle.
destruct bresult;[left|right].

(* need to continue, just show tidying *)
unfold lapply;simpl;intuition.
eauto.
eauto.
eauto.

clear -Hle.
repeat apply f_equal.
symmetry.
apply Zle_imp_le_bool.
omega.

(* preparing to stop *)
Lemma some_inj (A : Set) (x y : A) :
  Some x = Some y -> x = y.
Proof.
  injection 1; trivial.
Qed.
assert (v0 = 0%Z).
clear -H1 Hle.
unfold lapply in H1; simpl in H1.

Lemma M_inj (s : Sort) (x y : sort_sem s) :
  existT _ s x = existT _ s y -> x = y.
Proof.
  apply Eqdep_dec.inj_pair2_eq_dec; exact sort_dec.
Qed.
apply M_inj in H1.
symmetry in H1.
apply Zle_bool_imp_le in H1.
omega.
subst.
assumption.
(* adjustement done *)

Qed.

Lemma domain_reasoning_2 : forall
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))),
   Valid
     (Implies
        (And
           (And
              (Pattern
                 (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
                    (Update
                       (Update (Update (Update env pvi x) pvj y) pvi
                          (PlusZ
                             (Lookup (Update (Update env pvi x) pvj y) pvi)
                             (Val (-1)))) pvj
                       (PlusZ
                          (Lookup
                             (Update (Update (Update env pvi x) pvj y) pvi
                                (PlusZ
                                   (Lookup (Update (Update env pvi x) pvj y)
                                      pvi) (Val (-1)))) pvj)
                          (Val 1)))))
              (And (And (HasSort sVal x) (HasSort sVal y))
                 (HasSort sStore env)))
           (Equals (Bool true) (Zleb (Val 0) (PlusZ x (Val (-1))))))
        (ApplyF
           (PositiveMap.add xv (PlusZ x (Val (-1)))
              (PositiveMap.add yv (PlusZ y (Val 1))
                 (PositiveMap.empty (Term positive))))
           (And
              (And
                 (Pattern
                    (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
                       (Update (Update env pvi x) pvj y)))
                 (And (And (HasSort sVal x) (HasSort sVal y))
                    (HasSort sStore env)))
              (Equals (Bool true) (Zleb (Val 0) x))))).
Proof.
intros; subst.
simpl.
valid_dec.
unfold ImpLang.app_var in * |- *.
repeat ((rewrite PositiveMap.gso in * |- * by discriminate)
  || rewrite PositiveMap.gss in * |- *
  || rewrite PositiveMap.gempty in * |- *).
simpl in * |- *.
repeat
(match goal with
  | [H : exists v, PositiveMap.find _ _ = Some (existT _ _ _)
    |- _] => let v := fresh v in let Hlookup := fresh Hlookup in
             destruct H as [v Hlookup];rewrite Hlookup in * |- *
  end).

unfold lapply in H;simpl in H.
apply some_inj in H.
subst gamma.
unfold lapply;simpl.
apply f_equal.
apply f_equal.
apply f_equal.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
Transparent PositiveMap.add.
destruct v1;[|destruct v1_1];reflexivity.
Opaque PositiveMap.add.

destruct H2. exists (x0 - 1)%Z.
unfold inTerm, value', Apply', ImpLang.app_var;simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
simpl. rewrite H0. reflexivity.

destruct H4. exists (x0 + 1)%Z.
unfold inTerm, value', Apply', ImpLang.app_var;simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
simpl. rewrite H0. reflexivity.
Qed.

Lemma domain_reasoning_3 : forall
  (loopTest : Term positive)
  (HeqloopTest : loopTest = BLe (ECon (Val 1)) (EVar pvi))
  (loopBody : Term positive)
  (HeqloopBody : loopBody =
                Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
                  (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1))))),
   Valid
     (Implies
        (ApplyF
           (PositiveMap.add xv (PlusZ x (Val (-1)))
              (PositiveMap.add yv (PlusZ y (Val 1))
                 (PositiveMap.empty (Term positive))))
           (Pattern
              (KCfg kdot (Update (Update env pvi (Val 0)) pvj (PlusZ x y)))))
        (Pattern
           (KCfg kdot (Update (Update env pvi (Val 0)) pvj (PlusZ x y))))).

intros.
simpl.
unfold Apply', ImpLang.app_var.
simpl.
repeat ((rewrite PositiveMap.gso by discriminate) || rewrite PositiveMap.gss || rewrite PositiveMap.gempty).
valid_dec.

destruct (PositiveMap.find envv rho) as [[[]]|];try discriminate H.
destruct (PositiveMap.find xv rho) as [[[]]|];try discriminate H.
destruct (PositiveMap.find yv rho) as [[[]]|];try discriminate H.

unfold lapply in * |- *; simpl in * |- *.
apply some_inj in H. subst.
replace (s3 + -1 + (s4 + 1))%Z with (s3 + s4)%Z.
reflexivity.
ring.
Qed.

Lemma sum : PS true Krules
  (And
    (Pattern (KCfg
      (kra
        (KStmt
          (SWhile (BLe (ECon (Val 1%Z)) (EVar pvi))
            (Seq
              (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)%Z))))
              (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1%Z)))))))
        kdot)
    (Update (Update env pvi x) pvj y)))
  (Equals (Bool true) (Zleb (Val 0%Z) x)))
  (Pattern (KCfg kdot
    (Update (Update env pvi (Val 0%Z))
      pvj (PlusZ x y)))).
Proof.

remember (BLe (ECon (Val 1)) (EVar pvi)) as loopTest.
remember (Seq (SAssign pvi (EPlus (EVar pvi) (ECon (Val (-1)))))
              (SAssign pvj (EPlus (EVar pvj) (ECon (Val 1)))))
  as loopBody.

apply conseq_l with
  (phi1' :=
    (And
      (And (Pattern
        (KCfg (kra (KStmt (SWhile loopTest loopBody)) kdot)
          (Update (Update env pvi x) pvj y)))
      (And (And (HasSort sVal x) (HasSort sVal y)) (HasSort sStore env)))
      (Equals (Bool true) (Zleb (Val 0) x)))).

subst; unfold Valid, Satisfies; intros.
Opaque PositiveMap.find.
Opaque PositiveMap.add.
simpl. intros.
cbv [lapply ImpLabels.label_sem label_sem label projT1 projT2 eq_rec eq_rect] in H.
destruct H.
destruct (PositiveMap.find xv rho) as [[[]]|];try (discriminate H0);
destruct (PositiveMap.find envv rho) as [[[]]|];try (discriminate H);
destruct (PositiveMap.find yv rho) as [[[]]|];try (discriminate H);
simpl in H.
intuition eauto.
(* That took a while, but now we have know sorts of variables *)

eapply ps_circ.

run; auto using ps_refl.

eapply conseq_l.
eauto using domain_reasoning_1.

apply ps_case.

let n := 19 in
unabbrev;do n step;instantiate;reabbrev.

(* ready to use the circular assumption, but will
   need to subst to expand x/y *)

eapply ps_conseq.
Focus 2.
eapply ps_subst.
apply ps_axiom; left; reflexivity.
instantiate (1:=
  PositiveMap.add xv (PlusZ x (Val (-1)%Z))
  (PositiveMap.add yv (PlusZ y (Val 1%Z))
    (PositiveMap.empty _))).

eauto using domain_reasoning_2.
eauto using domain_reasoning_3.

run; auto using ps_refl.
Qed.