From stdpp Require Export coPset.
From stdpp Require Import namespaces.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmap auth agree gset coPset.
From Perennial.base_logic.lib Require Export own.
From Perennial.base_logic.lib Require Import wsat fancy_updates.
From iris.prelude Require Import options.
Export invGS.
Import uPred.

(* We start by constructing a way to divide up a namespace into a countably infinite sequence of name spaces with *)

Fixpoint ndc (N: namespace) (n: nat) : namespace :=
  match n with
  | O => N
  | S n' => ndc (N.@(1%positive)) n'
  end.

Lemma ndc_tail N n :
  ndc N (S n) = (ndc N n).@(1%positive).
Proof. revert N. induction n => N; first done. rewrite -IHn => //=. Qed.

Definition nomega (N: namespace) (mn: option nat) : coPset :=
  match mn with
  | None => ↑(N.@(2%positive))
  | Some n => ↑(ndc (N.@(1%positive)) n) ∪ ↑(N.@(2%positive))
  end.

Lemma ndc_anti_mono N n1 n2:
  n1 ≤ n2 →
  (↑(ndc N n2) : coPset) ⊆ ↑(ndc N n1).
Proof.
  induction 1.
  - reflexivity.
  - transitivity (↑(ndc N m) : coPset); last auto.
    clear. revert N. induction m => N.
    * rewrite //=. solve_ndisj.
    * rewrite ndc_tail. solve_ndisj.
Qed.

Lemma ndc_subset_root N n:
  (↑ (ndc N n) : coPset) ⊆ ↑N.
Proof.
  induction n; first solve_ndisj. etransitivity; last eauto.
  apply ndc_anti_mono; eauto.
Qed.

Definition ndc_S_diff N n : coPset := (↑ (ndc N n)) ∖ (↑ (ndc N (S n))).

Lemma ndc_compl_S_inf N n: ¬ set_finite (ndc_S_diff N n).
Proof.
  rewrite /ndc_S_diff.
  match goal with
  | [ |- ¬ set_finite ?X ] => cut ((↑ndc N n.@(2%positive)) ⊆ X)
  end.
  { pose proof (nclose_infinite (ndc N n.@(2%positive))) as Hinf. intros => Hfalse.
    apply Hinf. eapply set_finite_subseteq; eauto. }
  rewrite ndc_tail. solve_ndisj.
Qed.

Lemma nomega_anti_mono_Some N n1 n2:
  n1 ≤ n2 →
  nomega N (Some n2) ⊆ nomega N (Some n1).
Proof. intros Hle => //=.  pose proof (ndc_anti_mono (N.@1%positive) n1 n2). set_solver. Qed.

Lemma nomega_anti_mono_None N n:
  nomega N None ⊆ nomega N (Some n).
Proof. rewrite //=. set_solver. Qed.

Definition omega_le (mj1 mj2: option nat) : Prop :=
  match mj1, mj2 with
  | None, _ => True
  | Some n1, Some n2 => n2 ≤ n1
  | _, _ => False
  end.

Lemma omega_le_refl mj : omega_le mj mj.
Proof. destruct mj; simpl; done. Qed.

Lemma nomega_omege_le N mj1 mj2 :
  omega_le mj1 mj2 →
  nomega N mj1 ⊆ nomega N mj2.
Proof.
  destruct mj1, mj2; try (inversion 1; done).
  - apply nomega_anti_mono_Some.
  - intros _. apply nomega_anti_mono_None.
Qed.

Lemma nomega_subset_root N mj :
  nomega N mj ⊆ ↑ N.
Proof.
  destruct mj => //=.
  - apply union_least.
    * etransitivity; first eapply ndc_subset_root. solve_ndisj.
    * solve_ndisj.
  - solve_ndisj.
Qed.

(*
Fixpoint slice_string (j: nat) : namespace :=
  match j with
  | O => nroot
  | S n' => nroot.@(1%positive).@(slice_string n')
  end.
*)

Definition AE'_ns (n : nat) : namespace := nroot.@(1%positive).@(n).
Definition AE' (n: nat) : coPset := ↑(AE'_ns n).
Definition AE'' (n: nat) mj := nomega (AE'_ns n) mj.

Fixpoint AE_full_def (n: nat) :=
  AE' n ∪
  match n with
  | O => ∅
  | S n' => AE_full_def n'
  end.
Definition AE_full_aux : seal AE_full_def. Proof. by eexists. Qed.
Definition AE_full := AE_full_aux.(unseal).
Definition AE_full_eq : AE_full = AE_full_def :=
  AE_full_aux.(seal_eq).

Definition AE_def (n: nat) (mj: option nat) :=
  match n with
  | O => ∅
  | S n' => AE'' n mj ∪ AE_full n'
  end.
Definition AE_aux : seal AE_def. Proof. by eexists. Qed.
Definition AE := AE_aux.(unseal).
Definition AE_eq : AE = AE_def :=
  AE_aux.(seal_eq).

Lemma AlwaysEn_alt : AlwaysEn = ↑(nroot.@(1%positive)).
Proof.
  rewrite /AlwaysEn/coPset_inl ?namespaces.nclose_unseal /namespaces.nclose_def/up_close.
  rewrite /nroot namespaces.ndot_unseal /namespaces.ndot_def/encode //=.
  apply coPset_suffixes_of_top.
Qed.

Lemma AE'_disj n1 n2 : n1 ≠ n2 → AE' n1 ## AE' n2.
Proof. solve_ndisj. Qed.
Lemma AE'_disj_AE_full n1 n2 : n1 < n2 → AE' n2 ## AE_full n1.
Proof.
  revert n2. rewrite AE_full_eq.
  induction n1 => n2 Hlt.
  - rewrite //= right_id. apply AE'_disj. lia.
  - rewrite //=.
    feed pose proof (IHn1 n2); first lia.
    feed pose proof (AE'_disj n2 (S n1)); first lia.
    set_solver.
Qed.
Lemma AE_full_mono n1 n2 : n1 ≤ n2 → AE_full n1 ⊆ AE_full n2.
Proof. rewrite AE_full_eq. induction 1; rewrite //=; set_solver. Qed.
Lemma AE'_subset_AlwaysEn n : AE' n ⊆ AlwaysEn.
Proof. rewrite AlwaysEn_alt. solve_ndisj. Qed.
Lemma AE_full_subset_AlwaysEn n : AE_full n ⊆ AlwaysEn.
Proof. rewrite AE_full_eq AlwaysEn_alt. induction n; solve_ndisj. Qed.
Lemma AE_full_MaybeEn_disj n E : AE_full n ## MaybeEn1 E.
Proof.
  pose proof (AE_full_subset_AlwaysEn n).
  cut (AlwaysEn ## MaybeEn1 E); last by apply coPset_inl_inr_disj.
  { set_solver. }
Qed.
Lemma AE''_subset_AE' n mj : AE'' n mj ⊆ AE' n.
Proof. rewrite /AE''/AE'. apply nomega_subset_root. Qed.
Lemma AE''_disj_AE_full n1 n2 mj : n1 < n2 → AE'' n2 mj ## AE_full n1.
Proof.
  pose proof (AE''_subset_AE' n2 mj).
  pose proof (AE'_disj_AE_full n1 n2). intros.
  set_solver.
Qed.
Lemma AE_subset_AE_full n mj : AE n mj ⊆ AE_full n.
Proof.
  rewrite AE_eq AE_full_eq /AE_def /AE_full_def -/AE_full_def.
  destruct n; simpl; try set_solver.
  apply union_least.
  * etransitivity; last eapply union_subseteq_l. apply AE''_subset_AE'.
  * rewrite AE_full_eq; set_solver.
Qed.
Lemma AE_subset_le_AE_full n1 n2 mj : n1 ≤ n2 → AE n1 mj ⊆ AE_full n2.
Proof.
  induction 1.
  - apply AE_subset_AE_full.
  - rewrite AE_full_eq /AE_full_def -/AE_full_def -AE_full_eq.
    set_solver.
Qed.
Lemma AE_full_lt_subset_AE n1 n2 mj : n1 < n2 → AE_full n1 ⊆ AE n2 mj.
Proof.
  induction 1.
  * rewrite AE_eq /AE_def. set_solver.
  * rewrite AE_eq /AE_def. etransitivity; last eapply union_subseteq_r.
    apply AE_full_mono; eauto. lia.
Qed.

Lemma difference_union_same_L (X Y Z : coPset):
  X ## Z → Y ## Z →
  (X ∪ Z) ∖ (Y ∪ Z) = X ∖ Y.
Proof. set_solver. Qed.

Lemma disjoint_subseteq (X Y Z : coPset):
  X ⊆ Y →
  Y ## Z →
  X ## Z.
Proof. set_solver. Qed.

Lemma AE'_disj_lt_AE n1 mj n2 : n1 < n2 → AE n1 mj ## AE' n2.
Proof.
  intros Hlt.
  eapply disjoint_subseteq.
  { eapply AE_subset_AE_full. }
  symmetry. by apply AE'_disj_AE_full.
Qed.

Lemma AE_subset_mono n1 n2 mj1 mj2 :
  (n1 < n2 ∨ (n1 = n2 ∧ omega_le mj1 mj2)) →
  AE n1 mj1 ⊆ AE n2 mj2.
Proof.
  intros [Hlt|Heq].
  - induction Hlt.
    * rewrite AE_eq /= -AE_eq. etransitivity; last eapply union_subseteq_r.
      apply AE_subset_AE_full.
    * transitivity (AE_full m).
      ** apply AE_subset_le_AE_full; lia.
      ** apply AE_full_lt_subset_AE. lia.
  - destruct Heq as (->&Hle).
    rewrite AE_eq /AE_def; destruct n2; first set_solver+.
    rewrite /AE''. apply union_mono_r. by apply nomega_omege_le.
Qed.

Lemma AE_subset_AlwaysEn n mj : AE n mj ⊆ AlwaysEn.
Proof.
  etransitivity; first eapply (AE_subset_le_AE_full n n mj); auto.
  apply AE_full_subset_AlwaysEn.
Qed.

Lemma AE_MaybeEn_disj n mj E : AE n mj ## MaybeEn1 E.
Proof.
  pose proof (AE_full_MaybeEn_disj n E).
  pose proof (AE_subset_AE_full n mj). set_solver.
Qed.

Definition AE_next n mj : coPset :=
  match mj with
  | Some j => AE n (Some (S j))
  | None =>
    match n with
    | O => ∅
    | S n => AE n (Some O)
    end
  end.

Definition AE_S_diff n j : coPset :=
  AE n (Some j) ∖ AE n (Some (S j)).

Definition AE_next_diff n mj : coPset := AE n mj ∖ AE_next n mj.

Lemma AE_S_diff_inf n j: ¬ set_finite (AE_S_diff (S n) j).
Proof.
  rewrite /AE_S_diff.
  rewrite AE_eq /AE_def.
  rewrite difference_union_same_L; swap 1 3.
  { eapply AE''_disj_AE_full; lia. }
  { eapply AE''_disj_AE_full; lia. }
  rewrite /=.
  rewrite difference_union_same_L; swap 1 3.
  { match goal with
      | [ |- ↑ (ndc ?X ?j) ## _] => pose proof (ndc_subset_root X j)
    end. eapply disjoint_subseteq; first eassumption.
    solve_ndisj. }
  { match goal with
      | [ |- ↑ (ndc ?X ?j) ## _] => pose proof (ndc_subset_root X j)
    end. eapply disjoint_subseteq; first eassumption.
    solve_ndisj. }
  apply ndc_compl_S_inf.
Qed.

Lemma AE_next_diff_inf n mj: ¬ set_finite (AE_next_diff (S n) mj).
Proof.
  destruct mj; first apply AE_S_diff_inf.
  rewrite /=. rewrite /AE_next_diff/AE_next. rewrite AE_eq /=.
  match goal with
    | [ |- ¬ set_finite ?X ] => assert (↑ (AE'_ns (S n).@2%positive) ⊆ X)
  end.
  { cut (↑AE'_ns (S n).@2%positive ## AE_def n (Some 0)).
    { set_solver. }
    eapply (disjoint_subseteq _ (AE' (S n))).
    { rewrite /AE'. solve_ndisj. }
    rewrite -AE_eq. symmetry. eapply AE'_disj_lt_AE. lia.
  }
  intros Hfin. eapply set_finite_subseteq in Hfin; last eassumption.
  eapply nclose_infinite; eauto.
Qed.

Local Hint Extern 0 (AE_full _ ## MaybeEn1 _) => apply AE_full_MaybeEn_disj : core.
Local Hint Extern 0 (AE _ _ ## MaybeEn1 _) => apply AE_MaybeEn_disj : core.
Local Hint Extern 0 (AlwaysEn ## MaybeEn1 _) => apply coPset_inl_inr_disj : core.

Definition uPred_fupd_split_level_def `{!invGS Σ} (E1 E2 : coPset) (k : nat) mj (P : iProp Σ) : iProp Σ :=
  wsat (S k) ∗ ownE (AE (S k) mj ∪ MaybeEn1 E1) ==∗ ◇ (wsat (S k) ∗ ownE (AE (S k) mj ∪ MaybeEn1 E2) ∗ P).
Definition uPred_fupd_split_level_aux `{!invGS Σ} : seal uPred_fupd_split_level_def. Proof. by eexists. Qed.
Definition uPred_fupd_split_level `{!invGS Σ} := uPred_fupd_split_level_aux.(unseal).
Definition uPred_fupd_split_level_eq `{!invGS Σ} : uPred_fupd_split_level = uPred_fupd_split_level_def :=
  uPred_fupd_split_level_aux.(seal_eq).

Definition uPred_fupd_level_def `{!invGS Σ} (E1 E2 : coPset) (k : nat) (P : iProp Σ) : iProp Σ :=
  uPred_fupd_split_level E1 E2 k None P.
Definition uPred_fupd_level_aux `{!invGS Σ} : seal uPred_fupd_level_def. Proof. by eexists. Qed.
Definition uPred_fupd_level `{!invGS Σ} := uPred_fupd_level_aux.(unseal).
Definition uPred_fupd_level_eq `{!invGS Σ} : uPred_fupd_level = uPred_fupd_level_def :=
  uPred_fupd_level_aux.(seal_eq).

Reserved Notation "| k , j ={ E1 }=> Q"
  (at level 99, E1, k at level 50, j at level 50, Q at level 200,
   format "| k , j ={ E1 }=>  Q").
Reserved Notation "| k , j ={ E1 , E2 }=> Q"
  (at level 99, E1, E2, k at level 50, j at level 50, Q at level 200,
   format "| k , j ={ E1 , E2 }=>  Q").
Reserved Notation "| k ={ E1 }=> Q"
  (at level 99, E1, k at level 50, Q at level 200,
   format "| k ={ E1 }=>  Q").
Reserved Notation "| k ={ E1 , E2 }=> Q"
  (at level 99, E1, E2, k at level 50, Q at level 200,
   format "| k ={ E1 , E2 }=>  Q").

(*
Reserved Notation "P = k ={ E1 , E2 }=∗ Q"
  (at level 99, E1,E2, k at level 50, Q at level 200,
   format "'[' P  '/' = k ={ E1 , E2 }=∗  Q ']'").
*)

Notation "| k , j ={ E1 , E2 }=> Q" := (uPred_fupd_split_level E1 E2 k j Q) : bi_scope.
Notation "| k , j ={ E1 }=> Q" := (uPred_fupd_split_level E1 E1 k j Q) : bi_scope.
Notation "| k ={ E1 , E2 }=> Q" := (uPred_fupd_level E1 E2 k Q) : bi_scope.
Notation "| k ={ E1 }=> Q" := (uPred_fupd_level E1 E1 k Q) : bi_scope.
(*
Notation "P = k ={ E1 , E2 }=∗ Q" := (P -∗ |k={E1,E2}=> Q)%I : bi_scope.
Notation "P = k ={ E1 , E2 }=∗ Q" := (P -∗ |k={E1,E2}=> Q) : stdpp_scope.
*)

Section fupd_level.
Context `{!invGS Σ}.
Implicit Types P: iProp Σ.
Implicit Types E : coPset.
Implicit Types j k : nat.
Implicit Types mj : option nat.

Global Instance fupd_split_level_ne E1 E2 k mj : NonExpansive (uPred_fupd_split_level E1 E2 k mj).
Proof. rewrite uPred_fupd_split_level_eq. solve_proper. Qed.
Global Instance fupd_level_ne E1 E2 k : NonExpansive (uPred_fupd_level E1 E2 k).
Proof. rewrite uPred_fupd_level_eq. solve_proper. Qed.

Lemma fupd_split_level_intro_mask E1 E2 k mj P : E2 ⊆ E1 → P ⊢ |k,mj={E1,E2}=> |k,mj={E2,E1}=> P.
Proof.
  intros (E1''&->&?)%subseteq_disjoint_union_L.
  rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def ?ownE_op // ?ownE_op_MaybeEn //.
  by iIntros "$ ($ & $ & $ & HE) !> !> [$ [$ $]] !> !>" .
Qed.

Lemma fupd_level_mask_intro_subseteq E1 E2 k P : E2 ⊆ E1 → P ⊢ |k={E1,E2}=> |k={E2,E1}=> P.
Proof. rewrite uPred_fupd_level_eq; apply fupd_split_level_intro_mask. Qed.

Lemma except_0_fupd_split_level E1 E2 k mj P : ◇ (|k,mj={E1,E2}=> P) ⊢ |k,mj={E1,E2}=> P.
Proof.
  rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def.
  iIntros ">H [Hw HE]". iApply "H"; by iFrame.
Qed.

Lemma except_0_fupd_level E1 E2 k P : ◇ (|k={E1,E2}=> P) ⊢ |k={E1,E2}=> P.
Proof. rewrite uPred_fupd_level_eq; apply except_0_fupd_split_level. Qed.

Lemma fupd_split_level_mono E1 E2 k mj P Q : (P ⊢ Q) → (|k,mj={E1,E2}=> P) ⊢ |k,mj={E1,E2}=> Q.
Proof.
  rewrite uPred_fupd_split_level_eq. iIntros (HPQ) "HP HwE". rewrite -HPQ. by iApply "HP".
Qed.

Lemma fupd_level_mono E1 E2 k P Q : (P ⊢ Q) → (|k={E1,E2}=> P) ⊢ |k={E1,E2}=> Q.
Proof. rewrite uPred_fupd_level_eq; apply fupd_split_level_mono. Qed.

Lemma ownE_AE_split_current_rest k mj :
  ownE (AE (S k) mj) ⊣⊢  ownE (AE_next_diff (S k) mj) ∗ ownE (AE_next (S k) mj).
Proof.
  rewrite /AE_next_diff/AE_next.
  rewrite -ownE_op.
  {
    f_equiv.
    rewrite difference_union_L.
    rewrite (comm_L (∪)) subseteq_union_1_L //.
    destruct mj; apply AE_subset_mono; naive_solver lia.
  }
  set_solver.
Qed.
Lemma ownE_AE_le_acc n1 mj1 n2 mj2 :
  (n1 < n2 ∨ (n1 = n2 ∧ omega_le mj1 mj2)) →
  ownE (AE n2 mj2) -∗ ownE (AE n1 mj1) ∗ (ownE (AE n1 mj1) -∗ ownE (AE n2 mj2)).
Proof. iIntros (?). iApply ownE_mono_le_acc. by apply AE_subset_mono. Qed.

Lemma ownE_AlwaysEn_le_acc n1 mj1 :
  ownE (AlwaysEn) -∗ ownE (AE n1 mj1) ∗ (ownE (AE n1 mj1) -∗ ownE AlwaysEn).
Proof. iApply ownE_mono_le_acc. by apply AE_subset_AlwaysEn. Qed.

Lemma fupd_split_level_le E1 E2 k1 k2 mj1 mj2 P :
  (k1 < k2 ∨ (k1 = k2 ∧ omega_le mj1 mj2)) →
  (|k1,mj1={E1,E2}=> P) ⊢ |k2,mj2={E1,E2}=> P.
Proof.
  rewrite ?uPred_fupd_split_level_eq /uPred_fupd_split_level_def.
  rewrite ?ownE_op //.
  iIntros (Hle) "HP (Hw&HAE&HE)".
  iDestruct (wsat_le_acc (S k1) (S k2) with "Hw") as "(Hw&Hclo)".
  { lia. }
  iDestruct (ownE_AE_le_acc (S k1) mj1 (S k2) mj2 with "HAE") as "(HAE&Hclo')".
  { naive_solver lia. }
  iMod ("HP" with "[$]") as "H". iModIntro.
  iMod "H" as "(Hw&(HAE&HE)&HP)". iFrame.
  iModIntro.
  iDestruct ("Hclo" with "[$]") as "$".
  iDestruct ("Hclo'" with "[$]") as "$".
Qed.

Lemma fupd_level_le E1 E2 k1 k2 P : k1 ≤ k2 → (|k1={E1,E2}=> P) ⊢ |k2={E1,E2}=> P.
Proof. rewrite ?uPred_fupd_level_eq => ?. apply fupd_split_level_le; naive_solver lia. Qed.

Lemma fupd_level_split_level E1 E2 k1 mj k2 P : k1 ≤ k2 → (|k1={E1,E2}=> P) ⊢ |k2,mj={E1,E2}=> P.
Proof. rewrite ?uPred_fupd_level_eq => ?. apply fupd_split_level_le; naive_solver lia. Qed.

Lemma fupd_split_level_fupd E1 E2 P k mj : (|k,mj={E1,E2}=> P) ⊢ |={E1,E2}=> P.
Proof.
  rewrite ?uPred_fupd_split_level_eq /uPred_fupd_split_level_def.
  rewrite ?uPred_fupd_eq /uPred_fupd_def.
  rewrite ?ownE_op //.
  iIntros "HP (Hw&HAE&HE)".
  iMod (wsat_all_acc (S k) with "Hw") as "(Hw&Hclo)".
  iDestruct (ownE_AlwaysEn_le_acc (S k) with "HAE") as "(HAE&Hclo')".
  iMod ("HP" with "[$]") as ">(?&(?&$)&$)".
  do 2 iModIntro.
  iDestruct ("Hclo" with "[$]") as "$".
  iDestruct ("Hclo'" with "[$]") as "$".
Qed.

Lemma fupd_level_fupd E1 E2 P k : (|k={E1,E2}=> P) ⊢ |={E1,E2}=> P.
Proof. rewrite ?uPred_fupd_level_eq. apply fupd_split_level_fupd. Qed.

Lemma fupd_split_level_trans E1 E2 E3 k mj P : (|k,mj={E1,E2}=> |k,mj={E2,E3}=> P) ⊢ |k,mj={E1,E3}=> P.
Proof.
  rewrite uPred_fupd_split_level_eq. iIntros "HP HwE".
  iMod ("HP" with "HwE") as ">(Hw & HE & HP)". iApply "HP"; by iFrame.
Qed.

Lemma fupd_level_trans E1 E2 E3 k P : (|k={E1,E2}=> |k={E2,E3}=> P) ⊢ |k={E1,E3}=> P.
Proof. rewrite uPred_fupd_level_eq; apply fupd_split_level_trans. Qed.

Lemma fupd_split_level_mask_frame_r' E1 E2 Ef k mj P:
    E1 ## Ef → (|k,mj={E1,E2}=> ⌜E2 ## Ef⌝ → P) ⊢ |k,mj={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof.
  intros HE1Ef. rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def ?ownE_op // ownE_op_MaybeEn //.
  iIntros "Hvs (Hw & HAE & HE1 & HEf)".
  iMod ("Hvs" with "[Hw HAE HE1]") as ">($ & (HAE & HE2) & HP)"; first by iFrame.
  iDestruct (ownE_op_MaybeEn' with "[HE2 HEf]") as "[? $]"; first by iFrame.
  iIntros "!> !>". iFrame. by iApply "HP".
Qed.

Lemma fupd_level_mask_frame_r' E1 E2 Ef k P:
    E1 ## Ef → (|k={E1,E2}=> ⌜E2 ## Ef⌝ → P) ⊢ |k={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof. rewrite uPred_fupd_level_eq; apply fupd_split_level_mask_frame_r'. Qed.

Lemma fupd_split_level_frame_r E1 E2 k mj P R:
  (|k,mj={E1,E2}=> P) ∗ R ⊢ |k,mj={E1,E2}=> P ∗ R.
Proof. rewrite uPred_fupd_split_level_eq /uPred_fupd_split_level_def. by iIntros "[HwP $]". Qed.

Lemma fupd_level_frame_r E1 E2 k P R:
  (|k={E1,E2}=> P) ∗ R ⊢ |k={E1,E2}=> P ∗ R.
Proof. rewrite uPred_fupd_level_eq; apply fupd_split_level_frame_r. Qed.

Global Instance fupd_split_level_proper E1 E2 k mj :
  Proper ((≡) ==> (≡)) (uPred_fupd_split_level E1 E2 k mj) := ne_proper _.
Global Instance fupd_level_proper E1 E2 k :
  Proper ((≡) ==> (≡)) (uPred_fupd_level E1 E2 k) := ne_proper _.

Global Instance fupd_split_mono' E1 E2 k mj : Proper ((⊢) ==> (⊢)) (uPred_fupd_split_level E1 E2 k mj).
Proof. intros P Q; apply fupd_split_level_mono. Qed.
Global Instance fupd_mono' E1 E2 k : Proper ((⊢) ==> (⊢)) (uPred_fupd_level E1 E2 k).
Proof. intros P Q; apply fupd_level_mono. Qed.
Global Instance fupd_split_flip_mono' E1 E2 k mj :
  Proper (flip (⊢) ==> flip (⊢)) (uPred_fupd_split_level E1 E2 k mj).
Proof. intros P Q; apply fupd_split_level_mono. Qed.
Global Instance fupd_flip_mono' E1 E2 k :
  Proper (flip (⊢) ==> flip (⊢)) (uPred_fupd_level E1 E2 k).
Proof. intros P Q; apply fupd_level_mono. Qed.

Lemma bupd_fupd_split_level E k mj P:
  (|==> P) ⊢ |k,mj={E}=> P.
Proof. rewrite uPred_fupd_split_level_eq. by iIntros ">? [$ $] !> !>". Qed.

Lemma bupd_fupd_level E k P:
  (|==> P) ⊢ |k={E}=> P.
Proof. rewrite uPred_fupd_level_eq. apply bupd_fupd_split_level. Qed.

Lemma fupd_level_intro E k P : P ⊢ |k={E}=> P.
Proof. by rewrite {1}(fupd_level_mask_intro_subseteq E E k P) // fupd_level_trans. Qed.
Lemma fupd_level_mask_subseteq {E1} E2 k : E2 ⊆ E1 → ⊢@{iPropI Σ} |k={E1,E2}=> |k={E2,E1}=> emp.
Proof. exact: fupd_level_mask_intro_subseteq. Qed.
Lemma fupd_level_except_0 E1 E2 k P : (|k={E1,E2}=> ◇ P) ⊢ |k={E1,E2}=> P.
Proof. by rewrite {1}(fupd_level_intro E2 k P) except_0_fupd_level fupd_level_trans. Qed.

Global Instance from_assumption_fupd_level E k p P Q :
  FromAssumption p P (|==> Q) → KnownRFromAssumption p P (|k={E}=> Q)%I.
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply bupd_fupd_level. Qed.

Global Instance from_pure_fupd_level a E k P φ :
  FromPure a P φ → FromPure a (|k={E}=> P) φ.
Proof. rewrite /FromPure. intros <-. apply fupd_level_intro. Qed.

Lemma fupd_level_frame_l E1 E2 k R Q : (R ∗ |k={E1,E2}=> Q) ⊢ |k={E1,E2}=> R ∗ Q.
Proof. rewrite !(comm _ R); apply fupd_level_frame_r. Qed.
Lemma fupd_level_wand_l E1 E2 k P Q : (P -∗ Q) ∗ (|k={E1,E2}=> P) ⊢ |k={E1,E2}=> Q.
Proof. by rewrite fupd_level_frame_l wand_elim_l. Qed.
Lemma fupd_level_wand_r E1 E2 k P Q : (|k={E1,E2}=> P) ∗ (P -∗ Q) ⊢ |k={E1,E2}=> Q.
Proof. by rewrite fupd_level_frame_r wand_elim_r. Qed.

Lemma fupd_level_mask_intro_discard E1 E2 k P : E2 ⊆ E1 → P ⊢ |k={E1,E2}=> P.
Proof.
  intros ?. rewrite -{1}(right_id emp%I bi_sep P%I).
  rewrite (fupd_level_mask_intro_subseteq E1 E2 k emp%I) //.
  by rewrite fupd_level_frame_l sep_elim_l.
Qed.

Lemma fupd_level_mask_frame_r E1 E2 k Ef P :
  E1 ## Ef → (|k={E1,E2}=> P) ⊢ |k={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof.
  intros ?. rewrite -fupd_level_mask_frame_r' //. f_equiv.
  apply impl_intro_l, and_elim_r.
Qed.
Lemma fupd_level_mask_mono E1 E2 k P : E1 ⊆ E2 → (|k={E1}=> P) ⊢ |k={E2}=> P.
Proof.
  intros (Ef&->&?)%subseteq_disjoint_union_L. by apply fupd_level_mask_frame_r.
Qed.

Lemma fupd_level_sep E k P Q : (|k={E}=> P) ∗ (|k={E}=> Q) ⊢ |k={E}=> P ∗ Q.
Proof. by rewrite fupd_level_frame_r fupd_level_frame_l fupd_level_trans. Qed.
Lemma fupd_level_mask_frame E E' E1 E2 k P :
  E1 ⊆ E →
  (|k={E1,E2}=> |k={E2 ∪ (E ∖ E1),E'}=> P) -∗ (|k={E,E'}=> P).
Proof.
  intros ?. rewrite (fupd_level_mask_frame_r _ _ _ (E ∖ E1)); last set_solver.
  rewrite fupd_level_trans.
  by replace (E1 ∪ E ∖ E1) with E by (by apply union_difference_L).
Qed.

Global Instance into_wand_fupd_level E k p q R P Q :
  IntoWand false false R P Q →
  IntoWand p q (|k={E}=> R) (|k={E}=> P) (|k={E}=> Q).
Proof.
  rewrite /IntoWand /= => HR. rewrite !intuitionistically_if_elim HR.
  apply wand_intro_l. by rewrite fupd_level_sep wand_elim_r.
Qed.

Global Instance into_wand_fupd_level_persistent E1 E2 k p q R P Q :
  IntoWand false q R P Q → IntoWand p q (|k={E1,E2}=> R) P (|k={E1,E2}=> Q).
Proof.
  rewrite /IntoWand /= => HR. rewrite intuitionistically_if_elim HR.
  apply wand_intro_l. by rewrite fupd_level_frame_l wand_elim_r.
Qed.

Global Instance into_wand_fupd_level_args E1 E2 k p q R P Q :
  IntoWand p false R P Q → IntoWand' p q R (|k={E1,E2}=> P) (|k={E1,E2}=> Q).
Proof.
  rewrite /IntoWand' /IntoWand /= => ->.
  apply wand_intro_l. by rewrite intuitionistically_if_elim fupd_level_wand_r.
Qed.

Global Instance from_sep_fupd_level E k P Q1 Q2 :
  FromSep P Q1 Q2 → FromSep (|k={E}=> P) (|k={E}=> Q1) (|k={E}=> Q2).
Proof. rewrite /FromSep =><-. apply fupd_level_sep. Qed.

Global Instance from_or_fupd_level E1 E2 k P Q1 Q2 :
  FromOr P Q1 Q2 → FromOr (|k={E1,E2}=> P) (|k={E1,E2}=> Q1) (|k={E1,E2}=> Q2).
Proof.
  rewrite /FromOr=><-. apply or_elim; apply fupd_level_mono;
                         [apply bi.or_intro_l|apply bi.or_intro_r].
Qed.

Global Instance from_exist_fupd_level {A} E1 k E2 P (Φ : A → iProp Σ) :
  FromExist P Φ → FromExist (|k={E1,E2}=> P) (λ a, |k={E1,E2}=> Φ a)%I.
Proof.
  rewrite /FromExist=><-. apply exist_elim=> a. by rewrite -(exist_intro a).
Qed.

(*
Global Instance from_forall_fupd_level E1 E2 k {A} P (Φ : A → iProp Σ) :
  (* Some cases in which [E2 ⊆ E1] holds *)
  TCOr (TCEq E1 E2) (TCOr (TCEq E1 ⊤) (TCEq E2 ∅)) →
  FromForall P Φ → (∀ x, Plain (Φ x)) →
  FromForall (|k={E1,E2}=> P)%I (λ a, |k={E1,E2}=> (Φ a))%I.
Proof.
  rewrite /FromForall=> -[->|[->|->]] <- ?; rewrite fupd_plain_forall; set_solver.
Qed.
*)

Global Instance except_0_fupd_level' E1 E2 k P :
  IsExcept0 (|k={E1,E2}=> P).
Proof. by rewrite /IsExcept0 except_0_fupd_level. Qed.

Global Instance from_modal_fupd_level E k P :
  FromModal True modality_id (|k={E}=> P) (|k={E}=> P) P.
Proof. by rewrite /FromModal /= -fupd_level_intro. Qed.

Global Instance elim_modal_bupd_fupd_level p E1 E2 k P Q :
  ElimModal True p false (|==> P) P (|k={E1,E2}=> Q) (|k={E1,E2}=> Q) | 10.
Proof.
   by rewrite /ElimModal intuitionistically_if_elim
    (bupd_fupd_level E1 k) fupd_level_frame_r wand_elim_r fupd_level_trans.
Qed.
Global Instance elim_modal_fupd_level_fupd_level p E1 E2 E3 k P Q :
  ElimModal True p false (|k={E1,E2}=> P) P (|k={E1,E3}=> Q) (|k={E2,E3}=> Q).
Proof.
  by rewrite /ElimModal intuitionistically_if_elim
    fupd_level_frame_r wand_elim_r fupd_level_trans.
Qed.
(*
Global Instance elim_modal_fupd_fupd_level p E1 E2 k P Q :
  ElimModal True p false (|={E1,E2}=> P) P (|(S k)={E1,E3}=> Q) (|(S k)={E2,E3}=> Q).
Proof.
  rewrite /ElimModal => ??. rewrite (fupd_fupd_level _ _ k) intuitionistically_if_elim
    fupd_level_frame_r wand_elim_r fupd_level_trans //=.
Qed.
*)

Global Instance elim_acc_fupd_level {X} E1 E2 E k α β mγ Q :
  ElimAcc (X:=X) True (uPred_fupd_level E1 E2 k) (uPred_fupd_level E2 E1 k) α β mγ
          (|k={E1,E}=> Q)
          (λ x, |k={E2}=> β x ∗ (mγ x -∗? |k={E1,E}=> Q))%I.
Proof.
  rewrite /ElimAcc.
  iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
  iMod ("Hinner" with "Hα") as "[Hβ Hfin]".
  iMod ("Hclose" with "Hβ") as "Hγ". by iApply "Hfin".
Qed.

Global Instance frame_fupd_level p E1 E2 k R P Q :
  Frame p R P Q → Frame p R (|k={E1,E2}=> P) (|k={E1,E2}=> Q).
Proof. rewrite /Frame=><-. by rewrite fupd_level_frame_l. Qed.

Lemma fupd_level_mask_mono' E1 E2 E1' E2' k P : E1 ⊆ E2 → E2' ⊆ E1' → (|k={E1, E1'}=> P) ⊢ |k={E2,E2'}=> P.
Proof.
  iIntros (??) "H".
  iMod (fupd_level_mask_subseteq E1) as "Hclo"; auto.
  iMod "H".
  iApply (fupd_level_mask_intro_discard); auto.
Qed.

Lemma step_fupd_level_mask_mono Eo1 Eo2 Ei1 Ei2 k P :
  Ei2 ⊆ Ei1 → Eo1 ⊆ Eo2 →
  (|k={Eo1,Ei1}=> ▷ |k={Ei1, Eo1}=> P) ⊢ (|k={Eo2,Ei2}=> ▷ |k={Ei2, Eo2}=> P).
Proof.
  intros ??. rewrite -(emp_sep (|k={Eo1,Ei1}=> ▷ _))%I.
  rewrite (fupd_level_mask_intro_subseteq Eo2 Eo1 _ emp%I) //.
  rewrite fupd_level_frame_r -(fupd_level_trans Eo2 Eo1 Ei2). f_equiv.
  rewrite fupd_level_frame_l -(fupd_level_trans Eo1 Ei1 Ei2). f_equiv.
  rewrite (fupd_level_mask_intro_subseteq Ei1 Ei2 _ (|k={_,_}=> emp)%I) //.
  rewrite fupd_level_frame_r. f_equiv.
  rewrite [X in (X ∗ _)%I]later_intro -later_sep. f_equiv.
  rewrite fupd_level_frame_r -(fupd_level_trans Ei2 Ei1 Eo2). f_equiv.
  rewrite fupd_level_frame_l -(fupd_level_trans Ei1 Eo1 Eo2). f_equiv.
  by rewrite fupd_level_frame_r left_id.
Qed.

Lemma step_fupd_level_intro Ei Eo k P : Ei ⊆ Eo → ▷ P -∗ |k={Eo,Ei}=> ▷ |k={Ei,Eo}=> P.
Proof. intros. by rewrite -(step_fupd_level_mask_mono Ei _ Ei _) // -!fupd_level_intro. Qed.

End fupd_level.

Section fupd_split_level.
Context `{!invGS Σ}.
Lemma fupd_split_level_intro E k mj P : P ⊢ |k,mj={E}=> P.
Proof. by rewrite {1}(fupd_split_level_intro_mask E E k mj P) // fupd_split_level_trans. Qed.
Lemma fupd_split_level_intro_mask' E1 E2 k mj : E2 ⊆ E1 → ⊢@{iPropI Σ} |k,mj={E1,E2}=> |k,mj={E2,E1}=> emp.
Proof. exact: fupd_split_level_intro_mask. Qed.
Lemma fupd_split_level_except_0 E1 E2 k mj P : (|k,mj={E1,E2}=> ◇ P) ⊢ |k,mj={E1,E2}=> P.
Proof. by rewrite {1}(fupd_split_level_intro E2 k mj P) except_0_fupd_split_level fupd_split_level_trans. Qed.

Global Instance from_assumption_fupd_split_level E k mj p P Q :
  FromAssumption p P (|==> Q) → KnownRFromAssumption p P (|k,mj={E}=> Q)%I.
Proof. rewrite /KnownRFromAssumption /FromAssumption=>->. apply bupd_fupd_split_level. Qed.

Global Instance from_pure_fupd_split_level a E k mj P φ :
  FromPure a P φ → FromPure a (|k,mj={E}=> P) φ.
Proof. rewrite /FromPure. intros <-. apply fupd_split_level_intro. Qed.

Lemma fupd_split_level_frame_l E1 E2 k mj R Q : (R ∗ |k,mj={E1,E2}=> Q) ⊢ |k,mj={E1,E2}=> R ∗ Q.
Proof. rewrite !(comm _ R). apply fupd_split_level_frame_r. Qed.
Lemma fupd_split_level_wand_l E1 E2 k mj P Q : (P -∗ Q) ∗ (|k,mj={E1,E2}=> P) ⊢ |k,mj={E1,E2}=> Q.
Proof. by rewrite fupd_split_level_frame_l wand_elim_l. Qed.
Lemma fupd_split_level_wand_r E1 E2 k mj P Q : (|k,mj={E1,E2}=> P) ∗ (P -∗ Q) ⊢ |k,mj={E1,E2}=> Q.
Proof. by rewrite fupd_split_level_frame_r wand_elim_r. Qed.

Lemma fupd_split_level_mask_weaken E1 E2 k mj P : E2 ⊆ E1 → P ⊢ |k,mj={E1,E2}=> P.
Proof.
  intros ?. rewrite -{1}(right_id emp%I bi_sep P%I).
  rewrite (fupd_split_level_intro_mask E1 E2 k mj emp%I) //.
  by rewrite fupd_split_level_frame_l sep_elim_l.
Qed.

Lemma fupd_split_level_mask_frame_r E1 E2 k mj Ef P :
  E1 ## Ef → (|k,mj={E1,E2}=> P) ⊢ |k,mj={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof.
  intros ?. rewrite -fupd_split_level_mask_frame_r' //. f_equiv.
  apply impl_intro_l, and_elim_r.
Qed.
Lemma fupd_split_level_mask_mono E1 E2 k mj P : E1 ⊆ E2 → (|k,mj={E1}=> P) ⊢ |k,mj={E2}=> P.
Proof.
  intros (Ef&->&?)%subseteq_disjoint_union_L. by apply fupd_split_level_mask_frame_r.
Qed.

Lemma fupd_split_level_sep E k mj P Q : (|k,mj={E}=> P) ∗ (|k,mj={E}=> Q) ⊢ |k,mj={E}=> P ∗ Q.
Proof. by rewrite fupd_split_level_frame_r fupd_split_level_frame_l fupd_split_level_trans. Qed.
Lemma fupd_split_level_mask_frame E E' E1 E2 k mj P :
  E1 ⊆ E →
  (|k,mj={E1,E2}=> |k,mj={E2 ∪ (E ∖ E1),E'}=> P) -∗ (|k,mj={E,E'}=> P).
Proof.
  intros ?. rewrite (fupd_split_level_mask_frame_r _ _ _ _ (E ∖ E1)); last set_solver.
  rewrite fupd_split_level_trans.
  by replace (E1 ∪ E ∖ E1) with E by (by apply union_difference_L).
Qed.

Global Instance into_wand_fupd_split_level E k mj p q R P Q :
  IntoWand false false R P Q →
  IntoWand p q (|k,mj={E}=> R) (|k,mj={E}=> P) (|k,mj={E}=> Q).
Proof.
  rewrite /IntoWand /= => HR. rewrite !intuitionistically_if_elim HR.
  apply wand_intro_l. by rewrite fupd_split_level_sep wand_elim_r.
Qed.

Global Instance into_wand_fupd_split_level_persistent E1 E2 k mj p q R P Q :
  IntoWand false q R P Q → IntoWand p q (|k,mj={E1,E2}=> R) P (|k,mj={E1,E2}=> Q).
Proof.
  rewrite /IntoWand /= => HR. rewrite intuitionistically_if_elim HR.
  apply wand_intro_l. by rewrite fupd_split_level_frame_l wand_elim_r.
Qed.

Global Instance into_wand_fupd_split_level_args E1 E2 k mj p q R P Q :
  IntoWand p false R P Q → IntoWand' p q R (|k,mj={E1,E2}=> P) (|k,mj={E1,E2}=> Q).
Proof.
  rewrite /IntoWand' /IntoWand /= => ->.
  apply wand_intro_l. by rewrite intuitionistically_if_elim fupd_split_level_wand_r.
Qed.

Global Instance from_sep_fupd_split_level E k mj P Q1 Q2 :
  FromSep P Q1 Q2 → FromSep (|k,mj={E}=> P) (|k,mj={E}=> Q1) (|k,mj={E}=> Q2).
Proof. rewrite /FromSep =><-. apply fupd_split_level_sep. Qed.

Global Instance from_or_fupd_split_level E1 E2 k mj P Q1 Q2 :
  FromOr P Q1 Q2 → FromOr (|k,mj={E1,E2}=> P) (|k,mj={E1,E2}=> Q1) (|k,mj={E1,E2}=> Q2).
Proof.
  rewrite /FromOr=><-. apply or_elim; apply fupd_split_level_mono;
                         [apply bi.or_intro_l|apply bi.or_intro_r].
Qed.

Global Instance from_exist_fupd_split_level {A} E1 k mj E2 P (Φ : A → iProp Σ) :
  FromExist P Φ → FromExist (|k,mj={E1,E2}=> P) (λ a, |k,mj={E1,E2}=> Φ a)%I.
Proof.
  rewrite /FromExist=><-. apply exist_elim=> a. by rewrite -(exist_intro a).
Qed.

(*
Global Instance from_forall_fupd_split_level E1 E2 k mj {A} P (Φ : A → iProp Σ) :
  (* Some cases in which [E2 ⊆ E1] holds *)
  TCOr (TCEq E1 E2) (TCOr (TCEq E1 ⊤) (TCEq E2 ∅)) →
  FromForall P Φ → (∀ x, Plain (Φ x)) →
  FromForall (|k,mj={E1,E2}=> P)%I (λ a, |k,mj={E1,E2}=> (Φ a))%I.
Proof.
  rewrite /FromForall=> -[->|[->|->]] <- ?; rewrite fupd_plain_forall; set_solver.
Qed.
*)

Global Instance except_0_fupd_split_level' E1 E2 k mj P :
  IsExcept0 (|k,mj={E1,E2}=> P).
Proof. by rewrite /IsExcept0 except_0_fupd_split_level. Qed.

Global Instance from_modal_fupd_split_level E k mj P :
  FromModal True modality_id (|k,mj={E}=> P) (|k,mj={E}=> P) P.
Proof. by rewrite /FromModal /= -fupd_split_level_intro. Qed.

Global Instance elim_modal_bupd_fupd_split_level p E1 E2 k mj P Q :
  ElimModal True p false (|==> P) P (|k,mj={E1,E2}=> Q) (|k,mj={E1,E2}=> Q) | 10.
Proof.
  by rewrite /ElimModal intuitionistically_if_elim
    (bupd_fupd_split_level E1 k mj) fupd_split_level_frame_r wand_elim_r fupd_split_level_trans.
Qed.
Global Instance elim_modal_fupd_split_level_fupd_split_level p E1 E2 E3 k mj P Q :
  ElimModal True p false (|k,mj={E1,E2}=> P) P (|k,mj={E1,E3}=> Q) (|k,mj={E2,E3}=> Q).
Proof.
  by rewrite /ElimModal intuitionistically_if_elim
    fupd_split_level_frame_r wand_elim_r fupd_split_level_trans.
Qed.

Global Instance elim_modal_fupd_level_fupd p E1 E2 E3 k P Q :
  ElimModal True p false (|(S k)={E1,E2}=> P) P (|={E1,E3}=> Q) (|={E2,E3}=> Q).
Proof.
  rewrite /ElimModal=>?. rewrite (fupd_level_fupd) intuitionistically_if_elim /=.
  iIntros "(>H&H2)". iApply ("H2" with "[$]").
Qed.

Global Instance elim_acc_fupd_split_level {X} E1 E2 E k mj α β mγ Q :
  ElimAcc (X:=X) True (uPred_fupd_split_level E1 E2 k mj) (uPred_fupd_split_level E2 E1 k mj) α β mγ
          (|k,mj={E1,E}=> Q)
          (λ x, |k,mj={E2}=> β x ∗ (mγ x -∗? |k,mj={E1,E}=> Q))%I.
Proof.
  rewrite /ElimAcc.
  iIntros (_) "Hinner >Hacc". iDestruct "Hacc" as (x) "[Hα Hclose]".
  iMod ("Hinner" with "Hα") as "[Hβ Hfin]".
  iMod ("Hclose" with "Hβ") as "Hγ". by iApply "Hfin".
Qed.

Global Instance frame_fupd_split_level p E1 E2 k mj R P Q :
  Frame p R P Q → Frame p R (|k,mj={E1,E2}=> P) (|k,mj={E1,E2}=> Q).
Proof. rewrite /Frame=><-. by rewrite fupd_split_level_frame_l. Qed.

Lemma fupd_split_level_mask_mono' E1 E2 E1' E2' k mj P : E1 ⊆ E2 → E2' ⊆ E1' → (|k,mj={E1, E1'}=> P) ⊢ |k,mj={E2,E2'}=> P.
Proof.
  iIntros (??) "H".
  iMod (fupd_split_level_intro_mask' _ E1) as "Hclo"; auto.
  iMod "H".
  iApply (fupd_split_level_mask_weaken); auto.
Qed.

End fupd_split_level.

Section schema_test_fupd.
Context `{!invGS Σ}.
Implicit Types P : iProp Σ.

Definition bi_sch_False : bi_schema := bi_sch_pure False.

Definition bi_sch_except_0 (P: bi_schema) : bi_schema :=
  bi_sch_or (bi_sch_later (bi_sch_False)) P.

Definition bi_sch_bupd_wand (P1 P2: bi_schema) :=
  bi_sch_wand P1 (bi_sch_bupd P2).

Definition bi_sch_fupd_mj E1 E2 mj (P: bi_schema) : bi_schema :=
  bi_sch_bupd_wand
    (bi_sch_sep (bi_sch_wsat) (bi_sch_ownE (λ k, AE k mj ∪ MaybeEn1 E1)))
    (bi_sch_except_0 (bi_sch_sep (bi_sch_wsat)
                                (bi_sch_sep (bi_sch_ownE (λ k, AE k mj ∪ MaybeEn1 E2)) P))).

Definition bi_sch_fupd E1 E2 (P: bi_schema) : bi_schema :=
  bi_sch_bupd_wand
    (bi_sch_sep (bi_sch_wsat) (bi_sch_ownE (λ k, AE k (Some O) ∪ MaybeEn1 E1)))
    (bi_sch_except_0 (bi_sch_sep (bi_sch_wsat)
                                (bi_sch_sep (bi_sch_ownE (λ k, AE k (Some O) ∪ MaybeEn1 E2)) P))).

Lemma bi_sch_fupd_interp' E1 E2 lvl Qs Qs_mut Psch P:
  bi_schema_interp lvl Qs Qs_mut Psch = P →
  bi_schema_interp lvl Qs Qs_mut (bi_sch_fupd E1 E2 Psch) =
    (wsat lvl ∗ ownE (AE lvl (Some 0) ∪ MaybeEn1 E1) ==∗ ◇ (wsat lvl ∗ ownE (AE lvl (Some 0) ∪ MaybeEn1 E2) ∗ P))%I.
Proof.
  intros Heq.
  rewrite ?bi_schema_interp_unfold //=.
  do 11 (rewrite {1}bi_schema_interp_unfold //=).
  rewrite Heq. rewrite ?bi_schema_interp_unfold //=.
Qed.

Lemma bi_sch_fupd_interp E1 E2 lvl Qs Qs_mut Psch P:
  bi_schema_interp (S lvl) Qs Qs_mut Psch = P →
  bi_schema_interp (S lvl) Qs Qs_mut (bi_sch_fupd E1 E2 Psch) =
  (|lvl,(Some 0)={E1, E2}=> P)%I.
Proof.
  intros Heq. rewrite uPred_fupd_split_level_eq. by apply bi_sch_fupd_interp'.
Qed.

Lemma bi_sch_fupd_interp_mj' E1 E2 lvl mj Qs Qs_mut Psch P:
  bi_schema_interp lvl Qs Qs_mut Psch = P →
  bi_schema_interp lvl Qs Qs_mut (bi_sch_fupd_mj E1 E2 mj Psch) =
    (wsat lvl ∗ ownE (AE lvl mj ∪ MaybeEn1 E1) ==∗ ◇ (wsat lvl ∗ ownE (AE lvl mj ∪ MaybeEn1 E2) ∗ P))%I.
Proof.
  intros Heq.
  rewrite ?bi_schema_interp_unfold //=.
  do 11 (rewrite {1}bi_schema_interp_unfold //=).
  rewrite Heq. rewrite ?bi_schema_interp_unfold //=.
Qed.

Lemma bi_sch_fupd_interp_mj E1 E2 lvl mj Qs Qs_mut Psch P:
  bi_schema_interp (S lvl) Qs Qs_mut Psch = P →
  bi_schema_interp (S lvl) Qs Qs_mut (bi_sch_fupd_mj E1 E2 mj Psch) =
  (|lvl,mj={E1, E2}=> P)%I.
Proof.
  intros Heq. rewrite uPred_fupd_split_level_eq. by apply bi_sch_fupd_interp_mj'.
Qed.

End schema_test_fupd.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals Omega Psatz.
Require Import mathcomp.ssreflect.ssreflect.
Require Import Rcomplements Hierarchy Continuity Derive.

(** This file describes results about differentiability in [R x
 R]. This includes the [Schwarz] theorem and the 2D Taylor-Lagrange
 inequality. *)

(** * Differentiability *)

Definition differentiable_pt_lim (f : R -> R -> R) (x y : R) (lx ly : R) :=
  forall eps : posreal, locally_2d (fun u v =>
    Rabs (f u v - f x y - (lx * (u - x) + ly * (v - y))) <= eps * Rmax (Rabs (u - x)) (Rabs (v - y))) x y.

Lemma filterdiff_differentiable_pt_lim (f : R -> R -> R) (x y lx ly : R) :
  filterdiff (fun u : R * R => f (fst u) (snd u)) (locally (x,y)) (fun u : R * R => fst u * lx + snd u * ly)
  <-> differentiable_pt_lim f x y lx ly.
Proof.
  split => Df.
  move => eps.
  case: Df => _ Df.
  assert (is_filter_lim (locally (x, y)) (x, y)) by now intro.
  specialize (Df (x,y) H) => {H}.
  apply locally_2d_locally.
  assert (0 < eps / sqrt 2).
    apply Rdiv_lt_0_compat.
    by apply eps.
    by apply Rlt_sqrt2_0.
  move: (Df (mkposreal _ H)).
  apply filter_imp => [[u v] /= Huv].
  rewrite !(Rmult_comm _ (_-_)).
  eapply Rle_trans.
  apply Huv.
  rewrite Rmult_assoc.
  apply Rmult_le_compat_l.
  by apply Rlt_le, eps.
  rewrite Rmult_comm Rle_div_l.
  rewrite Rmult_comm.
  eapply Rle_trans.
  apply norm_prod.
  apply Rle_refl.
  by apply Rlt_sqrt2_0.

  split.
  apply (is_linear_comp (fun u : R * R => (scal (fst u) lx,scal (snd u) ly))
                          (fun u : R * R => plus (fst u) (snd u))).
  apply is_linear_prod.
  apply (is_linear_comp (@fst _ _) (fun t : R => scal t lx)).
  by apply is_linear_fst.
  by apply @is_linear_scal_l.
  apply (is_linear_comp (@snd _ _) (fun t : R => scal t ly)).
  by apply is_linear_snd.
  by apply @is_linear_scal_l.
  by apply @is_linear_plus.
  simpl => u Hu.
  replace u with (x,y) by now apply is_filter_lim_locally_unique.
  move => {u Hu} eps /=.
  move: (proj1 (locally_2d_locally _ _ _) (Df eps)).
  apply filter_imp => [[u v]] /= Huv.
  rewrite !(Rmult_comm (_-_)).
  eapply Rle_trans.
  apply Huv.
  apply Rmult_le_compat_l.
  by apply Rlt_le, eps.
  apply (norm_prod (u - x) (v - y)).
Qed.

Lemma differentiable_pt_lim_ext : forall f1 f2 x y lx ly,
  locally_2d (fun u v => f1 u v = f2 u v) x y ->
  differentiable_pt_lim f1 x y lx ly -> differentiable_pt_lim f2 x y lx ly.
Proof.
  intros f1 f2 x y lx ly H H1 eps.
  apply: locally_2d_impl (H1 eps) => {H1}.
  rewrite (locally_2d_singleton _ _ _ H).
  apply: locally_2d_impl H.
  apply locally_2d_forall.
  now intros u v ->.
Qed.

Definition differentiable_pt (f : R -> R -> R) (x y : R) :=
  exists lx, exists ly, differentiable_pt_lim f x y lx ly.

Lemma differentiable_continuity_pt : forall f x y,
  differentiable_pt f x y -> continuity_2d_pt f x y.
Proof.
  intros f x y (l1&l2&Df) eps ; simpl in Df.
  assert (0 < eps / 2).
    apply Rdiv_lt_0_compat ; [apply eps|apply Rlt_R0_R2].
    set (eps' := mkposreal _ H).
  elim (Df eps') ; clear Df ; intros d0 Df.
  assert (0 < Rmin (Rmin d0 1) (Rmin (eps/(4*Rmax (Rabs l1) 1)) (eps / (4* Rmax (Rabs l2) 1)))).
    apply Rmin_pos ; apply Rmin_pos.
    apply d0.
    apply Rlt_0_1.
    apply Rdiv_lt_0_compat.
    apply eps.
    apply Rmult_lt_0_compat.
    apply Rmult_lt_0_compat ; apply Rlt_R0_R2.
    apply (Rlt_le_trans _ _ _ Rlt_0_1 (RmaxLess2 _ _)).
    apply Rdiv_lt_0_compat.
    apply eps.
    apply Rmult_lt_0_compat.
    apply Rmult_lt_0_compat ; apply Rlt_R0_R2.
    apply (Rlt_le_trans _ _ _ Rlt_0_1 (RmaxLess2 _ _)).
    set (delta := mkposreal _ H0).
  exists delta ; intros x' y' H1 H2.
  rewrite (double_var eps).
  apply (Rle_lt_trans _ (Rabs (f x' y' - f x y - (l1 * (x' - x) + l2 * (y' - y)))
    + Rabs (l1 * (x' - x) + l2 * (y' - y)))).
    assert (Rabs (f x' y' - f x y) =
      Rabs ((f x' y' - f x y - (l1 * (x' - x) + l2 * (y' - y))) +
      (l1 * (x' - x) + l2 * (y' - y)))).
      assert ((f x' y' - f x y) =
        (f x' y' - f x y - (l1 * (x' - x) + l2 * (y' - y)) +
        (l1 * (x' - x) + l2 * (y' - y)))).
        ring.
      rewrite <- H3 ; clear H3 ; reflexivity.
    rewrite H3 ; clear H3 ; apply Rabs_triang.
  apply Rplus_lt_le_compat.
  apply (Rle_lt_trans _ (eps' * Rmax (Rabs (x' - x)) (Rabs (y' - y)))).
  apply Df.
  apply (Rlt_le_trans _ _ _ H1) ; unfold delta ; simpl ;
  apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_l _ _)).
  apply (Rlt_le_trans _ _ _ H2) ; unfold delta ; simpl ;
  apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_l _ _)).
  rewrite <- (Rmult_1_r (eps/2)) ; unfold eps' ; simpl.
  apply Rmult_lt_compat_l.
  apply H.
  apply (Rlt_le_trans _ delta).
  apply (Rmax_lub_lt _ _ _ H1 H2).
  unfold delta ; simpl ;
  apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_r _ _)).
  apply (Rle_trans _ (Rabs l1 * Rabs (x'-x) + Rabs l2 * Rabs (y'-y))).
    repeat rewrite <- Rabs_mult.
    apply Rabs_triang.
  rewrite (double_var (eps/2)).
  apply Rplus_le_compat.
  apply (Rle_trans _ (Rabs l1 * delta)).
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply Rlt_le, H1.
  apply (Rle_trans _ (Rabs l1 * (Rmin (eps / (4 * Rmax (Rabs l1) 1))
                     (eps / (4 * Rmax (Rabs l2) 1))))).
    apply Rmult_le_compat_l ; unfold delta ; simpl ; [apply Rabs_pos| apply Rmin_r].
  apply (Rle_trans _ (Rabs l1 * (eps / (4 * Rmax (Rabs l1) 1)))).
  apply Rmult_le_compat_l ; [apply Rabs_pos | apply Rmin_l].
  unfold Rmax ; destruct (Rle_dec (Rabs l1) 1).
  rewrite <- (Rmult_1_l (eps/2/2)).
  apply Rmult_le_compat.
  apply Rabs_pos.
  apply Rlt_le, Rdiv_lt_0_compat ;
  [apply eps | apply Rmult_lt_0_compat ;
  [apply Rmult_lt_0_compat ; apply Rlt_R0_R2|apply Rlt_0_1]].
  apply r.
  apply Req_le ; field.
  apply Req_le ; field.
  apply Rnot_le_lt in n.
  apply sym_not_eq, Rlt_not_eq, (Rlt_trans _ _ _ Rlt_0_1 n).

  apply (Rle_trans _ (Rabs l2 * delta)).
  apply Rmult_le_compat_l.
  apply Rabs_pos.
  apply Rlt_le, H2.
  apply (Rle_trans _ (Rabs l2 * (Rmin (eps / (4 * Rmax (Rabs l1) 1))
                     (eps / (4 * Rmax (Rabs l2) 1))))).
    apply Rmult_le_compat_l ; unfold delta ; simpl ; [apply Rabs_pos| apply Rmin_r].
  apply (Rle_trans _ (Rabs l2 * (eps / (4 * Rmax (Rabs l2) 1)))).
  apply Rmult_le_compat_l ; [apply Rabs_pos | apply Rmin_r].
  unfold Rmax ; destruct (Rle_dec (Rabs l2) 1).
  rewrite <- (Rmult_1_l (eps/2/2)).
  apply Rmult_le_compat.
  apply Rabs_pos.
  apply Rlt_le, Rdiv_lt_0_compat ;
  [apply eps | apply Rmult_lt_0_compat ;
  [apply Rmult_lt_0_compat ; apply Rlt_R0_R2|apply Rlt_0_1]].
  apply r.
  apply Req_le ; field.
  apply Req_le ; field.
  apply Rnot_le_lt in n.
  apply sym_not_eq, Rlt_not_eq, (Rlt_trans _ _ _ Rlt_0_1 n).
Qed.

Lemma differentiable_pt_lim_proj1_0 (f : R -> R) (x y l : R) :
  derivable_pt_lim f x l -> differentiable_pt_lim (fun u v => f u) x y l 0.
Proof.
  intros Df eps.
  apply is_derive_Reals in Df ;
  elim (proj2 Df x (fun P H => H) eps) ; clear Df ; intros delta Df.
  exists delta ; simpl ; intros.
  rewrite Rmult_0_l Rplus_0_r.
  apply (Rle_trans _ (eps * Rabs (u - x))).
  rewrite Rmult_comm ; apply (Df _ H).
  apply Rmult_le_compat_l.
  apply Rlt_le, eps.
  apply RmaxLess1.
Qed.

Lemma differentiable_pt_lim_proj1_1 (f : R -> R) (x y l : R) :
  differentiable_pt_lim (fun u v => f u) x y l 0 -> derivable_pt_lim f x l.
Proof.
  intros Df.
  apply is_derive_Reals ; split => [ | z Hz eps].
    by apply @is_linear_scal_l.
  rewrite -(is_filter_lim_locally_unique _ _ Hz) => {z Hz}.
  elim (Df eps) ; clear Df ; intros delta Df.
  exists delta ; simpl in Df ; simpl ; intros.
  rewrite /minus /plus /opp /scal /= /mult /=.
  replace (f y0 + - f x + - ((y0 + - x) * l)) with (f y0 - f x - (l * (y0 - x) + 0 * (y - y))) by ring.
  assert (Rabs (y0 - x) = Rmax (Rabs (y0 - x)) (Rabs (y-y))).
    rewrite Rmax_comm ; apply sym_equal, Rmax_right.
    rewrite Rminus_eq_0 Rabs_R0 ; apply Rabs_pos.
  rewrite /norm /= /abs /=.
  rewrite H0 ; clear H0.
  apply (Df _ _ H).
  rewrite Rminus_eq_0 Rabs_R0 ; apply delta.
Qed.

Lemma differentiable_pt_lim_unique (f : R -> R -> R) (x y : R) (lx ly : R) :
  differentiable_pt_lim f x y lx ly
    -> Derive (fun x => f x y) x = lx /\ Derive (fun y => f x y) y = ly.
Proof.
  move => Df ; split ; apply is_derive_unique, is_derive_Reals => e He ;
  case: (Df (pos_div_2 (mkposreal e He))) => {Df} delta /= Df ;
  exists delta => h Hh0 Hh.

  replace ((f (x + h) y - f x y) / h - lx)
    with ((f (x+h) y - f x y - (lx * ((x+h) - x) + ly * (y - y))) / h)
    by (by field).
  rewrite Rabs_div.
  apply Rlt_div_l.
  by apply Rabs_pos_lt.
  apply Rle_lt_trans with (e / 2 * Rmax (Rabs (x + h - x)) (Rabs (y - y))).
  apply (Df (x+h) y).
  by (ring_simplify (x + h - x)).
  rewrite Rminus_eq_0 Rabs_R0 ; by apply delta.
  ring_simplify (x + h - x).
  rewrite Rmax_left.
  apply Rmult_lt_compat_r.
  by apply Rabs_pos_lt.
  lra.
  rewrite Rminus_eq_0 Rabs_R0 ; by apply Rabs_pos.
  by [].

  replace ((f x (y + h) - f x y) / h - ly)
    with ((f x (y + h) - f x y - (lx * (x - x) + ly * ((y + h) - y))) / h)
    by (by field).
  rewrite Rabs_div.
  apply Rlt_div_l.
  by apply Rabs_pos_lt.
  apply Rle_lt_trans with (e / 2 * Rmax (Rabs (x - x)) (Rabs (y + h - y))).
  apply (Df x (y + h)).
  rewrite Rminus_eq_0 Rabs_R0 ; by apply delta.
  by (ring_simplify (y + h - y)).
  ring_simplify (y + h - y).
  rewrite Rmax_right.
  apply Rmult_lt_compat_r.
  by apply Rabs_pos_lt.
  lra.
  rewrite Rminus_eq_0 Rabs_R0 ; by apply Rabs_pos.
  by [].
Qed.

(** * Operations *)

Lemma differentiable_pt_lim_comp : forall f1 f2 f3 x y l1x l1y l2x l2y l3x l3y,
  differentiable_pt_lim f1 (f2 x y) (f3 x y) l1x l1y ->
  differentiable_pt_lim f2 x y l2x l2y -> differentiable_pt_lim f3 x y l3x l3y ->
  differentiable_pt_lim (fun u v => f1 (f2 u v) (f3 u v)) x y
    (l1x * l2x + l1y * l3x) (l1x * l2y + l1y * l3y).
Proof.
  intros f1 f2 f3 x y l1_1 l1_2 l2_1 l2_2 l3_1 l3_2
    Df1 Df2 Df3 eps ; simpl.
  assert (Cf2 : continuity_2d_pt f2 x y).
    apply differentiable_continuity_pt.
    exists l2_1 ; exists l2_2 ; apply Df2.
  assert (Cf3 : continuity_2d_pt f3 x y).
    apply differentiable_continuity_pt.
    exists l3_1 ; exists l3_2 ; apply Df3.
  assert (He2 : 0 < eps / (4 * Rmax (Rabs l1_1) 1)).
    apply Rdiv_lt_0_compat ;
    [apply eps | apply Rmult_lt_0_compat].
    apply Rmult_lt_0_compat ; apply Rlt_R0_R2.
    apply (Rlt_le_trans _ _ _ Rlt_0_1 (RmaxLess2 _ _)).
    set (eps2 := mkposreal _ He2).
  assert (He3 : 0 < eps / (4 * Rmax (Rabs l1_2) 1)).
    apply Rdiv_lt_0_compat ;
    [apply eps | apply Rmult_lt_0_compat].
    apply Rmult_lt_0_compat ; apply Rlt_R0_R2.
    apply (Rlt_le_trans _ _ _ Rlt_0_1 (RmaxLess2 _ _)).
    set (eps3 := mkposreal _ He3).
  assert (He1 : 0 < eps / (2 * Rmax (eps2 + Rabs l2_1 + Rabs l2_2)
    (eps3 + Rabs l3_1 + Rabs l3_2))).
    apply Rdiv_lt_0_compat ; [apply eps | apply Rmult_lt_0_compat].
    apply Rlt_R0_R2.
    apply (Rlt_le_trans _ (eps2 + Rabs l2_1 + Rabs l2_2)).
    rewrite Rplus_assoc ; apply Rplus_lt_le_0_compat.
    apply eps2.
    apply Rplus_le_le_0_compat ; apply Rabs_pos.
    apply RmaxLess1.
    set (eps1 := mkposreal _ He1).
  elim (Df1 eps1) ; clear Df1 ; intros d0 Df1.
    elim (Cf2 d0) ; clear Cf2 ; intros d1 Cf2.
    elim (Cf3 d0) ; clear Cf3 ; intros d'1 Cf3.
  elim (Df2 eps2) ; clear Df2 ; intros d2 Df2.
  elim (Df3 eps3) ; clear Df3 ; intros d3 Df3.
  assert (Hd : 0 < Rmin (Rmin d1 d'1) (Rmin d2 d3)).
    apply Rmin_pos ; apply Rmin_pos ;
    [apply d1 | apply d'1 | apply d2 | apply d3].
    set (delta := mkposreal _ Hd).
  exists delta ; intros x' y' ; intros.
  apply (Rle_trans _ (Rabs (f1 (f2 x' y') (f3 x' y') - f1 (f2 x y) (f3 x y) -
    (l1_1 * (f2 x' y' - f2 x y) + l1_2 * (f3 x' y' - f3 x y)))
    + Rabs (l1_1 * (f2 x' y' - f2 x y) + l1_2 * (f3 x' y' - f3 x y) -
    ((l1_1 * l2_1 + l1_2 * l3_1) * (x' - x) + (l1_1 * l2_2 + l1_2 * l3_2) * (y' - y))))).
    replace ((f1 (f2 x' y') (f3 x' y') - f1 (f2 x y) (f3 x y) -
      ((l1_1 * l2_1 + l1_2 * l3_1) * (x' - x) +
      (l1_1 * l2_2 + l1_2 * l3_2) * (y' - y)))) with
      ((f1 (f2 x' y') (f3 x' y') - f1 (f2 x y) (f3 x y) -
      (l1_1 * (f2 x' y' - f2 x y) + l1_2 * (f3 x' y' - f3 x y))) +
      (l1_1 * (f2 x' y' - f2 x y) + l1_2 * (f3 x' y' - f3 x y) -
      ((l1_1 * l2_1 + l1_2 * l3_1) * (x' - x) +
      (l1_1 * l2_2 + l1_2 * l3_2) * (y' - y)))) by ring.
    apply Rabs_triang.
  rewrite (double_var eps) (Rmult_plus_distr_r (eps/2)).
  apply Rplus_le_compat.
  apply (Rle_trans _ (eps1 * Rmax (Rabs (f2 x' y' - f2 x y)) (Rabs (f3 x' y' - f3 x y)))).
    apply Df1.
    apply Cf2.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_l _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_l _ _)).
    apply Cf3.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_r _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_l _ _) (Rmin_r _ _)).
  apply (Rle_trans _ (eps1 * (Rmax (eps2 + Rabs l2_1 + Rabs l2_2)
    (eps3 + Rabs l3_1 + Rabs l3_2) * Rmax (Rabs (x'-x)) (Rabs (y'-y))))).
    apply Rmult_le_compat_l.
    apply Rlt_le, eps1.
    rewrite Rmax_mult.
    apply Rmax_le_compat.
    rewrite Rplus_assoc Rmult_plus_distr_r.
    apply (Rle_trans _ (Rabs (f2 x' y' - f2 x y - (l2_1 * (x' - x) + l2_2 * (y' - y)))
      + Rabs (l2_1 * (x' - x) + l2_2 * (y' - y)))).
      assert (Rabs (f2 x' y' - f2 x y) =
      Rabs ((f2 x' y' - f2 x y - (l2_1 * (x' - x) + l2_2 * (y' - y))) +
      (l2_1 * (x' - x) + l2_2 * (y' - y)))).
      assert ((f2 x' y' - f2 x y) =
      ((f2 x' y' - f2 x y - (l2_1 * (x' - x) + l2_2 * (y' - y))) +
      (l2_1 * (x' - x) + l2_2 * (y' - y)))).
      ring.
      rewrite <- H1 ; clear H1 ; reflexivity.
    rewrite H1 ; clear H1 ; apply Rabs_triang.
    apply Rplus_le_compat.
    apply Df2.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_l _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_l _ _)).
    apply (Rle_trans _ (Rabs l2_1 * Rabs (x'-x) + Rabs l2_2 * Rabs (y'-y))).
      repeat rewrite <- Rabs_mult ; apply Rabs_triang.
      rewrite Rmult_plus_distr_r.
      apply Rplus_le_compat ; apply Rmult_le_compat_l.
      apply Rabs_pos.
      apply RmaxLess1.
      apply Rabs_pos.
      apply RmaxLess2.
  rewrite Rplus_assoc Rmult_plus_distr_r.
  apply (Rle_trans _ (Rabs (f3 x' y' - f3 x y - (l3_1 * (x' - x) + l3_2 * (y' - y)))
      + Rabs (l3_1 * (x' - x) + l3_2 * (y' - y)))).
      assert (Rabs (f3 x' y' - f3 x y) =
      Rabs ((f3 x' y' - f3 x y - (l3_1 * (x' - x) + l3_2 * (y' - y))) +
      (l3_1 * (x' - x) + l3_2 * (y' - y)))).
      assert ((f3 x' y' - f3 x y) =
      ((f3 x' y' - f3 x y - (l3_1 * (x' - x) + l3_2 * (y' - y))) +
      (l3_1 * (x' - x) + l3_2 * (y' - y)))).
      ring.
      rewrite <- H1 ; clear H1 ; reflexivity.
    rewrite H1 ; clear H1 ; apply Rabs_triang.
    apply Rplus_le_compat.
    apply Df3.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_r _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_r _ _)).
    apply (Rle_trans _ (Rabs l3_1 * Rabs (x'-x) + Rabs l3_2 * Rabs (y'-y))).
      repeat rewrite <- Rabs_mult ; apply Rabs_triang.
      rewrite Rmult_plus_distr_r.
      apply Rplus_le_compat ; apply Rmult_le_compat_l.
      apply Rabs_pos.
      apply RmaxLess1.
      apply Rabs_pos.
      apply RmaxLess2.
  apply (Rle_trans _ _ _ (Rabs_pos _) (RmaxLess1 _ _)).
  simpl ; apply Req_le ; field.
  apply sym_not_eq, Rlt_not_eq, (Rlt_le_trans _ (eps2 + Rabs l2_1 + Rabs l2_2)).
  rewrite Rplus_assoc ; apply Rplus_lt_le_0_compat.
  apply eps2.
  apply Rplus_le_le_0_compat ; apply Rabs_pos.
  apply RmaxLess1.
  rewrite (double_var (eps/2)) (Rmult_plus_distr_r (eps/2/2)).
  apply (Rle_trans _ (Rabs l1_1 * Rabs (f2 x' y' - f2 x y - (l2_1 * (x' - x) + l2_2 * (y' - y)))
    + Rabs l1_2 * Rabs (f3 x' y' - f3 x y - (l3_1 * (x' - x) + l3_2 * (y' - y))))).
    repeat rewrite <- Rabs_mult.
    assert ((l1_1 * (f2 x' y' - f2 x y) + l1_2 * (f3 x' y' - f3 x y) -
      ((l1_1 * l2_1 + l1_2 * l3_1) * (x' - x) +
      (l1_1 * l2_2 + l1_2 * l3_2) * (y' - y))) =
      (l1_1 * (f2 x' y' - f2 x y - (l2_1 * (x' - x) + l2_2 * (y' - y)))) +
      (l1_2 * (f3 x' y' - f3 x y - (l3_1 * (x' - x) + l3_2 * (y' - y))))).
      ring.
    rewrite H1 ; clear H1 ; apply Rabs_triang.
  apply Rplus_le_compat.
  apply (Rle_trans _ (Rabs l1_1 * (eps2 * Rmax (Rabs (x' - x)) (Rabs (y' - y))))).
    apply Rmult_le_compat_l.
    apply Rabs_pos.
    apply Df2.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_l _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_l _ _)).
    rewrite <- Rmult_assoc ; apply Rmult_le_compat_r.
    apply (Rle_trans _ _ _ (Rabs_pos _) (RmaxLess1 _ _)).
    unfold eps2, Rmax ; simpl ; destruct (Rle_dec (Rabs l1_1) 1).
    rewrite <- (Rmult_1_l (eps/2/2)) ; apply Rmult_le_compat.
    apply Rabs_pos.
    rewrite Rmult_1_r ; apply Rlt_le, Rdiv_lt_0_compat ;
    [apply eps | apply Rmult_lt_0_compat ; apply Rlt_R0_R2].
    apply r.
    apply Req_le ; field.
    apply Req_le ; field.
    apply sym_not_eq, Rlt_not_eq, (Rlt_trans _ _ _ Rlt_0_1 (Rnot_le_lt _ _ n)).
  apply (Rle_trans _ (Rabs l1_2 * (eps3 * Rmax (Rabs (x' - x)) (Rabs (y' - y))))).
    apply Rmult_le_compat_l.
    apply Rabs_pos.
    apply Df3.
    apply (Rlt_le_trans _ _ _ H) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_r _ _)).
    apply (Rlt_le_trans _ _ _ H0) ; simpl ;
    apply (Rle_trans _ _ _ (Rmin_r _ _) (Rmin_r _ _)).
    rewrite <- Rmult_assoc ; apply Rmult_le_compat_r.
    apply (Rle_trans _ _ _ (Rabs_pos _) (RmaxLess1 _ _)).
    unfold eps3, Rmax ; simpl ; destruct (Rle_dec (Rabs l1_2) 1).
    rewrite <- (Rmult_1_l (eps/2/2)) ; apply Rmult_le_compat.
    apply Rabs_pos.
    rewrite Rmult_1_r ; apply Rlt_le, Rdiv_lt_0_compat ;
    [apply eps | apply Rmult_lt_0_compat ; apply Rlt_R0_R2].
    apply r.
    apply Req_le ; field.
    apply Req_le ; field.
    apply sym_not_eq, Rlt_not_eq, (Rlt_trans _ _ _ Rlt_0_1 (Rnot_le_lt _ _ n)).
Qed.

Lemma derivable_pt_lim_comp_2d : forall f1 f2 f3 x l1x l1y l2 l3,
  differentiable_pt_lim f1 (f2 x) (f3 x) l1x l1y ->
  derivable_pt_lim f2 x l2 -> derivable_pt_lim f3 x l3 ->
  derivable_pt_lim (fun t => f1 (f2 t) (f3 t)) x (l1x * l2 + l1y * l3).
Proof.
  intros.
  apply (differentiable_pt_lim_proj1_1 _ x 0 (l1x * l2 + l1y * l3)).
  pattern 0 at 2 ; replace 0 with (l1x * 0 + l1y * 0) by ring.
  apply differentiable_pt_lim_comp.
  apply H.
  apply: differentiable_pt_lim_proj1_0 H0.
  apply: differentiable_pt_lim_proj1_0 H1.
Qed.

(** * Partial derivatives *)

Definition partial_derive (m k : nat) (f : R -> R -> R) : R -> R -> R :=
  fun x y => Derive_n (fun t => Derive_n (fun z => f t z) k y) m x.

Definition differential (p : nat) (f : R -> R -> R) (x y dx dy : R) : R :=
  sum_f_R0
    (fun m =>
      C p m *
      partial_derive m (p - m)%nat f x y *
      dx ^ m * dy ^ (p - m)%nat)
    p.

Definition DL_pol (n : nat) (f : R -> R -> R) (x y dx dy : R) : R :=
  sum_f_R0
    (fun p =>
      differential p f x y dx dy / INR (fact p))
    n.

Lemma partial_derive_ext_loc :
  forall f g p q x y,
  locally_2d (fun u v => f u v = g u v) x y ->
  partial_derive p q f x y = partial_derive p q g x y.
Proof.
intros f g p q x y H.
unfold partial_derive.
apply Derive_n_ext_loc.
destruct H as (e,He).
exists e.
intros u Hu.
apply Derive_n_ext_loc.
exists e.
intros v Hv.
now apply He.
Qed.

(** * Schwarz theorem *)

Lemma Schwarz_aux :
  forall f x y (eps : posreal),
  ( forall u v, Rabs (u - x) < eps -> Rabs (v - y) < eps ->
    ex_derive (fun z : R => f z v) u /\
    ex_derive (fun z : R => Derive (fun t => f t z) u) v ) ->
  forall h k, Rabs h < eps -> Rabs k < eps ->
  let phi k x := f x (y + k) - f x y in
  exists u, exists v,
  Rabs (u - x) <= Rabs h /\ Rabs (v - y) <= Rabs k /\
  phi k (x + h) - phi k x = h * k * (Derive (fun z => Derive (fun t => f t z) u) v).
Proof.
intros f x y eps HD h k Hh Hk phi.
assert (Hx: x + h - x = h) by ring.
assert (Hy: y + k - y = k) by ring.
(* . *)
destruct (MVT_cor4 (phi k) (Derive (phi k)) x (Rabs h)) with (b := x + h) as (u&Hu1&Hu2).
intros c Hc.
apply Derive_correct.
apply: ex_derive_minus.
apply (HD c).
now apply Rle_lt_trans with (Rabs h).
now rewrite Hy.
apply (HD c).
now apply Rle_lt_trans with (Rabs h).
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
rewrite Hx.
apply Rle_refl.
rewrite Hx in Hu1, Hu2.
exists u.
(* . *)
destruct (MVT_cor4 (fun v => Derive (fun t => f t v) u) (Derive (fun v => Derive (fun t => f t v) u)) y (Rabs k)) with (b := y + k) as (v&Hv1&Hv2).
intros c Hc.
apply Derive_correct, HD.
now apply Rle_lt_trans with (Rabs h).
now apply Rle_lt_trans with (1 := Hc).
rewrite Hy.
apply Rle_refl.
rewrite Hy in Hv1, Hv2.
exists v.
(* . *)
refine (conj Hu2 (conj Hv2 _)).
rewrite Hu1 /phi Derive_minus.
rewrite Hv1.
ring.
apply (HD u).
now apply Rle_lt_trans with (Rabs h).
now rewrite Hy.
apply (HD u).
now apply Rle_lt_trans with (Rabs h).
rewrite /Rminus Rplus_opp_r Rabs_R0.
apply cond_pos.
Qed.

Lemma Schwarz :
  forall (f : R -> R -> R) x y,
  locally_2d (fun u v =>
    ex_derive (fun z : R => f z v) u /\
    ex_derive (fun z : R => f u z) v /\
    ex_derive (fun z : R => Derive (fun t => f z t) v) u /\
    ex_derive (fun z : R => Derive (fun t => f t z) u) v) x y ->
  continuity_2d_pt (fun u v => Derive (fun z => Derive (fun t => f z t) v) u) x y ->
  continuity_2d_pt (fun u v => Derive (fun z => Derive (fun t => f t z) u) v) x y ->
  Derive (fun z => Derive (fun t => f z t) y) x = Derive (fun z => Derive (fun t => f t z) x) y.
Proof.
intros f x y (eps, HD) HC2 HC1.
refine ((fun H1 => _) (Schwarz_aux f x y eps _)).
2: intros u v Hu Hv ; split ; now apply (HD u v).
refine ((fun H2 => _ )(Schwarz_aux (fun x y => f y x) y x eps _)).
2: intros u v Hu Hv ; split ; now apply (HD v u).
simpl in H1, H2.
apply Req_lt_aux.
intros e.
destruct (HC1 (pos_div_2 e)) as (d1,Hc1).
destruct (HC2 (pos_div_2 e)) as (d2,Hc2).
set (d := Rmin (Rmin (pos_div_2 d1) (pos_div_2 d2)) (pos_div_2 eps)).
assert (Hd: d > 0).
apply Rmin_glb_lt.
apply Rmin_stable_in_posreal.
apply cond_pos.
assert (K: Rabs d < eps).
rewrite Rabs_right.
apply Rle_lt_trans with (1 := Rmin_r _ _).
apply (Rlt_eps2_eps eps).
apply cond_pos.
now apply Rgt_ge.
specialize (H1 d d K K).
specialize (H2 d d K K).
destruct H1 as (u1&v1&Hu1&Hv1&H1).
destruct H2 as (v2&u2&Hv2&Hu2&H2).
clear K.
rewrite (Rabs_right d (Rgt_ge _ _ Hd)) in Hu1 Hv1 Hu2 Hv2.
assert (K: forall a b, Rabs (a - b) <= d -> Rabs (a - b) < d1).
intros a b H.
apply Rle_lt_trans with (1 := H).
apply Rle_lt_trans with (1 := Rmin_l _ _).
apply Rle_lt_trans with (1 := Rmin_l _ _).
apply (Rlt_eps2_eps d1).
apply cond_pos.
specialize (Hc1 u1 v1 (K _ _ Hu1) (K _ _ Hv1)).
clear K.
assert (K: forall a b, Rabs (a - b) <= d -> Rabs (a - b) < d2).
intros a b H.
apply Rle_lt_trans with (1 := H).
apply Rle_lt_trans with (1 := Rmin_l _ _).
apply Rle_lt_trans with (1 := Rmin_r _ _).
apply (Rlt_eps2_eps d2).
apply cond_pos.
specialize (Hc2 u2 v2 (K _ _ Hu2) (K _ _ Hv2)).
clear -Hd H1 H2 Hc1 Hc2.
assert (H: forall a b c, b - c = -(a - b) + (a - c)) by (intros ; ring).
rewrite (H (Derive (fun z : R => Derive (fun t : R => f z t) v2) u2)).
clear H.
apply Rle_lt_trans with (1 := Rabs_triang _ _).
rewrite Rabs_Ropp (double_var e).
apply Rplus_lt_compat.
exact Hc2.
replace (Derive (fun z : R => Derive (fun t : R => f z t) v2) u2) with
  (Derive (fun z : R => Derive (fun t : R => f t z) u1) v1).
exact Hc1.
apply Rmult_eq_reg_l with (d * d).
rewrite -H1 -H2.
ring.
apply Rgt_not_eq.
now apply Rmult_gt_0_compat.
Qed.

Lemma partial_derive_add_zero: forall f p q r s x y,
  (q=0)%nat \/ (r=0)%nat ->
  partial_derive p q (partial_derive r s f) x y
   = partial_derive (p+r) (q+s) f x y.
intros f p q r s x y H.
destruct H; rewrite H.
rewrite plus_0_l.
unfold partial_derive.
simpl.
rewrite -Derive_n_comp.
now apply Derive_n_ext.
rewrite plus_0_r.
unfold partial_derive.
simpl.
apply Derive_n_ext.
intros y0.
rewrite -Derive_n_comp.
now apply Derive_n_ext.
Qed.

(** * Iterated differential *)

Fixpoint ex_diff_n f n x y :=
  continuity_2d_pt f x y /\
  match n with
  | O => True
  | S n =>
    ex_derive (fun z => f z y) x /\
    ex_derive (fun z => f x z) y /\
    ex_diff_n (fun u v => Derive (fun z => f z v) u) n x y /\
    ex_diff_n (fun u v => Derive (fun z => f u z) v) n x y
  end.

Lemma ex_diff_n_ext_loc: forall f g n x y,
    locally_2d (fun u v =>  f u v = g u v) x y
      -> ex_diff_n f n x y -> ex_diff_n g n x y.
Proof.
intros f g n; revert f g.
induction n.
intros f g x y H; simpl.
intros (H1,_); split.
apply (continuity_2d_pt_ext_loc _ _ _ _ H H1).
easy.
simpl.
intros f g x y H (H1&H2&H3&H4&H5).
split.
apply (continuity_2d_pt_ext_loc _ _ _ _ H H1).
split.
apply: ex_derive_ext_loc H2.
apply locally_2d_1d_const_y with (1:=H).
split.
apply: ex_derive_ext_loc H3.
apply locally_2d_1d_const_x with (1:=H).
split.
apply IHn with (2:=H4).
apply locally_2d_impl_strong with (2:=H).
apply locally_2d_forall.
intros u v H6.
apply Derive_ext_loc.
apply locally_2d_1d_const_y with (1:=H6).
apply IHn with (2:=H5).
apply locally_2d_impl_strong with (2:=H).
apply locally_2d_forall.
intros u v H6.
apply Derive_ext_loc.
apply locally_2d_1d_const_x with (1:=H6).
Qed.

Lemma ex_diff_n_m :
  forall n m, (m <= n)%nat -> forall f x y, ex_diff_n f n x y -> ex_diff_n f m x y.
Proof.
assert (forall n f x y, ex_diff_n f (S n) x y -> ex_diff_n f n x y).
induction n.
simpl.
intros f x y H; split; try apply H.
intros f x y H.
repeat (split; try apply H).
apply IHn.
apply H.
apply IHn.
apply H.
intros n m H1 f x y Hn.
induction n.
replace m with 0%nat.
exact Hn.
now apply le_n_0_eq.
case (le_lt_or_eq _ _ H1).
intros H2; apply IHn.
now apply gt_S_le.
apply (H _ _ _ _ Hn).
intros H2; now rewrite H2.
Qed.

Lemma ex_diff_n_deriv_aux1: forall f n x y,
  ex_diff_n f (S n) x y -> ex_diff_n (fun u v => Derive (fun z => f z v) u) n x y.
Proof.
intros f n x y.
case n.
simpl.
intros H; split; apply H.
clear n;intros n H.
simpl in H.
repeat split; apply H.
Qed.

Lemma ex_diff_n_deriv_aux2: forall f n x y,
  ex_diff_n f (S n) x y -> ex_diff_n (fun u v => Derive (fun z => f u z) v) n x y.
Proof.
intros f n x y.
case n.
simpl.
intros H; split; apply H.
clear n;intros n H.
simpl in H.
repeat split; apply H.
Qed.

Lemma ex_diff_n_deriv: forall n p q, (p+q <= n)%nat -> forall f x y,
    ex_diff_n f n x y-> ex_diff_n (partial_derive p q f) (n -(p+q)) x y.
induction p.
(* . *)
intros q; rewrite plus_0_l.
induction q.
intros H f x y H1.
unfold partial_derive.
simpl.
rewrite - minus_n_O.
apply: (ex_diff_n_ext_loc _ _ _ _ _ _ H1).
now apply locally_2d_forall.
intros H f x y H1.
apply (ex_diff_n_ext_loc (fun u v => Derive (fun z => (partial_derive 0 q f) u z) v)).
apply locally_2d_forall.
intros u v; unfold partial_derive.
reflexivity.
apply ex_diff_n_deriv_aux2.
replace ((S (n - S q))) with (n-q)%nat by omega.
apply IHq.
now apply lt_le_weak.
exact H1.
(* . *)
intros q H f x y H1.
apply (ex_diff_n_ext_loc (fun u v => Derive (fun z => (partial_derive p q f) z v) u)).
apply locally_2d_forall.
intros u v; unfold partial_derive.
reflexivity.
apply ex_diff_n_deriv_aux1.
replace ((S (n - (S p +q)))) with (n-(p+q))%nat by omega.
apply IHp.
now apply lt_le_weak.
exact H1.
Qed.

Lemma ex_diff_n_ex_deriv_inf_1 : forall n p k, (p+k < n)%nat -> forall f x y,
    ex_diff_n f n x y ->
    ex_derive  (fun z : R => partial_derive p k f z y) x.
Proof.
intros n p; case p; clear p.
(* . *)
intros k; case k; clear k.
case n; clear n.
intros Hn; contradict Hn; apply lt_n_O.
intros n _ f x y H.
unfold partial_derive; simpl.
apply H.
intros n0 H f x y Hf.
assert (ex_diff_n (partial_derive 0 n0 f) (n -(0+n0)) x y).
apply ex_diff_n_deriv.
auto with zarith.
exact Hf.
revert H0; rewrite plus_0_l.
case_eq (n-n0)%nat.
intros H1; contradict H; auto with zarith.
intros n1 H1 H2.
apply ex_derive_ext with (fun z => Derive (fun t => (partial_derive 0 n0 f z) t) y).
intros y0; unfold partial_derive; simpl.
reflexivity.
simpl in H2.
destruct H2 as (T1&T2&T3&T4&T5).
case_eq n1.
intros H2; rewrite H2 in H1.
clear -H H1; contradict H; auto with zarith.
intros n2 Hn2; rewrite Hn2 in T5.
apply T5.
(* . *)
intros p q H f x y Hf.
assert (ex_diff_n (partial_derive p q f) (n -(p+q)) x y).
apply ex_diff_n_deriv.
auto with zarith.
exact Hf.
case_eq (n-(p+q))%nat.
intros H1; contradict H; auto with zarith.
intros n1 H1.
apply ex_derive_ext with (fun z => Derive (fun t => (partial_derive p q f t) y) z).
intros x0; unfold partial_derive; simpl.
reflexivity.
rewrite H1 in H0; simpl in H0.
destruct H0 as (T1&T2&T3&T4&T5).
case_eq n1.
intros H2; rewrite H2 in H1.
clear -H H1; contradict H; auto with zarith.
intros n2 Hn2; rewrite Hn2 in T4.
apply T4.
Qed.

Lemma ex_diff_n_ex_deriv_inf_2 : forall n p k, (p+k < n)%nat -> forall f x y,
  ex_diff_n f n x y ->
  ex_derive (fun z => partial_derive p k f x z) y.
Proof.
intros n p; case p; clear p.
(* . *)
intros k; case k; clear k.
case n; clear n.
intros Hn; contradict Hn; apply lt_n_O.
intros n _ f x y H.
unfold partial_derive; simpl.
apply H.
intros n0 H f x y Hf.
assert (ex_diff_n (partial_derive 0 n0 f) (n -(0+n0)) x y).
apply ex_diff_n_deriv.
auto with zarith.
exact Hf.
revert H0; rewrite plus_0_l.
case_eq (n-n0)%nat.
intros H1; contradict H; auto with zarith.
intros n1 H1 H2.
apply ex_derive_ext with (fun z => Derive (fun t => (partial_derive 0 n0 f x) t) z).
intros y0; unfold partial_derive; simpl.
reflexivity.
simpl in H2.
destruct H2 as (T1&T2&T3&T4&T5).
case_eq n1.
intros H2; rewrite H2 in H1.
clear -H H1; contradict H; auto with zarith.
intros n2 Hn2; rewrite Hn2 in T5.
apply T5.
(* . *)
intros p q H f x y Hf.
assert (ex_diff_n (partial_derive p q f) (n -(p+q)) x y).
apply ex_diff_n_deriv.
auto with zarith.
exact Hf.
case_eq (n-(p+q))%nat.
intros H1; contradict H; auto with zarith.
intros n1 H1.
apply ex_derive_ext with (fun z => Derive (fun t => (partial_derive p q f t) z) x).
intros x0; unfold partial_derive; simpl.
reflexivity.
rewrite H1 in H0; simpl in H0.
destruct H0 as (T1&T2&T3&T4&T5).
case_eq n1.
intros H2; rewrite H2 in H1.
clear -H H1; contradict H; auto with zarith.
intros n2 Hn2; rewrite Hn2 in T4.
apply T4.
Qed.

Lemma ex_diff_n_continuity_inf_1 : forall n p k, (p+k < n)%nat -> forall f x y,
  ex_diff_n f n x y ->
  continuity_2d_pt (fun u v => Derive (fun z : R => partial_derive p k f z v) u) x y.
Proof.
intros n p k Hn f x y Hf.
assert (ex_diff_n (partial_derive (S p) k f) (n -(S p+k)) x y).
now apply ex_diff_n_deriv.
apply continuity_2d_pt_ext_loc with (partial_derive (S p) k f).
apply locally_2d_forall.
intros u v; unfold partial_derive; simpl.
reflexivity.
revert H; case (n - (S p + k))%nat.
simpl; intros H; apply H.
intros n0; simpl; intros H; apply H.
Qed.

Lemma Derive_partial_derive_aux1: forall p f x y,
  locally_2d (ex_diff_n f (S p)) x y ->
   partial_derive  1 p f x y = partial_derive 0 p (partial_derive  1 0 f) x y.
Proof.
intros p; induction p.
intros f x y H.
unfold partial_derive; now simpl.
intros f x y H.
apply trans_eq with  (partial_derive 1 p (partial_derive 0 1 f) x y).
unfold partial_derive.
simpl.
apply Derive_ext.
intros t.
apply trans_eq with (Derive_n (Derive_n (fun z : R => f t z) p) 1 y).
reflexivity.
rewrite Derive_n_comp.
rewrite Arith.Plus.plus_comm.
rewrite -Derive_n_comp.
reflexivity.
rewrite IHp.
apply trans_eq with
  (partial_derive 0 p (partial_derive 0 1 (partial_derive 1 0 f)) x y).
unfold partial_derive.
simpl.
apply Derive_n_ext_loc.
cut (locally_2d (fun u v =>
         Derive (fun x0 : R => Derive (fun x1 : R => f x0 x1) v) u =
         Derive (fun x0 : R => Derive (fun x1 : R => f x1 x0) u) v) x y).
apply locally_2d_1d_const_x.
apply locally_2d_impl_strong with (2:=H).
apply locally_2d_forall.
intros u v H1.
apply Schwarz.
apply locally_2d_impl with (2:=H1).
apply locally_2d_forall.
intros u' v' H2.
split.
apply H2.
split.
apply H2.
simpl in H2; destruct H2 as (T1&T2&T3&T4&T5).
split.
apply T5.
apply T4.
apply locally_2d_singleton in H1.
simpl in H1; destruct H1 as (T1&T2&T3&T4&T5).
destruct T5 as (Y1&Y2&Y3&Y4&Y5).
clear - Y4.
case p in Y4; simpl in Y4; apply Y4.
apply locally_2d_singleton in H1.
simpl in H1; destruct H1 as (T1&T2&T3&T4&T5).
destruct T4 as (Y1&Y2&Y3&Y4&Y5).
clear - Y5.
case p in Y5; simpl in Y5; apply Y5.
unfold partial_derive.
simpl.
apply trans_eq with (Derive_n (Derive_n (fun z => Derive (fun x0 => f x0 z) x) p) 1 y).
rewrite Derive_n_comp.
rewrite Arith.Plus.plus_comm.
rewrite -Derive_n_comp.
reflexivity.
reflexivity.
apply locally_2d_impl with (2:=H).
apply locally_2d_forall.
intros u v.
pattern (S p) at 2; replace (S p) with (S (S p) -(0+1))%nat.
apply ex_diff_n_deriv.
rewrite plus_0_l.
apply lt_le_S; apply lt_0_Sn.
rewrite plus_0_l.
omega.
Qed.

Lemma Derive_partial_derive_aux2: forall p k f x y,
  locally_2d (ex_diff_n f (p+S k)) x y ->
  partial_derive 0 1 (partial_derive p k f) x y =
     partial_derive p (S k) f x y.
Proof.
intros p; induction p.
intros; easy.
intros k f x y Y.
apply sym_eq.
apply trans_eq with
  (partial_derive p 0 (partial_derive 1 (S k) f) x y).
rewrite partial_derive_add_zero.
rewrite plus_0_l.
replace (S p) with (p+1)%nat by apply Arith.Plus.plus_comm.
easy.
now left.
apply trans_eq with
  (partial_derive p 0 (partial_derive 0 (S k) (partial_derive 1 0 f)) x y).
apply partial_derive_ext_loc.
apply locally_2d_impl_strong with (2:=Y).
apply locally_2d_forall.
intros u v H.
apply Derive_partial_derive_aux1.
apply locally_2d_impl with (2:=H).
apply locally_2d_forall.
intros u'' v''.
apply ex_diff_n_m.
omega.
apply trans_eq with (partial_derive p (S k) (partial_derive 1 0 f) x y).
rewrite partial_derive_add_zero.
now rewrite plus_0_l plus_0_r.
now right.
rewrite - IHp.
apply partial_derive_ext_loc.
apply locally_2d_impl_strong with (2:=Y).
apply locally_2d_forall.
intros u v H.
apply trans_eq with
 (partial_derive p 0 (partial_derive 0 k (partial_derive 1 0 f)) u v).
rewrite (partial_derive_add_zero _ _ 0%nat).
now rewrite plus_0_l plus_0_r.
now right.
apply trans_eq with
 (partial_derive p 0 (partial_derive 1 k f) u v).
apply partial_derive_ext_loc.
apply locally_2d_impl_strong with (2:=H).
apply locally_2d_forall.
intros u' v' H'.
apply sym_eq.
apply Derive_partial_derive_aux1.
apply locally_2d_impl with (2:=H').
apply locally_2d_forall.
intros u'' v''.
apply ex_diff_n_m.
apply le_plus_r.
rewrite partial_derive_add_zero.
rewrite plus_0_l.
replace (S p) with (p+1)%nat by apply Arith.Plus.plus_comm.
easy.
now left.
apply locally_2d_impl with (2:=Y).
apply locally_2d_forall.
intros u'' v''.
replace (p+ S k)%nat with ((S p+S k)-(1+0))%nat.
apply ex_diff_n_deriv.
rewrite plus_0_r.
apply le_plus_trans; apply lt_le_S; apply lt_0_Sn.
rewrite plus_0_r.
omega.
Qed.

Lemma Derive_partial_derive: forall p k f x y,
  locally_2d (ex_diff_n f (p+S k)) x y ->
  Derive (fun v : R => partial_derive p k f x v) y =
     partial_derive p (S k) f x y.
Proof.
intros p k f x y H.
generalize (Derive_partial_derive_aux2 p k f x y H).
easy.
Qed.

Lemma ex_diff_n_continuity_inf_2 : forall n p k, (p+k < n)%nat -> forall f x y,
  ex_diff_n f n x y ->
  continuity_2d_pt (fun u v => Derive (fun z : R => partial_derive p k f u z) v) x y.
Proof.
intros n p k Hn f x y Hf.
assert (ex_diff_n (partial_derive p k f) (n -(p+k)) x y).
apply ex_diff_n_deriv.
now apply lt_le_weak.
exact Hf.
revert H; case_eq (n-(p+k))%nat.
intros H; contradict Hn.
omega.
intros n0 Hn0; simpl; intros (T1&T2&T3&T4&T5).
revert T5; case n0.
intros Y; apply Y.
intros n1 Y; apply Y.
Qed.

(** * 2D Taylor-Lagrange inequality *)

Definition DL_regular_n f m x y :=
  exists D, locally_2d (fun u v =>
    Rabs (f u v - DL_pol m f x y (u-x) (v-y)) <= D * (Rmax (Rabs (u-x)) (Rabs (v-y))) ^ (S m)) x y.

Theorem Taylor_Lagrange_2d : forall f n x y,
  locally_2d (fun u v => ex_diff_n f (S n) u v) x y -> DL_regular_n f n x y.
Proof.
intros f n x y Df.
(* *)
assert (exists D, locally_2d (fun u v => forall p, (p <= S n)%nat ->
  Rabs (partial_derive p (S n - p) f u v) <= D) x y).
(* . *)
assert (forall p, (p <= S n)%nat -> exists D, locally_2d (fun u v => Rabs (partial_derive p (S n - p) f u v) <= D) x y).
intros p Hp.
(* .. *)
assert (continuity_2d_pt (partial_derive p (S n - p) f) x y).
apply locally_2d_singleton in Df.
refine (proj1 (_: ex_diff_n (partial_derive p (S n - p) f) 0 x y)).
replace O with (S n - (p + (S n - p)))%nat by rewrite le_plus_minus_r // minus_diag //.
cut (p + (S n - p) <= S n)%nat.
2: now rewrite le_plus_minus_r.
generalize (S n - p)%nat.
clear Hp.
revert f Df p.
generalize (S n).
clear n.
induction n.
intros f (H,_) [|p] [|q] H' ; try inversion H'.
done.
intros f H [|p] q H'.
destruct q as [|q].
exact H.
now apply ex_diff_n_deriv.
now apply ex_diff_n_deriv.
(* .. *)
exists (Rabs (partial_derive p (S n - p) f x y) + 1).
specialize (H (mkposreal 1 Rlt_0_1)).
apply: locally_2d_impl H.
apply: locally_2d_forall => u v H.
replace (partial_derive p (S n - p) f u v) with (partial_derive p (S n - p) f x y + (partial_derive p (S n - p) f u v - partial_derive p (S n - p) f x y)) by ring.
apply Rle_trans with (1 := Rabs_triang _ _).
apply Rplus_le_compat_l.
now apply Rlt_le.
(* . *)
clear -H.
generalize (le_refl (S n)).
generalize (S n) at 1 3.
intros p Hp.
induction p.
move: (H _ Hp) => {H} [D H].
exists D.
apply: locally_2d_impl H.
apply locally_2d_forall => u v H [|p] Hp' //.
inversion Hp'.
move: (IHp (le_S _ _ (le_S_n _ _ Hp))) => {IHp} [D1 H1].
move: (H _ Hp) => {H} [D2 H2].
exists (Rmax D1 D2).
move: (locally_2d_and _ _ x y H1 H2) => {H1 H2} H.
apply: locally_2d_impl H.
apply locally_2d_forall => u v H p' Hp'.
destruct (le_lt_or_eq _ _ Hp').
apply Rle_trans with (2 := Rmax_l _ _).
apply H.
now apply gt_S_le.
apply Rle_trans with (2 := Rmax_r _ _).
now rewrite H0.
(* *)
destruct H as (D,H).
exists  (/ INR (fact (S n)) * D * sum_f_R0 (fun i : nat => Rabs (C (S n) i)) (S n)).
move: (locally_2d_and _ _ _ _ Df H) => {Df H} HH.
apply locally_2d_1d_strong in HH.
apply: locally_2d_impl HH.
apply locally_2d_forall => u v HH.
set (g t := f (x + t * (u - x)) (y + t * (v - y))).
replace (f u v) with (g 1) by (rewrite /g 2!Rmult_1_l ; apply f_equal2 ; ring).
assert (forall k t, (k <= S n)%nat -> 0 <= t <= 1 ->
  is_derive_n g k t (sum_f_R0 (fun m => C k m * partial_derive m (k - m)%nat f (x+t*(u-x)) (y+t*(v-y)) *
         (u-x) ^ m * (v-y) ^ (k - m)%nat) k)).
intros k t Hk Ht.
specialize (HH t Ht).
revert HH.
pattern t ; apply locally_singleton.
induction k.
rewrite /C /partial_derive /g /=.
apply filter_forall.
intros ; field.
specialize (IHk (le_S _ _ (le_S_n _ _ Hk))).
rewrite /is_derive_n.
apply locally_locally in IHk.
move: IHk ; apply filter_imp => {t Ht} z IHk HH.
apply is_derive_ext_loc with (fun t => sum_n (fun m => C k m *
  partial_derive m (k - m) f (x + t * (u - x)) (y + t * (v - y)) * (u - x) ^ m * (v - y) ^ (k - m)) k).
  apply locally_locally in HH.
  generalize (filter_and _ _ HH IHk).
  apply filter_imp => {z HH IHk} z [Hz HH].
  specialize (HH Hz).
  apply sym_eq.
  rewrite sum_n_Reals.
  now apply is_derive_n_unique.
replace (sum_f_R0 (fun m : nat => C (S k) m *
    partial_derive m (S k - m) f (x + z * (u - x)) (y + z * (v - y)) * (u - x) ^ m * (v - y) ^ (S k - m)) (S k)) with
  (sum_n (fun m : nat => C k m * (u - x) ^ m  * (v - y) ^ (k - m) *
    ((u - x) * partial_derive (S m) (k - m) f (x + z * (u - x)) (y + z * (v - y)) +
     (v - y) * partial_derive m (S (k - m)) f (x + z * (u - x)) (y + z * (v - y)))) k).
apply: is_derive_sum_n => p Hp.
apply is_derive_ext with (fun u0 => C k p * (u - x) ^ p * (v - y) ^ (k - p) * partial_derive p (k - p) f (x + u0 * (u - x)) (y + u0 * (v - y))).
intros w.
simpl ; ring.
apply is_derive_Reals, derivable_pt_lim_scal.
rewrite (Rmult_comm (u - x)) (Rmult_comm (v - y)).
apply derivable_pt_lim_comp_2d.
apply locally_singleton in HH.
replace (partial_derive (S p) (k - p) f (x + z * (u - x)) (y + z * (v - y)))
  with (Derive (fun u : R => partial_derive p (k - p) f u (y + z * (v - y))) (x + z * (u - x))).
2: reflexivity.
replace (partial_derive p (S (k - p)) f (x + z * (u - x)) (y + z * (v - y))) with
  (Derive (fun v : R => partial_derive p (k - p) f  (x + z * (u - x)) v) (y + z * (v - y))).
apply filterdiff_differentiable_pt_lim.
eapply filterdiff_ext_lin.
apply is_derive_filterdiff.
apply locally_2d_locally in HH.
apply filter_imp with (2:=HH).
clear - Hk Hp ; intros [u' v'] (H1,H2).
evar_last.
apply Derive_correct.
apply ex_diff_n_ex_deriv_inf_1 with (S n).
now rewrite - le_plus_minus.
exact H1.
simpl ; reflexivity.
apply locally_2d_singleton in HH.
apply Derive_correct.
apply ex_diff_n_ex_deriv_inf_2 with (S n).
now rewrite - le_plus_minus.
apply HH.
apply locally_2d_singleton in HH.
apply continuity_2d_pt_filterlim.
apply ex_diff_n_continuity_inf_1 with (S n).
now rewrite - le_plus_minus.
apply HH.
case => /= u' v'.
reflexivity.
apply Derive_partial_derive_aux2.
apply locally_2d_impl with (2:=HH).
apply locally_2d_forall.
intros u' v' (Y,_).
apply ex_diff_n_m with (2:=Y).
omega.
apply is_derive_Reals ; eapply filterdiff_ext_lin.
apply @filterdiff_plus_fct ; try apply locally_filter.
apply filterdiff_const.
apply @filterdiff_scal_l ; try apply locally_filter.
simpl => y0 ; apply plus_zero_l.
apply is_derive_Reals ; eapply filterdiff_ext_lin.
apply @filterdiff_plus_fct ; try apply locally_filter.
apply filterdiff_const.
apply @filterdiff_scal_l ; try apply locally_filter.
simpl => y0 ; apply plus_zero_l.
rewrite sum_n_Reals -(sum_eq (fun m =>
  C k m * (u - x) ^ (S m) * (v - y) ^ (k - m) * partial_derive (S m) (k - m) f (x + z * (u - x)) (y + z * (v - y)) +
  C k m * (u - x) ^ m * (v - y) ^ (S (k - m)) * partial_derive m (S (k - m)) f (x + z * (u - x)) (y + z * (v - y)))).
2: intros ; simpl ; ring.
case k; clear Hk IHk k.
unfold C; simpl.
simpl ; field.
intros k.
apply sym_eq.
rewrite (decomp_sum _ (S (S k))).
2: apply lt_0_Sn.
rewrite - pred_Sn.
rewrite tech5.
rewrite (sum_eq _ (fun i : nat =>
     (C (S k) i*
    partial_derive (S i) (S (S k) - S i) f (x + z * (u - x))
      (y + z * (v - y)) * (u - x) ^ S i * (v - y) ^ (S (S k) - S i))
     + (C (S k) (S i) *
       partial_derive (S i) (S (S k) - S i) f (x + z * (u - x))
      (y + z * (v - y)) * (u - x) ^ S i * (v - y) ^ (S (S k) - S i)))).
rewrite sum_plus.
apply sym_eq.
rewrite sum_plus.
rewrite tech5.
rewrite (tech2 _ 0 (S k)).
2: apply lt_0_Sn.
replace
 (sum_f_R0
   (fun l : nat =>
    C (S k) l * (u - x) ^ l * (v - y) ^ S (S k - l) *
    partial_derive l (S (S k - l)) f (x + z * (u - x)) (y + z * (v - y))) 0)
with  (C (S (S k)) 0 *
partial_derive 0 (S (S k) - 0) f (x + z * (u - x)) (y + z * (v - y)) *
(u - x) ^ 0 * (v - y) ^ (S (S k) - 0)).
replace (C (S k) (S k) * (u - x) ^ S (S k) * (v - y) ^ (S k - S k) *
   partial_derive (S (S k)) (S k - S k) f (x + z * (u - x)) (y + z * (v - y))) with
 (C (S (S k)) (S (S k)) *
 partial_derive (S (S k)) (S (S k) - S (S k)) f (x + z * (u - x))
   (y + z * (v - y)) * (u - x) ^ S (S k) * (v - y) ^ (S (S k) - S (S k))).
replace (sum_f_R0
  (fun l : nat =>
   C (S k) l *
   partial_derive (S l) (S (S k) - S l) f (x + z * (u - x)) (y + z * (v - y)) *
   (u - x) ^ S l * (v - y) ^ (S (S k) - S l)) k)
  with (sum_f_R0
  (fun l : nat =>
   C (S k) l * (u - x) ^ S l * (v - y) ^ (S k - l) *
   partial_derive (S l) (S k - l) f (x + z * (u - x)) (y + z * (v - y))) k).
replace (sum_f_R0
  (fun l : nat =>
   C (S k) (S l) *
   partial_derive (S l) (S (S k) - S l) f (x + z * (u - x)) (y + z * (v - y)) *
   (u - x) ^ S l * (v - y) ^ (S (S k) - S l)) k)
 with (sum_f_R0
  (fun i : nat =>
   C (S k) (1 + i) * (u - x) ^ (1 + i) * (v - y) ^ S (S k - (1 + i)) *
   partial_derive (1 + i) (S (S k - (1 + i))) f (x + z * (u - x))
     (y + z * (v - y))) (S k - 1)).
simpl ; ring.
replace (S k - 1)%nat with k. 2: now apply plus_minus.
apply sum_eq.
intros i Hi.
replace (1+i)%nat with (S i) by reflexivity.
replace (S (S k - S i))%nat with (S (S k) - S i)%nat.
ring.
now (rewrite minus_Sn_m; try apply le_n_S).
apply sum_eq.
intros i Hi.
replace (S k - i)%nat with (S (S k) - S i)%nat by reflexivity.
ring.
rewrite 2!C_n_n 2!minus_diag.
ring.
simpl.
rewrite 2!C_n_0.
ring.
intros.
rewrite - (pascal (S k) i).
ring.
now apply le_lt_n_Sm.
(* *)
destruct (Taylor_Lagrange g n 0 1 Rlt_0_1) as (t&Ht&Hg).
intros t Ht.
intros [|k] Hk.
easy.
eexists.
now apply (H (S k)).
(* *)
rewrite Hg /DL_pol.
replace (1 - 0) with 1 by ring.
rewrite pow1 {1}/Rminus Rplus_assoc [_*_+_]Rplus_comm -Rplus_assoc -/(Rminus _ _).
assert (forall k t, (k <= S n)%nat -> 0 <= t <= 1 -> Derive_n g k t =
      (sum_f_R0 (fun m =>  C k m * partial_derive m (k - m)%nat f (x+t*(u-x)) (y+t*(v-y)) *
         (u-x) ^ m * (v-y) ^ (k - m)%nat) k)).
intros k t0 Hk Ht0.
apply is_derive_n_unique.
now apply H.
rewrite -minus_sum sum_eq_R0.
rewrite H0.
rewrite Rplus_0_l.
unfold differential.
rewrite Rabs_mult.
eapply Rle_trans.
apply Rmult_le_compat_l.
apply Rabs_pos.
eapply Rle_trans.
apply Rsum_abs.
apply sum_Rle.
intros n0 Hn0.
rewrite Rmult_assoc 3!Rabs_mult.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rmult_le_compat.
apply Rabs_pos.
apply Rmult_le_pos; apply Rabs_pos.
specialize (HH t (conj (Rlt_le _ _ (proj1 Ht)) (Rlt_le _ _ (proj2 Ht)))).
apply locally_singleton in HH.
apply locally_2d_singleton in HH.
now apply HH.
rewrite - 2!RPow_abs.
instantiate (1:=(Rmax (Rabs (u - x)) (Rabs (v - y)) ^ S n)).
apply Rle_trans with ((Rmax (Rabs (u - x)) (Rabs (v - y)) ^ n0) * (Rmax (Rabs (u - x)) (Rabs (v - y)) ^ (S n - n0))).
apply Rmult_le_compat.
apply pow_le ; apply Rabs_pos.
apply pow_le ; apply Rabs_pos.
apply pow_incr.
split.
apply Rabs_pos.
apply Rmax_l.
apply pow_incr.
split.
apply Rabs_pos.
apply Rmax_r.
rewrite -pow_add.
rewrite -le_plus_minus.
apply Rle_refl.
exact Hn0.
rewrite - scal_sum.
rewrite /Rdiv Rmult_1_l Rabs_right .
right; ring.
apply Rle_ge; apply Rlt_le; apply Rinv_0_lt_compat.
apply INR_fact_lt_0.
apply le_refl.
split; apply Rlt_le, Ht.
intros n0 hn0.
rewrite H0.
rewrite 2!Rmult_0_l 2!Rplus_0_r pow1.
unfold differential, Rdiv; ring.
now apply le_S.
split; [apply Rle_refl | apply Rle_0_1].
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 P Q D R1 R2 : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ D A /\ (wd_ D B /\ (wd_ P R1 /\ (wd_ Q R1 /\ (wd_ D R1 /\ (wd_ R1 R2 /\ (wd_ D R2 /\ (col_ P Q D /\ (col_ P Q R1 /\ (col_ R1 D R2 /\ col_ D A B)))))))))))))) -> col_ P Q R2)).
Proof.
  time tac.
Qed.

End FOFProblem.


From ITree Require Import ITree.
Import ITreeNotations.

Section Crypto.
  Parameter BS: Set. (** ByteString *)
  Parameter P: Set.  (** Principals *)

  Inductive Msg := mkMsg (principal: P)(payload: BS).

  (** effects *)

  (** High-level network spec *)
  Inductive Net: Type -> Type :=
  | Recv: Net Msg (** blocking *)
  | Send : Msg -> Net unit.

  (** Ghost types *)
  Inductive E (p: P): Type -> Type := Enc: forall t: Type, t -> E p t.
  Inductive S (p: P): Type -> Type := Sign: forall t: Type, t -> S p t.
  Inductive Pub (p: P): Type := mkPub: BS -> Pub p.
  Inductive Priv (p: P): Type := mkPriv: BS -> Priv p.
  Inductive Sym(p: P): Type := mkSym: BS -> Sym p.

  (** High-level PKI lang *)
  Inductive PKI: Type -> Type :=
  | EncPub(p: P)(k: Pub p)(plain: BS): PKI (E p BS)
  | DecPriv(p: P)(k: Priv p)(cipher: E p BS): PKI BS
  | SignPriv(p: P)(k: Priv p)(plain: BS): PKI (S p BS)
  | CheckPub(p: P)(k: Pub p)(signed: S p BS): PKI bool
  | EncSym(p: P)(k: Sym p)(plain: BS): PKI (E p BS)
  | DecSym(p: P)(k: Sym p)(cipher: E p BS): PKI BS.

  Definition recv : itree Net Msg := embed Recv.
  Definition send : Msg -> itree Net unit := embed Send.
  Definition encrypt := embed EncPub.
  Definition decrypt := embed DecPriv.
  Definition sign := embed SignPriv.
  Definition check := embed CheckPub.
  Definition sencrypt := embed EncSym.
  Definition sdecrypt := embed DecSym.

End Crypto.


Require Import VST.floyd.proofauto.
Require Import fac2.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Import fac_facts.

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr (fac 5))))
     SEP(TT).

Definition Gprog : funspecs :=
        ltac:(with_library prog [main_spec]).

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward.
assert (fac 5 <= Int.max_signed) by (compute; congruence).
assert (0 < 5 <= 12) by rep_lia.
forget 5 as n.
forward.
forward.
forward.
forward_loop (EX r:Z,
  PROP (1 <= r <= n)
  LOCAL (temp _u (Vint (Int.repr (fac r)));
              temp _r (Vint (Int.repr r));
              temp _n (Vint (Int.repr n)))
  SEP(has_ext tt))
   break: (PROP () LOCAL (temp _u (Vint (Int.repr (fac n)))) SEP(has_ext tt)).
- repeat step!.
-
Intros r.
forward.
forward_if (r < n). forward. entailer!.
forward. entailer!.
assert (r=n) by lia. subst. auto.
forward.
forward_loop (EX s:Z,
  PROP (1 <= s <= r)
  LOCAL (temp _u (Vint (Int.repr (s * fac r)));
              temp _v (Vint (Int.repr (fac r)));
              temp _s (Vint (Int.repr s));
              temp _r (Vint (Int.repr r));
              temp _n (Vint (Int.repr n)))
  SEP(has_ext tt))
   break: (PROP ()
              LOCAL (temp _u (Vint (Int.repr (fac (r+1))));
                         temp _r (Vint (Int.repr r));
                         temp _n (Vint (Int.repr n)))
               SEP(has_ext tt)).
+
Exists 1; entailer!.
+
pose proof (fac_mono 0 r).
spec H3; [lia|]. change (fac 0) with 1 in H3.
pose proof (fac_mono r (n-1)).
spec H4; [lia|].
assert (fac (n-1) <= fac 11).
apply fac_mono. lia.
set (x := fac 11) in *. compute in x. subst x.
Intros s.
assert (0 <= s * fac r) by (apply Z.mul_nonneg_nonneg; lia).
assert (s * fac r + fac r <= fac (r+1)). {
  rewrite (fac_equation (r+1)).
  rewrite if_true by lia.
  rewrite Z.add_simpl_r.
  replace (s * fac r + fac r) with ((s+1)*(fac r))%Z by (rewrite Z.mul_add_distr_r; lia).
  apply Z.mul_le_mono_nonneg_r; lia.
}
assert (fac (r+1) <= fac n) by (apply fac_mono; lia).
forward.
forward.
forward.
forward_if (s < r).
forward.
entailer!.
forward.
entailer!.
assert (s=r) by lia.
subst s.
replace (r * fac r + fac r) with ((r+1)*(fac r))%Z by (rewrite Z.mul_add_distr_r; lia).
rewrite (fac_equation (r+1)). rewrite if_true by lia.
rewrite Z.add_simpl_r.
auto.
Exists (s+1).
entailer!.
rewrite Z.mul_add_distr_r.
rewrite Z.mul_1_l. auto.
+
forward.
Exists (r+1).
entailer!.
-
forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct: semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_main.
Qed.


Require Export Coq.ZArith.ZArith.
Require Export Coq.Strings.String.
Require Export Crypto.Specific.GF25519.
Require Import Crypto.Reflection.Reify.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.SmartMap.
Require Import Crypto.Reflection.ExprInversion.
Require Import Crypto.Reflection.Relations.
Require Import Crypto.Reflection.Linearize.
Require Import Crypto.Reflection.Z.Reify.
Require Export Crypto.Reflection.Z.Syntax.
Require Import Crypto.Reflection.InterpWfRel.
Require Import Crypto.Reflection.LinearizeInterp.
Require Import Crypto.Reflection.WfReflective.
Require Import Crypto.Reflection.Eta.
Require Import Crypto.Reflection.EtaInterp.
Require Import Crypto.CompleteEdwardsCurve.ExtendedCoordinates.
Require Import Crypto.Specific.GF25519Reflective.Common.
Require Import Crypto.Specific.GF25519Reflective.Reified.Add.
Require Import Crypto.Specific.GF25519Reflective.Reified.Sub.
Require Import Crypto.Specific.GF25519Reflective.Reified.Mul.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ZUtil.
Require Import Crypto.Util.HList.
Require Import Crypto.Util.Tower.
Require Import Crypto.Util.Tactics.
Require Import Crypto.Util.Notations.
Require Import Bedrock.Word.

(* TODO: it would be nice if we didn't need to duplicate this *)
Definition add_coordinates_gen (F:Type) (Fadd Fsub Fmul : F -> F -> F) (twice_d : F) (P1 P2 : F*F*F*F) (F4:Type) (parlet: F -> (F -> F4) -> F4) (pair4:F->F->F->F->F4) : F4 :=
  let (p, T1) := P1 in
  let (p0, Z1) := p in
  let (X1, Y1) := p0 in
  let (p1, T2) := P2 in
  let (p2, Z2) := p1 in
  let (X2, Y2) := p2 in
  parlet (Fmul (Fsub Y1 X1) (Fsub Y2 X2)) (fun A=>
  parlet (Fmul (Fadd Y1 X1) (Fadd Y2 X2)) (fun B=>
  parlet (Fmul (Fmul T1 twice_d) T2) (fun C=>
  parlet (Fmul Z1 (Fadd Z2 Z2)) (fun D=>
  parlet (Fsub B A) (fun E=>
  parlet (Fsub D C) (fun F0=>
  parlet (Fadd D C) (fun G=>
  parlet (Fadd B A) (fun H=>
  parlet (Fmul E F0) (fun X3=>
  parlet (Fmul G H) (fun Y3=>
  parlet (Fmul E H) (fun T3=>
  parlet (Fmul F0 G) (fun Z3=>
  pair4 X3 Y3 Z3 T3)))))))))))).

Definition radd_coordinatesZ' var twice_d P1 P2
  := @add_coordinates_gen
       _
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig raddZ_sig var)))
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig rsubZ_sig var)))
       (fun x y => LetIn (Pair x y) (invert_Abs (proj1_sig rmulZ_sig var)))
       twice_d
       P1 P2
       _
       (fun v f => LetIn v
                         (fun k => f (SmartVarf k)))
       (fun x y z w => (x, y, z, w)%expr).

Local Notation eta x := (fst x, snd x).

Definition radd_coordinatesZ'' : Syntax.Expr _ _ _
  := Linearize
       (ExprEta
          (fun var
           => Abs (fun twice_d_P1_P2 : interp_flat_type _ (_ * ((_ * _ * _ * _) * (_ * _ * _ * _)))
                   => let '(twice_d, ((P10, P11, P12, P13), (P20, P21, P22, P23)))
                          := twice_d_P1_P2 in
                      radd_coordinatesZ'
                        var (SmartVarf twice_d)
                        (SmartVarf P10, SmartVarf P11, SmartVarf P12, SmartVarf P13)
                        (SmartVarf P20, SmartVarf P21, SmartVarf P22, SmartVarf P23)))).

Definition add_coordinates
  := fun twice_d P10 P11 P12 P13 P20 P21 P22 P23
     => add_coordinates_gen
          _ add sub mul
          twice_d (P10, P11, P12, P13) (P20, P21, P22, P23) _ (fun x (f:_->(_*_*_*_)) => let y := x in f y) (fun x y z t => (x,y,z,t)).

Definition uncurried_add_coordinates
  := fun twice_d_P1_P2
     => let twice_d := fst twice_d_P1_P2 in
        let (P1, P2) := eta (snd twice_d_P1_P2) in
        @add_coordinates_gen
          _ add sub mul
          twice_d P1 P2
          _
          (fun v f => dlet_nd k := v in f k)
          (fun x y z w => (x, y, z, w)).

Local Notation rexpr_sigPf T uncurried_op rexprZ x :=
  (Interp interp_op (t:=T) rexprZ x = uncurried_op x)
    (only parsing).
Local Notation rexpr_sigP T uncurried_op rexprZ :=
  (forall x, rexpr_sigPf T uncurried_op rexprZ x)
    (only parsing).
Local Notation rexpr_sig T uncurried_op :=
  { rexprZ | rexpr_sigP T uncurried_op rexprZ }
    (only parsing).

Local Ltac fold_interpf' :=
  let k := (eval unfold interpf, interpf_step in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  change k with k'; clearbody k'; subst k'.

Local Ltac fold_interpf :=
  let k := (eval unfold interpf in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  change k with k'; clearbody k'; subst k';
  fold_interpf'.

Local Ltac repeat_step_interpf :=
  let k := (eval unfold interpf in (@interpf base_type interp_base_type op interp_op)) in
  let k' := fresh in
  let H := fresh in
  pose k as k';
  assert (H : @interpf base_type interp_base_type op interp_op = k') by reflexivity;
  repeat (unfold k'; change k with k'; unfold interpf_step);
  clearbody k'; subst k'.

Lemma radd_coordinatesZ_sigP' : rexpr_sigP _ uncurried_add_coordinates radd_coordinatesZ''.
Proof.
  cbv [radd_coordinatesZ''].
  intro x; rewrite InterpLinearize, InterpExprEta.
  cbv [domain interp_flat_type] in x.
  destruct x as [twice_d [ [ [ [P10_ P11_] P12_] P13_] [ [ [P20_ P21_] P22_] P23_] ] ].
  repeat match goal with
         | [ H : prod _ _ |- _ ] => let H0 := fresh H in let H1 := fresh H in destruct H as [H0 H1]
         end.
  cbv [invert_Abs domain codomain Interp interp SmartVarf smart_interp_flat_map fst snd].
  cbv [radd_coordinatesZ' uncurried_add_coordinates add_coordinates add_coordinates_gen SmartVarf smart_interp_flat_map]; simpl @fst; simpl @snd.
  repeat match goal with
         | [ |- appcontext[@proj1_sig ?A ?B ?v] ]
           => let k := fresh "f" in
              let k' := fresh "f" in
              let H := fresh in
              set (k := v);
                set (k' := @proj1_sig A B k);
                pose proof (proj2_sig k) as H;
                change (proj1_sig k) with k' in H;
                clearbody k'; clear k;
                  cbv beta in *
         end.
  cbv [Interp Curry.curry2] in *.
  unfold interpf, interpf_step; fold_interpf.
  cbv beta iota delta [uncurried_add_coordinates add_coordinates_gen interp_flat_type interp_base_type GF25519.fe25519].
  Time
    abstract (
      repeat match goal with
             | [ |- (dlet x := ?y in @?z x) = (dlet x' := ?y' in @?z' x') ]
               => refine ((fun pf0 pf1 => @Proper_Let_In_nd_changebody _ _ Logic.eq _ y y' pf0 z z' pf1)
                            (_ : y = y')
                            (_ : forall x, z x = z' x));
                    cbv beta; intros;
                      [ cbv [Let_In] | ]
             end;
        repeat match goal with
               | _ => rewrite !interpf_invert_Abs
               | _ => rewrite_hyp !*
               | [ |- ?x = ?x ] => reflexivity
               | _ => rewrite <- !surjective_pairing
               end
    ).
Time Defined.
Lemma radd_coordinatesZ_sigP : rexpr_sigP _ uncurried_add_coordinates radd_coordinatesZ''.
Proof.
  exact radd_coordinatesZ_sigP'.
Qed.
Definition radd_coordinatesZ_sig
  := exist (fun v => rexpr_sigP _ _ v) radd_coordinatesZ'' radd_coordinatesZ_sigP.

Definition radd_coordinates_input_bounds
  := (ExprUnOp_bounds, ((ExprUnOp_bounds, ExprUnOp_bounds, ExprUnOp_bounds, ExprUnOp_bounds),
                        (ExprUnOp_bounds, ExprUnOp_bounds, ExprUnOp_bounds, ExprUnOp_bounds))).

Time Definition radd_coordinatesZ : Expr _ := Eval vm_compute in proj1_sig radd_coordinatesZ_sig.
Time Definition radd_coordinatesW_pkgo := Eval vm_compute in rexpr_select_word_sizes_option radd_coordinatesZ radd_coordinates_input_bounds.
Time Definition radd_coordinatesW_pkg := Eval vm_compute in rexpr_select_word_sizes_postprocess1 radd_coordinatesW_pkgo.
Time Definition radd_coordinatesT := get_output_type radd_coordinatesW_pkg.
Time Definition radd_coordinatesW' : Expr _ := Eval vm_compute in get_output_expr radd_coordinatesW_pkg.
Time Definition radd_coordinatesW : Expr radd_coordinatesT := Eval cbv [radd_coordinatesW'] in rexpr_select_word_sizes_postprocess2 radd_coordinatesW'.


Require Import Coq.Classes.Morphisms.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Definitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Properties.
Require Import Fiat.Common.BoolFacts.
Require Import Fiat.Common.
Require Import Fiat.Common.Wf.

Set Implicit Arguments.

Local Open Scope bool_scope.

Global Instance prod_fixedpoint_lattice {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (@state _ fpldata0 * @state _ fpldata1).
Proof.
  refine {| prestate_lt x y := ((state_le (fst x) (fst y) && state_le (snd x) (snd y))
                                  && negb (state_beq (fst x) (fst y) && state_beq (snd x) (snd y)));
            prestate_beq := Equality.prod_beq state_beq state_beq;
            preleast_upper_bound x y
            := constant (least_upper_bound (fst x) (fst y), least_upper_bound (snd x) (snd y)) |};
  try abstract (
        repeat match goal with
               | _ => progress unfold Equality.prod_beq
               | [ |- RelationClasses.Equivalence _ ]
                 => split; repeat intro
               | [ |- well_founded _ ] => fail 1
               | [ |- is_true (?R ?x ?x) ] => reflexivity
               | [ |- is_true true ] => reflexivity
               | [ |- ?R ?x ?x ] => reflexivity
               | _ => congruence
               | [ |- Proper _ _ ] => unfold Proper, respectful
               | [ |- Transitive _ ] => intros ???; cbv beta
               | _ => progress intros
               | [ H : and _ _ |- _ ] => destruct H
               | [ H : prod _ _ |- _ ] => destruct H
               | _ => progress simpl in *
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => rewrite H in *; clear x H
               | [ H : is_true (state_beq ?x ?y) |- _ ]
                 => clear x H
               | [ |- context[(?x <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (x <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_l)
               | [ |- context[(?y <= least_upper_bound ?x ?y)%fixedpoint] ]
                 => replace (y <= least_upper_bound x y)%fixedpoint
                    with true by (symmetry; apply least_upper_bound_correct_r)
               | [ H : is_true true |- _ ] => clear H
               | [ H : is_true ?x |- context[?x] ]
                 => progress replace x with true by (symmetry; exact H)
               | [ H : is_true ?x, H' : context[?x] |- _ ]
                 => progress replace x with true in H' by (symmetry; exact H)
               | [ H : context[@state_beq ?A ?B ?x ?x] |- _ ]
                 => replace (@state_beq A B x x) with true in H by (symmetry; change (is_true (@state_beq A B x x)); reflexivity)
               | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ]
                 => unique pose proof (transitivity (R := R) H H' : is_true (R x z))
               | [ H : is_true (@state_le ?A ?B ?x ?y), H' : is_true (state_le ?y ?x) |- _ ]
                 => unique pose proof (@antisymmetry _ (@state_beq A B) _ (@state_le A B) _ x y H H' : is_true (state_beq x y))
               | [ |- context[is_true (negb ?x)] ]
                 => destruct x eqn:?; simpl; fold_is_true
               | _ => progress bool_congr_setoid
               | [ |- and _ _ ] => split
               end
      ).
  { unfold flip.
    eapply well_founded_subrelation; [ | eapply well_founded_prod_relationA with (eqA := state_beq) ];
      [ .. | eapply state_gt_wf | eapply state_gt_wf ].
    { intros x y H.
      unfold prod_relationA, flip, state_le, state in *.
      revert H.
      generalize (@state_lt _ fpldata0).
      generalize (@state_lt _ fpldata1).
      generalize (@state_beq _ fpldata0).
      generalize (@state_beq _ fpldata1).
      unfold state.
      clear.
      abstract (
          repeat match goal with
                 | _ => setoid_rewrite Bool.negb_andb
                 | _ => tauto
                 | _ => congruence
                 | _ => progress destruct_head and
                 | [ H : is_true ?x, H' : context[?x] |- _ ]
                   => progress replace x with true in H' by (symmetry; exact H)
                 | _ => progress simpl in *
                 | _ => progress bool_congr_setoid
                 | _ => progress intros
                 | _ => progress destruct_head or
                 end
        ). }
    { apply prod_relationA_Proper_from_Equivalence; try exact _; [].
      unfold flip; intros ??? x y H H'; subst.
      rewrite H; assumption. } }
Defined.

Global Instance prod_fixedpoint_lattice' {prestate0 prestate1}
       {fpldata0 : grammar_fixedpoint_lattice_data prestate0}
       {fpldata1 : grammar_fixedpoint_lattice_data prestate1}
  : grammar_fixedpoint_lattice_data (lattice_for prestate0 * lattice_for prestate1)
  := prod_fixedpoint_lattice.