(* Copyright © 2008-2008
 * Cezary Kaliszyk
 * Russell O'Connor
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qreals.
Require Import Coq.QArith.QArith_base.
Require Import CoRN.tactics.CornTac.
Require Import Coq.Reals.RIneq.
Require Import Coq.Reals.Rcomplete.
Require Import Coq.Reals.Rlimit.
Require Import Coq.Reals.Rbasic_fun.
Require Import CoRN.coq_reals.Rreals.
Require Import CoRN.reals.iso_CReals.
Require Import CoRN.reals.CauchySeq.
Require Import Coq.Reals.Rtrigo_def.
Require Import CoRN.transc.PowerSeries.
Require Import Coq.Logic.ConstructiveEpsilon.
Require Import Coq.Reals.Rlogic.
Require Export Coq.Reals.Reals.
Require Import CoRN.transc.Pi.
Require Import CoRN.transc.MoreArcTan.
Require Import CoRN.logic.PropDecid.
Require Import CoRN.transc.Exponential.
From Coq Require Import Lia Lra.

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

(* This changed in RLogic and should probably be moved there: *)
Lemma forall_dec : forall P:nat->Prop, (forall n, {P n} + {~ P n}) -> {forall n, P n} + {~forall n, P n}.
intros.
case (sig_forall_dec _ H) as [[n H1] | H1];intuition.
Qed.

(** * Coq Real Numbers and IR isomorphisms

 Warning: The Coq real numbers depend on classical logic.  Importing this
 module will give you classical logic, the axioms of Coq's real number
 structure, plus all the logical consquences of these axioms.  To avoid
 these consequences, use CoRN's real number structure [IR] instead.

 All real number structures are isomorphic.  This module uses this
 isomorphis to create a rewrite database [RtoIR] for converting many
 problems over [R] into problems over [IR] where constructive methods
 may be employed.
*)

(** ** The isomorphism *)

Lemma RIR_iso : Isomorphism RReals IR.
Proof.
 exact (Canonic_Isomorphism_between_CReals RReals IR).
Qed.

Definition RasIR : R -> IR := iso_map_lft _ _ RIR_iso.
Definition IRasR : IR -> R := iso_map_rht _ _ RIR_iso.

Lemma RasIRasR_id : forall (x:R), (IRasR (RasIR x)=x).
Proof.
 apply (inversity_rht _ _ RIR_iso).
Qed.

Lemma IRasRasIR_id : forall (x:IR), (RasIR (IRasR x)[=]x).
Proof.
 apply (inversity_lft _ _ RIR_iso).
Qed.

(** equality *)

Lemma R_eq_as_IR : forall x y, (x = y -> RasIR x [=] RasIR y).
Proof.
 apply: map_wd_unfolded.
Qed.

(** apartness *)

Lemma R_eq_as_IR_back : forall x y, (RasIR x [=] RasIR y -> x = y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 apply: map_wd_unfolded; assumption.
Qed.

Lemma R_ap_as_IR : forall x y, (RasIR x [#] RasIR y -> x <> y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 change (IRasR (RasIR x) [#] IRasR (RasIR y)).
 apply: map_pres_apartness; assumption.
Qed.

Lemma R_ap_as_IR_back : forall x y, (x <> y -> RasIR x [#] RasIR y).
Proof.
 intros x y H.
 apply map_pres_apartness.
 assumption.
Qed.

Lemma IR_ap_as_R : forall x y, (x <> y -> RasIR x [#] RasIR y).
Proof.
 intro.
 apply: map_pres_apartness.
Qed.

(** less-than *)

Open Scope R_scope.

Lemma R_lt_as_IR : forall x y, (RasIR x [<] RasIR y -> x < y).
Proof.
 intros x y H.
 replace x with (IRasR (RasIR x)) by apply RasIRasR_id.
 replace y with (IRasR (RasIR y)) by apply RasIRasR_id.
 change (IRasR (RasIR x) [<] IRasR (RasIR y)).
 apply: map_pres_less; assumption.
Qed.

Lemma R_lt_as_IR_back : forall x y, (x [<] y -> IRasR x < IRasR y).
Proof.
 intros x y H.
 change (IRasR x [<] IRasR y).
 apply: map_pres_less.
 assumption.
Qed.

Lemma IR_lt_as_R : forall x y, (x < y -> RasIR x [<] RasIR y).
Proof.
 intro.
 apply: map_pres_less.
Qed.

Lemma IR_lt_as_R_back : forall x y, (IRasR x < IRasR y -> x [<] y).
Proof.
 intros.
 stepl (RasIR (IRasR x)); [| now apply IRasRasIR_id].
 stepr (RasIR (IRasR y)); [| now apply IRasRasIR_id].
 apply map_pres_less.
 assumption.
Qed.

(** le *)

Lemma R_le_as_IR : forall x y, (RasIR x [<=] RasIR y -> x <= y).
Proof.
 intros x y H.
 cut (~ (y < x)).
  apply Rnot_lt_le.
 intro xy.
 revert H. rewrite -> leEq_def. intro H. apply H.
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma IR_le_as_R : forall x y, (x <= y -> RasIR x [<=] RasIR y).
Proof.
 intros x y H.
 rewrite -> leEq_def.
 intro xy.
 assert (~ (y < x)).
  apply RIneq.Rle_not_lt; assumption.
 apply H0.
 apply R_lt_as_IR.
 assumption.
Qed.

Lemma IR_le_as_R_back : forall x y, (IRasR x <= IRasR y -> x [<=] y).
Proof.
 intros.
 rewrite -> leEq_def.
 intro xy.
 cut (~ (IRasR y < IRasR x)); intro.
  apply H0.
  apply R_lt_as_IR.
  stepl y; [| now rewrite -> IRasRasIR_id; reflexivity].
  stepr x; [| now rewrite -> IRasRasIR_id; reflexivity].
  assumption .
 apply (RIneq.Rle_not_lt (IRasR y) (IRasR x)).
  assumption.
 assumption.
Qed.

(** zero *)

Lemma R_Zero_as_IR : (RasIR R0 [=] [0]).
Proof.
 apply map_pres_zero_unfolded.
Qed.

Lemma IR_Zero_as_R : (IRasR [0] = 0).
Proof.
 apply: map_pres_zero_unfolded.
Qed.

#[global]
Hint Rewrite R_Zero_as_IR : RtoIR.

(** one *)

Lemma R_One_as_IR : (RasIR R1 [=] [1]).
Proof.
 apply map_pres_one_unfolded.
Qed.

#[global]
Hint Rewrite R_One_as_IR : RtoIR.

Lemma IR_One_as_R : (IRasR [1] = R1).
Proof.
 apply: map_pres_one_unfolded.
Qed.

(** addition *)

Lemma R_plus_as_IR : forall x y, (RasIR (x+y) [=] RasIR x [+] RasIR y).
Proof.
 apply: map_pres_plus.
Qed.

#[global]
Hint Rewrite R_plus_as_IR : RtoIR.

Lemma IR_plus_as_R : forall x y, (IRasR (x[+]y) [=] IRasR x + IRasR y).
Proof.
 apply: map_pres_plus_unfolded.
Qed.

(** negation *)

Lemma R_opp_as_IR : forall x, (RasIR (- x) [=] ([--] (RasIR x))).
Proof.
 apply: map_pres_minus.
Qed.

#[global]
Hint Rewrite R_opp_as_IR : RtoIR.

Lemma IR_opp_as_R : forall x, (IRasR ([--] x) [=] (- (IRasR x))).
Proof.
 apply: map_pres_minus_unfolded.
Qed.

(** subtraction *)

Lemma R_minus_as_IR : forall x y, (RasIR (x-y) [=] RasIR x [-] RasIR y).
Proof.
 intros x y.
 unfold cg_minus.
 rewrite <- R_opp_as_IR.
 rewrite <- R_plus_as_IR.
 reflexivity.
Qed.

#[global]
Hint Rewrite R_minus_as_IR : RtoIR.

Lemma IR_minus_as_R : forall x y, (IRasR (x[-]y) [=] IRasR x - IRasR y).
Proof.
  intros x y.
  unfold Rminus.
  rewrite <- IR_opp_as_R.
  rewrite <- IR_plus_as_R.
  reflexivity.
Qed.

(** multiplication *)

Lemma R_mult_as_IR : forall x y, (RasIR (x*y) [=] RasIR x [*] RasIR y).
Proof.
 apply: map_pres_mult.
Qed.

#[global]
Hint Rewrite R_mult_as_IR : RtoIR.

Lemma IR_mult_as_R : forall x y, (IRasR (x[*]y) = IRasR x * IRasR y).
Proof.
 apply: map_pres_mult_unfolded.
Qed.

(** reciprocal *)

Lemma R_recip_as_IR : forall y Hy, (RasIR (1 / y) [=] ([1] [/] RasIR y [//] Hy)).
Proof.
 intros y Hy.
 simpl in Hy.
 assert (y [#] 0).
  apply: R_ap_as_IR.
  stepr ([0]:IR). assumption.
   symmetry.
  apply R_Zero_as_IR.
 change (1/y) with ([1] [/] y [//] X).
 eapply eq_transitive.
  unfold RasIR.
  apply (map_pres_inv_unfolded RReals IR).
 apply div_wd; reflexivity.
Qed.

#[global]
Hint Rewrite R_recip_as_IR : RtoIR.

(** division *)

Lemma R_div_as_IR : forall x y Hy, (RasIR (x/y) [=] (RasIR x [/] RasIR y [//] Hy)).
Proof.
 intros x y Hy.
 unfold Rdiv.
 rewrite -> R_mult_as_IR.
 rstepr ((RasIR x) [*] ([1] [/]RasIR y[//]Hy)).
 replace (/ y) with (1 / y).
  rewrite <- R_recip_as_IR; reflexivity.
 unfold Rdiv.
 ring.
Qed.

(** absolute value *)

Lemma R_abs_as_IR : forall x, RasIR (Rabs x) [=] AbsIR (RasIR x).
Proof.
 intro x.
 unfold Rabs.
 destruct (Rcase_abs x) as [Hx | Hx].
  cut (RasIR x[<=][0]).
   intro Hxn.
   rewrite -> (AbsIR_eq_inv_x (RasIR x) Hxn).
   autorewrite with RtoIR; reflexivity.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply less_leEq.
  apply IR_lt_as_R.
  assumption.
 cut ([0] [<=] RasIR x).
  intro Hxn.
  rewrite -> (AbsIR_eq_x _ Hxn).
  reflexivity.
 stepl (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_le_as_R.
 lra.
Qed.
#[global]
Hint Rewrite R_abs_as_IR : RtoIR.

(** parital sum *)

Lemma R_sum_as_IR : forall a m,
    RasIR (sum_f_R0 a m) [=] (seq_part_sum (fun i : nat => RasIR (a i)) (S m)).
Proof.
 intros a m.
 induction m.
  simpl.
  rational.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHm.
 simpl.
 reflexivity.
Qed.

(** infinite sum *)

Lemma R_infsum_as_IR_convergent : forall (y: R) a,
  infinit_sum a y -> convergent (fun i : nat => RasIR (a i)).
Proof.
 unfold infinit_sum.
 unfold convergent.
 intros y a conv.
 assert (cauchy := CV_Cauchy _ (exist _ y conv)).
 clear conv.
 unfold Cauchy_crit in cauchy.
 unfold Cauchy_prop.
 intros e e0.
 pose (new_e0 := R_lt_as_IR_back _ _ e0).
 rewrite -> IR_Zero_as_R in new_e0.
 assert (sig (fun N => forall n m : nat, (n >= N)%nat ->
   (m >= N)%nat -> R_dist (sum_f_R0 a n) (sum_f_R0 a m) < IRasR e )).
  apply constructive_indefinite_description_nat.
   intros N.
   apply forall_dec.
    intros n0.
   apply forall_dec.
   intros n1.
   apply imp_dec.
    unfold ge.
    destruct (le_gt_dec N n0).
     left; auto with *.
    right; auto with *.
   apply imp_dec.
    destruct (le_gt_dec N n1).
     left; auto with *.
    right; auto with *.
   apply Rlt_dec.
  apply cauchy; auto with *.
 destruct H as [N HN].
 exists (S N).
 intros m Hm.
 assert (N <= pred m)%nat by  auto with *.
 assert (HH := HN (pred m) N H (le_refl N)).
 clear - HH Hm.
 destruct m.
  exfalso.
  auto with *.
 rewrite <- R_sum_as_IR.
 rewrite <- R_sum_as_IR.
 rewrite <- R_minus_as_IR.
 apply AbsIR_imp_AbsSmall.
 stepl (RasIR (Rabs(sum_f_R0 a m - sum_f_R0 a N))); [| now apply R_abs_as_IR].
 apply less_leEq.
 unfold R_dist in HH.
 stepr (RasIR (IRasR e)); [| now apply IRasRasIR_id].
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma R_infsum_as_IR : forall (y: R) a,
  Rfunctions.infinit_sum a y -> forall prf,
  RasIR y [=] series_sum (fun i : nat => RasIR (a i)) prf.
Proof.
 intros y a Hay prf.
 unfold series_sum.
 unfold infinit_sum in *.
 apply Limits_unique.
 unfold Cauchy_Lim_prop2.
 simpl.
 clear prf.
 intros e He.
 assert (sig (fun N => forall n : nat, (n >= N)%nat -> R_dist (sum_f_R0 a n) y < IRasR e )).
  apply constructive_indefinite_description_nat.
   intros N.
   apply forall_dec.
   intros n0.
   apply imp_dec.
    unfold ge.
    destruct (le_gt_dec N n0).
     left; auto with *.
    right; auto with *.
   apply Rlt_dec.
  apply (Hay).
  unfold Rgt.
  apply R_lt_as_IR.
  stepl ([0]:IR); [| now symmetry;apply R_Zero_as_IR].
  stepr (e); [| now symmetry; apply IRasRasIR_id].
  assumption.
 destruct H as [N HN].
 exists (S N).
 intros m Hm.
 assert (N <= pred m)%nat.
  auto with *.
 assert (HH := HN (pred m) H).
 clear - HH Hm.
 destruct m.
  exfalso.
  auto with *.
 rewrite <- R_sum_as_IR.
 rewrite <- R_minus_as_IR.
 apply AbsIR_imp_AbsSmall.
 unfold R_dist in HH.
 simpl in HH.
 apply less_leEq.
 stepl (RasIR (Rabs(sum_f_R0 a m - y))); [| apply R_abs_as_IR].
 stepr (RasIR (IRasR e)); [| apply IRasRasIR_id].
 apply IR_lt_as_R.
 assumption.
Qed.

Lemma R_infsum_f_as_IR : forall (x y: R) f,
  Rfunctions.infinit_sum (f x) y -> forall prf,
  RasIR y [=] series_sum (fun i : nat => RasIR (f x i)) prf.
Proof.
 intros x y f cprf rprf.
 apply R_infsum_as_IR.
 assumption.
Qed.

(** factorial *)

Lemma R_nring_as_IR : forall i, RasIR (nring i) [=] nring i.
Proof.
 induction i.
  simpl.
  apply R_Zero_as_IR.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHi.
 reflexivity.
Qed.
#[global]
Hint Rewrite R_nring_as_IR : RtoIR.

Add Morphism RasIR with signature (@cs_eq _) ==> (@cs_eq _) as R_as_IR_wd.
Proof.
 intros.
 rewrite H.
 reflexivity.
Qed.

(** integers *)

Lemma R_pring_as_IR : forall x, RasIR (pring _ x) [=] pring _ x.
Proof.
 intro x.
 (*rewrite pring_convert.*)
 stepr (nring (R := IR) (nat_of_P x)).
  stepl (RasIR (nring (R := RReals) (nat_of_P x))).
   apply R_nring_as_IR.
  apply R_as_IR_wd.
  symmetry.
  apply (pring_convert RReals x).
 symmetry.
 apply (pring_convert IR x).
Qed.

Lemma R_zring_as_IR : forall x, RasIR (zring x) [=] zring x.
Proof.
 induction x; simpl.
   apply R_Zero_as_IR.
  apply R_pring_as_IR.
 rewrite -> R_opp_as_IR.
 rewrite -> R_pring_as_IR.
 reflexivity.
Qed.

Lemma INR_as_nring : forall x, INR x = nring (R:=RRing) x.
Proof.
 induction x.
  reflexivity.
 simpl nring.
 rewrite <- IHx.
 apply S_INR.
Qed.

Lemma IZR_as_zring : forall x, IZR x = zring (R:=RRing) x.
Proof.
 induction x.
   reflexivity.
  rewrite <- positive_nat_Z, <- INR_IZR_INZ.
  rewrite INR_as_nring.
  (* rewrite pring_convert *)
  symmetry.
  rewrite positive_nat_Z.
  apply (pring_convert RRing p).
 change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))).
 rewrite <- positive_nat_Z, <- INR_IZR_INZ.
 rewrite INR_as_nring.
 apply Ropp_eq_compat.
 symmetry.
 apply (pring_convert RRing p).
Qed.

Lemma R_IZR_as_IR : forall x, RasIR (IZR x) [=] zring x.
Proof.
 induction x.
   apply R_Zero_as_IR.
  rewrite <- positive_nat_Z, <- INR_IZR_INZ.
  rewrite R_INR_as_IR.
  rewrite -> R_nring_as_IR.
  auto with *.
 change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))).
 rewrite <- positive_nat_Z, <- INR_IZR_INZ.
 rewrite -> R_opp_as_IR.
 rewrite R_INR_as_IR.
 rewrite -> R_nring_as_IR.
 simpl zring.
 auto with *.
Qed.

#[global]
Hint Rewrite R_IZR_as_IR : RtoIR.

(** exponents *)

Lemma R_pow_as_IR : forall x i,
  RasIR (Rpow_def.pow x i)[=] nexp _ i (RasIR x).
Proof.
 intros x i.
 induction i.
  simpl.
  apply R_One_as_IR.
 simpl.
 autorewrite with RtoIR.
 rewrite -> IHi.
 auto with *.
Qed.
#[global]
Hint Rewrite R_pow_as_IR : RtoIR.

Lemma R_exp_as_IR : forall x, RasIR (exp x) [=] Exp (RasIR x).
Proof.
 unfold exp.
 unfold projT1.
 intro x; case (exist_exp x).
 unfold exp_in.
 intros y rsums.
 rewrite -> ( R_infsum_f_as_IR x y ((fun x i => / INR (fact i) * Rpow_def.pow x i)) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 simpl.
 apply series_sum_wd.
 intro i.
 autorewrite with RtoIR.
 replace (/ nring (fact i)) with (1 / nring (fact i)).
  2: field; apply (nring_fac_ap_zero RReals i).
 cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact i)))).
  intro Hy.
  rewrite -> (R_recip_as_IR (nring (fact i)) Hy).
  clear.
  rewrite -> (cg_inv_zero IR (RasIR x)).
  apply mult_wdl.
  apply div_wd.
   reflexivity.
  apply (R_nring_as_IR (fact i)).
 simpl.
 stepl (nring (R:=IR) (fact i)).
  apply (nring_fac_ap_zero IR i).
 symmetry.
 apply (R_nring_as_IR).
Qed.

#[global]
Hint Rewrite R_exp_as_IR : RtoIR.

(** trigonometry *)

Lemma R_cos_as_IR : forall x, RasIR (cos x) [=] Cos (RasIR x).
Proof.
 unfold cos.
 intro x.
 case (exist_cos (Rsqr x)).
 unfold cos_in.
 intros y rsums.
 rewrite -> (R_infsum_f_as_IR x y (fun x i => cos_n i * Rsqr x ^ i) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 simpl.
 unfold series_sum.
 apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
 induction n.
  reflexivity.
 simpl in *.
 rewrite -> IHn.
 rewrite (plus_comm n (S (n + 0))).
 simpl.
 rstepr ( seq_part_sum (fun n0 : nat =>
   (cos_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (RasIR x[-][0])) (n + 0 + n)[+] (
       (cos_seq (n + 0 + n)[/]nring (R:=IR) (fact (n + 0 + n))[//]
         nring_fac_ap_zero IR (n + 0 + n))[*]nexp IR (n + 0 + n) (RasIR x[-][0])[+]
           (cos_seq (S (n + 0 + n))[/]
             nring (R:=IR) (fact (n + 0 + n) + (n + 0 + n) * fact (n + 0 + n))[//]
               nring_fac_ap_zero IR (S (n + 0 + n)))[*]
                 (nexp IR (n + 0 + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ).
 apply bin_op_wd_unfolded.
  rewrite plus_comm.
  reflexivity.
 replace (n + 0 + n)%nat with (n + n)%nat by auto with *.
 unfold Rsqr.
 unfold cos_n.
 simpl.
 unfold cos_seq.
 simpl.
 destruct (even_or_odd_plus (n + n)).
 destruct (even_or_odd_plus (S(n + n))).
 simpl.
 destruct s; [ | exfalso; auto with *].
 destruct s0; simpl.
  exfalso; auto with *.
 autorewrite with RtoIR.
 stepr ( (nexp IR x0 [--][1][/]nring (R:=IR) (fact (n + n))[//]
   nring_fac_ap_zero IR (n + n))[*]nexp IR (n + n) (RasIR x[-][0]) ).
  apply bin_op_wd_unfolded.
   replace (n + 0)%nat with n by auto with *.
   assert (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n))))).
    simpl.
    stepr (RasIR 0); [| now apply R_Zero_as_IR].
    apply R_ap_as_IR_back.
    apply (nring_fac_ap_zero RReals (n + n)).
   rewrite -> (R_div_as_IR ((-1)^n) (nring (R := RRing) (fact (n + n))) X).
   apply div_wd.
    autorewrite with RtoIR.
    replace n with x0 by lia.
    reflexivity.
   autorewrite with RtoIR.
   reflexivity.
  clear.
  induction n; simpl.
   reflexivity.
  rewrite -> IHn.
  replace (n + S n)%nat with (S (n + n))%nat by auto with *.
  simpl.
  rstepr ( nexp IR (n + n) (RasIR x[-][0])[*]((RasIR x[-][0])[*](RasIR x[-][0])) ).
  apply bin_op_wd_unfolded.
   reflexivity.
  rational.
 setoid_replace (([0][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
   nring_fac_ap_zero IR (S (n + n)))[*] (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0])))
     with ([0]:IR).
  rational.
 rational.
Qed.

#[global]
Hint Rewrite R_cos_as_IR : RtoIR.

Lemma R_sin_as_IR : forall x, RasIR (sin x) [=] Sin (RasIR x).
Proof.
 unfold sin.
 intro x.
 case (exist_sin (Rsqr x)).
 unfold sin_in.
 intros y rsums.
 rewrite -> R_mult_as_IR.
 rewrite -> (R_infsum_f_as_IR x y (fun x i => sin_n i * Rsqr x ^ i) rsums
   (R_infsum_as_IR_convergent _ _ rsums) ).
 assert (convergent (fun n : nat => RasIR x[*](fun i : nat => RasIR (sin_n i * Rsqr x ^ i)) n)).
  apply conv_series_mult_scal.
  apply (R_infsum_as_IR_convergent _ _ rsums).
 rewrite <- (series_sum_mult_scal (fun i : nat => RasIR (sin_n i * Rsqr x ^ i))
   (R_infsum_as_IR_convergent _ _ rsums) (RasIR x) X).
 simpl.
 unfold series_sum.
 apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat.
   intros; lia.
  intros n; exists (S n); lia.
 induction n.
  reflexivity.
 simpl in *.
 rewrite -> IHn.
 rewrite (plus_comm n (S (n + 0))).
 simpl.
 replace (n + 0 + n)%nat with (n + n)%nat by auto with *.
 unfold sin_n.
 simpl.
 replace (n + 0)%nat with (n)%nat by auto with *.
 unfold sin_seq at 3.
 unfold sin_seq at 3.
 simpl.
 destruct (even_or_odd_plus (n + n)).
 destruct (even_or_odd_plus (S(n + n))).
 destruct s; [ | exfalso; auto with *].
 destruct s0; simpl.
  exfalso; auto with *.
 rstepr ( seq_part_sum (fun n0 : nat =>
   (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*]
     nexp IR n0 (RasIR x[-][0])) (n + n)[+](
       ([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*]
         nexp IR (n + n) (RasIR x[-][0])[+]
           (nexp IR x1 [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
             nring_fac_ap_zero IR (S (n + n)))[*]
               (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ).
 apply bin_op_wd_unfolded.
  reflexivity.
 setoid_replace (RasIR x [-] [0]) with (RasIR x);[|rational].
 replace x1 with n by lia.
 clear.
 setoid_replace (([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*]
   nexp IR (n + n) (RasIR x)) with ([0]:IR);[|rational].
 rstepr ( RasIR x [*] ( (nexp IR n [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//]
   nring_fac_ap_zero IR (S (n + n)))[*](nexp IR (n + n) (RasIR x))) ).
 apply bin_op_wd_unfolded.
  reflexivity.
 autorewrite with RtoIR.
 unfold Rsqr.
 apply bin_op_wd_unfolded.
  cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n + 1))))).
   intro X.
   rewrite -> (R_div_as_IR ((-1)^n) (nring (R:=RRing) (fact (n + n + 1))) X).
   apply div_wd.
    autorewrite with RtoIR; reflexivity.
   autorewrite with RtoIR.
   apply nring_wd.
   replace (n + n + 1)%nat with (S (n + n)) by lia.
   simpl.
   reflexivity.
  simpl.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply R_ap_as_IR_back.
  apply (nring_fac_ap_zero RReals (n + n + 1)).
 induction n; simpl.
  reflexivity.
 replace (n + S n)%nat with (S(n + n)) by lia.
 simpl.
 rewrite -> IHn.
 autorewrite with RtoIR.
 rational.
Qed.

#[global]
Hint Rewrite R_sin_as_IR : RtoIR.

Lemma R_tan_as_IR : forall x dom, RasIR (tan x) [=] Tan (RasIR x) dom.
Proof.
 intros x dom.
 unfold tan.
 cut (Dom (f_rcpcl' IR) (RasIR (cos x))).
  intro Hdiv.
  rewrite -> (R_div_as_IR (sin x) (cos x) Hdiv).
  cut (Dom (f_rcpcl' IR) (Cos (RasIR x))).
   intro ndom.
   stepl (Sin(RasIR x) [/] Cos(RasIR x) [//] ndom).
    unfold Tan.
    unfold Tang.
    apply: div_wd.
     apply: pfwdef.
     reflexivity.
    apply: pfwdef.
    reflexivity.
   apply div_wd.
    symmetry; apply R_sin_as_IR.
   symmetry; apply R_cos_as_IR.
  unfold pfdom,f_rcpcl' in *.
  stepl (RasIR (cos x)); [| now apply R_cos_as_IR].
  assumption.
 unfold pfdom,f_rcpcl', Tang,Fdiv in *.
 destruct dom.
 destruct e.
 stepl (Cos (RasIR x)); [| now symmetry; apply R_cos_as_IR].
 apply: c.
Qed.

(** logarithm *)

Lemma R_ln_as_IR : forall x prf, RasIR (ln x) [=] Log (RasIR x) prf.
Proof.
 intros x prf.
 apply Exp_cancel.
 rewrite -> Exp_Log.
 rewrite <- R_exp_as_IR.
 apply R_as_IR_wd.
 apply exp_ln.
 apply R_lt_as_IR.
 stepl ([0]:IR); [| now symmetry; apply R_Zero_as_IR].
 assumption.
Qed.

(** pi *)

Lemma R_pi_as_IR : RasIR (PI) [=] Pi.
Proof.
 assert (Sin (RasIR PI) [=] [0]).
  rewrite <- R_sin_as_IR.
  rewrite sin_PI.
  apply R_Zero_as_IR.
 assert (Not (forall z : Z, RasIR PI[#]zring (R:=IR) z[*]Pi)).
  unfold Not.
  intro X.
  apply ((eq_imp_not_ap _ _ _ H) (Sin_ap_Zero (RasIR (PI)) X)).
 clear H.
 apply (not_ap_imp_eq).
 intro PiNot.
 elim H0.
 intro z.
 elim z.
   simpl.
   rstepr ([0]:IR).
   stepr (RasIR 0); [| now apply R_Zero_as_IR].
   apply R_ap_as_IR_back.
   apply PI_neq0.
  intro p.
  rewrite <- convert_is_POS.
  stepr (nring (R := IR) (nat_of_P p) [*] Pi); [| now apply mult_wdl; symmetry; apply (zring_plus_nat IR)].
  case (nat_of_P p).
   simpl.
   rstepr ([0]:IR).
   stepr (RasIR 0); [| now apply R_Zero_as_IR].
   apply R_ap_as_IR_back.
   apply PI_neq0.
  intro n.
  case n.
   simpl.
   rstepr (Pi).
   assumption.
  intro n0.
  apply less_imp_ap.
  apply leEq_less_trans with Four.
   rstepr (([1] [+] [1]) [*] ([1] [+] [1]):IR).
   rewrite <- R_One_as_IR.
   rewrite <- R_plus_as_IR.
   rewrite <- R_mult_as_IR.
   apply IR_le_as_R.
   apply PI_4.
  apply less_leEq_trans with (Two [*] Pi).
   rstepl (Two [*] Two:IR).
   apply mult_resp_less_lft.
    apply Pi_gt_2.
   rstepr (([0] [+] [1]) [+] [1] : IR).
   apply plus_one_ext_less.
   apply zero_lt_posplus1.
   apply eq_imp_leEq.
   reflexivity.
  apply mult_resp_leEq_rht.
   simpl.
   apply (plus_resp_leEq).
   apply (plus_resp_leEq).
   stepl (nring (R := IR) 0); [| now auto with *].
   apply nring_leEq; auto with *.
  apply less_leEq.
  apply pos_Pi.
 intro p.
 apply Greater_imp_ap.
 simpl.
 apply leEq_less_trans with ([0]:IR).
  rewrite -> pring_convert.
  apply less_leEq.
  apply inv_cancel_less.
  rstepl ([0][*][0]:IR).
  rstepr ((nring (R:=IR) (nat_of_P p))[*]Pi).
  apply mult_resp_less_both.
     apply eq_imp_leEq.
     reflexivity.
    rstepl (nring (R := IR) 0) .
    apply nring_less.
    auto with *.
   apply eq_imp_leEq.
   reflexivity.
  auto with *.
 stepl (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_lt_as_R.
 apply PI_RGT_0.
Qed.

Lemma R_pi_alt_as_IR : RasIR (Alt_PI) [=] pi.
Proof.
 unfold Alt_PI.
 unfold pi.
 destruct (exist_PI) as [x prf].
 unfold pi_series.
 unfold tg_alt in prf.
 unfold PI_tg in prf.
 rewrite -> R_mult_as_IR.
 apply mult_wd.
  change 4 with ((1 + 1) * (1 + 1)).
  rewrite -> R_mult_as_IR.
  rewrite -> R_plus_as_IR.
  rewrite -> R_One_as_IR.
  rational.
 rewrite -> (R_infsum_as_IR x ( (fun i : nat => (-1) ^ i * / INR (2 * i + 1))
   ) prf (R_infsum_as_IR_convergent _ _ prf) ).
 apply series_sum_wd.
 intro n.
 autorewrite with RtoIR.
 apply mult_wd.
  simpl; reflexivity.
 stepr (RasIR (1 / nring (R:=RRing) (2 * n + 1))).
  apply R_as_IR_wd.
  unfold Rdiv.
  simpl; auto with *.
 cut (n + (n + 0) + 1 = S (n + n))%nat.
  intro DF.
  cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RReals) (2 * n + 1)))).
   intro H.
   rewrite -> (R_recip_as_IR (nring (R:=RReals) (2 * n + 1)) H).
   apply div_wd.
    reflexivity.
   rewrite -> R_nring_as_IR.
   apply nring_wd.
   rewrite <- DF.
   simpl.
   auto.
  simpl.
  stepr (RasIR 0); [| now apply R_Zero_as_IR].
  apply R_ap_as_IR_back.
  apply Rgt_not_eq.
  rewrite DF.
  unfold Rgt.
  change ([0] [<] nring (R:=RRing) (S (n + n))).
  apply pos_nring_S.
 auto with *.
Qed.

#[global]
Hint Rewrite R_pi_as_IR : RtoIR.

(** rationals *)

Lemma R_Q2R_as_IR : forall q, RasIR (Q2R q) [=] inj_Q IR q.
Proof.
 intro q.
 destruct q.
 unfold Q2R.
 cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (nat_of_P Qden)))).
  intro Hy.
  stepr (RasIR (zring (R:=RRing) Qnum)[/]RasIR (nring (R:=RRing) (nat_of_P Qden))[//]Hy).
   stepl (RasIR (zring (R:=RRing) Qnum / nring (R:=RRing) (nat_of_P Qden))).
    apply (R_div_as_IR (zring Qnum) (nring (nat_of_P Qden))).
   apply R_as_IR_wd.
   unfold Rdiv.
   replace (nring (R:=RRing) (nat_of_P Qden)) with (INR (nat_of_P Qden)).
    replace (zring (R:=RRing) Qnum) with (IZR Qnum).
     now rewrite <- positive_nat_Z, INR_IZR_INZ.
    apply IZR_as_zring.
   apply INR_as_nring.
  apply div_wd.
   apply R_zring_as_IR.
  apply R_nring_as_IR.
 simpl.
 stepr (RasIR 0); [| now apply R_Zero_as_IR].
 apply IR_ap_as_R.
 apply Rgt_not_eq.
 unfold Rgt.
 replace 0 with (nring (R:=RRing) 0).
  change ((nring (R:=RRing) 0 [<] nring (R:=RRing) (nat_of_P Qden))).
  apply nring_less.
  auto with *.
 auto with *.
Qed.

#[global]
Hint Rewrite R_Q2R_as_IR : RtoIR.

Close Scope R_scope.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Load "eztactics.v".

Require Import Arith.
Require Import List.

Add LoadPath "Listkit" as Listkit.

Require Import Listkit.AllType.
Require Import Listkit.AllType.
Require Import Listkit.Foreach.
Require Import Listkit.Map.
Require Import Listkit.NthError.
Require Import Listkit.Sets.
Require Import Listkit.listkit.

Require Import OutsideRange.
Require Import Shift.
Require Import Term.
Require Import Typing.

Hint Rewrite map_length: map.

(*Section Subst.*)

(** Until I did all this, I didn't realize that substitution was a big
ask; a complex function with an algorithm in its own right. *)

Ltac map_lia :=
   autorewrite with map; lia.

(** * Simultaneous substitution of a list of terms beginning at De Bruijn index k *)
Fixpoint subst_env k vs tm {struct tm} :=
  match tm with
  | TmConst => tm
  | TmVar x =>
    if le_gt_dec k x then
      match nth_error vs (x - k) with
      | None => tm
      | Some v => v
      end
    else tm
  | TmPair l m => TmPair (subst_env k vs l) (subst_env k vs m)
  | TmProj b m => TmProj b (subst_env k vs m)
  | TmApp l m => TmApp (subst_env k vs l) (subst_env k vs m)
  | TmAbs n => TmAbs (subst_env (S k) (map (shift 0 1) vs) n)
  | TmNull => TmNull
  | TmSingle m => TmSingle (subst_env k vs m)
  | TmUnion m n => TmUnion (subst_env k vs m) (subst_env k vs n)
  | TmBind m K => TmBind (subst_env k vs m) (subst_env (S k) (map (shift 0 1) vs) K)
  | TmIf b m n => TmIf (subst_env k vs b) (subst_env k vs m) (subst_env k vs n)
  | TmTable ty => tm
  end.

Ltac break_ne :=
  match goal with
  | |- context C [nth_error (map ?f ?A) ?B]
  => rewrite nth_error_map
  | H: nth_error ?A ?B = ?C |- context C [nth_error ?A ?B]
  => rewrite H
  | |- context C [match nth_error ?A ?B with _ => _ end]
        => let a := fresh "a" in
           let b := fresh "b" in
           let c := fresh "c" in
           let d := fresh "d" in
              nth_error_dichotomize a b c d (* bounds is_error v v_def *)
        end.

(* This "magic" tactic is quite likely to solve goals involing subst_env. *)
Ltac magic :=
  (repeat double_case; simpl);
  (repeat (rewrite nth_error_map); simpl);
  (repeat breakauto; simpl);
  (repeat (rewrite nth_error_map); simpl);
  (repeat break_ne; simpl);
  try solve [auto | lia].

Lemma subst_env_nonfree_noop:
  forall N T env Vs n,
    Typing env N T ->
    n >= length env ->
      subst_env n Vs N = N.
Proof.
 induction N; simpl; intros T env Vs n tp n_big;
   auto; inversion tp; try (f_equal; eauto).
 (* Case TmVar *)
  break; [ | sauto].
  subst.
  case_eq (nth_error Vs (x - n)); [ | sauto].
  absurd (x < length env).
    efinish.
   efinish_new NthError.
 (* Case TmAbs *)
 eapply IHN; efinish.
 (* Case TmBind *)
 eapply IHN2 with (T:=TyList t).
  apply H3.
 simpl; lia.
Qed.

Lemma subst_env_closed_noop:
  forall N T Vs n,
    Typing nil N T ->
      subst_env n Vs N = N.
Proof.
 intros.
 eapply subst_env_nonfree_noop; eauto.
 simpl; lia.
Qed.

    (* env_typing Vs env' -> *)
    (* x < length Vs & x < length env' & Typing (TmVar x) T *)
Lemma subst_env_preserves_typing_var:
  forall x Vs env env' T k,
    env_typing Vs env' ->
    Typing (env ++ env') (TmVar x) T ->
    k = length env ->
      Typing env (subst_env k Vs (TmVar x)) T.
Proof.
 simpl; intros x Vs env env' T k Vs_tp tp k_eq; inversion tp; subst.
 destruct Vs_tp as [Vs_env'_equilong Vs_tp].
 destruct (le_gt_dec (length env) x).
 - (* Case x is beyond [length env] *)
   case_eq (nth_error Vs (x - length env));
     [intros v H_v | intros H_v]; auto.
   (* Obtained value v for x - length env in Vs. *)
    apply Weakening_closed.
    eapply foreach2_ty_member; eauto.
    auto with NthError.
   (* Bogus case of no value for x - length env. *)
   refute.
   apply nth_error_ok_rev in H0.
   apply <- nth_error_overflow in H_v.
   rewrite app_length in H0.
   lia.
 - (* Case of x in env. *)
  apply TVar.
  rewrite nth_error_ext_length in H0; auto.
Qed.

(**
       Vs :: env'
env, env' |- M       : T
env       |- M{Vs/k} : T    (where k = length env)
*)
Lemma subst_env_preserves_typing:
  forall M Vs env env' T k,
    env_typing Vs env' ->
    Typing (env ++ env') M T ->
    k = length env ->
      Typing env (subst_env k Vs M) T.
Proof.
 induction M; simpl; intros Vs env env' T k Vs_tp tp k_eq;
    inversion tp; subst; eauto.
 - (* Case TmVar *)
   eapply subst_env_preserves_typing_var; eauto.
 - (* Case TmAbs *)
   apply TAbs.
   replace (S (length env)) with (length (s::env)) by trivial.
   apply IHM with env'; trivial.
   erewrite env_typing_shift_noop; eauto.
 - (* Case TmBind *)
   eapply TBind; eauto using IHM1, IHM2.
   erewrite env_typing_shift_noop; eauto.
Qed.

(* Note: Used only in one place, in sn.v! *)
#[export] Hint Resolve subst_env_preserves_typing : Subst.

Lemma subst_nil :
  forall N k, subst_env k nil N = N.
Proof.
 induction N; intros k; simpl; try (solve [f_equal; eauto]).
 (* Case TmVar *)
 rewrite nth_error_nil.
 destruct (le_gt_dec k x); auto.
Qed.

Lemma subst_env_one:
  forall n n' M env,
    n = n' ->
    subst_env n (M::env) (TmVar n') = M.
Proof.
  intros.
  simpl.
  destruct (le_gt_dec n n'); try lia.
  replace (n' - n) with 0 by lia.
  auto.
Qed.

Lemma subst_env_noop:
  forall n x M,
    n <> x ->
    subst_env n (M::nil) (TmVar x) = TmVar x.
Proof.
 intros; simpl.
 break.
 - break_ne.
   { auto. }
   simpl in *.
   lia.
 - auto.
Qed.

(** If a variable is bigger than [q + length env] then it is untouched
 by substituting ([q], [env]). *)
(* TODO: This might be a lemma that would be immediate from a lemma about
   subst_env and freevars. *)
Lemma subst_env_big_var :
  forall q x env,
    q + length env <= x ->
      subst_env q env (TmVar x) = TmVar x.
Proof.
 intros.
 simpl.
 break; auto.
 nth_error_dichotomize bounds is_error v v_def; auto.
 finish.
Qed.

Lemma shift_subst_commute_hi_var:
  forall (x : nat) (env : list Term) (k q n : nat),
    q + length env <= k ->
    shift k n (subst_env q env (TmVar x)) =
    subst_env q (map (shift k n) env) (shift k n (TmVar x)).
Proof.
  intros.
  unfold shift at 3.
  unfold shift_var.
  destruct (le_gt_dec k x) ; [ | ].
   rewrite subst_env_big_var by lia.
   rewrite subst_env_big_var.
    simpl; unfold shift_var.
    break; finish.
   solve[map_lia].
  repeat (magic; unfold shift_var; simpl).
Qed.

Lemma shift_subst_commute_helper:
  forall M env k q n,
    subst_env q (map (shift (S k) n) (map (shift 0 1) env)) M =
    subst_env q (map (shift 0 1)     (map (shift k n) env)) M.
Proof.
  intros.
  f_equal.
  repeat (rewrite map_map).
  apply map_ext; intros x.
  apply shift_shift_commute.
  lia.
Qed.

Lemma shift_subst_commute_hi:
  forall M env k q n,
    q + length env <= k ->
    shift k n (subst_env q env M) =
      subst_env q (map (shift k n) env) (shift k n M).
Proof.
 induction M; intros env k q n k_overbounds_subst; simpl; try (f_equal; eauto).

 (* Case TmVar *)
- apply shift_subst_commute_hi_var; auto.

 (* Case TmAbs *)
 - rewrite IHM by map_lia.
   apply shift_subst_commute_helper.

 (* Case TmBind *)
 - rewrite IHM2 by map_lia.
   apply shift_subst_commute_helper.
Qed.

Lemma shift_subst_commute_lo:
  forall M env k q n,
    k <= q ->
    shift k n (subst_env q env M) =
      subst_env (q + n) (map (shift k n) env) (shift k n M).
Proof.
 induction M; simpl; intros env k q n k_low; try (f_equal; eauto).
 (* TmVar *)
        unfold shift_var.
        (* Take cases on where x is in relation to k, q: *)
        case_eq (le_gt_dec q x); intros;
          case_eq (le_gt_dec k x); intros; try (solve[exfalso;lia]);
          destruct (le_gt_dec (q + n) (x + n)); try (solve[exfalso;lia]).
        (* Case k <= q <= x. *)
          replace (x + n - (q + n)) with (x - q) by lia.
          (* Take cases on whether x - q is defined in env: *)
          nth_error_dichotomize index_hi result_none V V_def;
            rewrite nth_error_map ; (rewrite result_none || rewrite V_def);
          simpl; unfold shift_var.
          (* Case length env <= x - q. *)
           rewrite H0; sauto.
          (* Case x - q < length env. *)
          sauto.
        (* Case k <= x < q. *)
         simpl; unfold shift_var.
         solve [breakauto].
        (* Case x < k <= q. *)
        breakauto.
        simpl; unfold shift_var.
        rewrite H0; sauto.

 (* Case TmAbs *)
     rewrite IHM by lia.
     apply shift_subst_commute_helper.

 (* Case TmBind *)
 rewrite IHM2 by lia.
 apply shift_subst_commute_helper.
Qed.

(** If two successive substitutions are "independent" and adjacent then we can combine
   them into one (on a var). *)
Lemma subst_env_concat_TmVar:
  forall (x : nat) (Vs Ws : list Term) (env : list Ty) (k : nat),
    env_typing (Vs ++ Ws) env ->
    length (Vs ++ Ws) = length env ->
       subst_env k Vs (subst_env (k + length Vs) Ws (TmVar x)) =
       subst_env k (Vs ++ Ws) (TmVar x).
Proof.
 intros ? ? ? ? ? env_closed VsWs_env_equilong.
 unfold subst_env at 3.
 unfold subst_env at 2.
 unfold env_typing in *.

 case_eq (le_gt_dec k x); [intros k_le_x ?|intros x_gt_x H].
 (* Case k <= x *)
  replace (x - (k + length Vs)) with (x - k - length Vs) by lia.

  destruct (equilong_nth_error Term Ty (Vs ++ Ws) env (x - k))
        as [[x_small [VW' [T' HH]]] | [x_large HH]]; trivial;
    destruct HH as [lookup_VWs lookup_env].
  (* Case x < k + length (Vs ++ Ws) *)
   destruct (le_gt_dec (k + length Vs) x).
   (* Case k + length Vs <= x *)
    rewrite <- rewrite_nth_error_app; [|lia].
    rewrite lookup_VWs; simpl.
    (* subst_env k Vs VW' = VW': *)
    apply subst_env_closed_noop with T'.
    (* Typing nil VW' T': *)
    eapply foreach2_ty_member; eauto.
    apply env_closed.
   (* Case k + length Vs > x *)
   simpl; rewrite H.
   (rewrite nth_error_ext_length in lookup_VWs by lia);
   (rewrite nth_error_ext_length by lia; reflexivity).

  (* Case x >= k + length (Vs ++ Ws) *)
  rewrite app_length in x_large.
  rewrite <- rewrite_nth_error_app; [|lia].
  rewrite lookup_VWs; simpl.
  double_case.
  apply subst_env_big_var; lia.

 (* Case k > x *)
 break; [exfalso; lia| ].
 simpl.
 rewrite H; easy.
Qed.

(** If two successive substitutions are "independent" and adjacent then we can combine
   them into one. *)
Lemma subst_env_concat:
  forall N Vs Ws env k,
    env_typing (Vs ++ Ws) env->
    let k' := k + length Vs in
    let VWs := Vs ++ Ws in
      subst_env k Vs (subst_env k' Ws N) = subst_env k (VWs) N.
Proof.
 let triage := solve[simpl; f_equal; eauto] in
 induction N; intros Vs Ws env k env_closed;
     inversion env_closed as [VsWs_env_equilong env_closed'];
     trivial; try triage.

 (* Case TmVar *)
  eapply subst_env_concat_TmVar; eauto.

 (* Case TmAbs *)
  simpl; f_equal.
  rewrite map_app.
  replace (length Vs) with (length (map (shift 0 1) Vs)); [|apply map_length].
  replace (S (k + length (map (shift 0 1) Vs))) with
     (S k + length (map (shift 0 1) Vs)); [|easy].
  apply IHN with env; auto.
  rewrite <- map_app.
  erewrite env_typing_shift_noop; eauto.

 (* Case TmBind *)
 simpl; f_equal; eauto.
 rewrite map_app.
 replace (length Vs) with (length (map (shift 0 1) Vs)); [|apply map_length].
 replace (S(k + length (map (shift 0 1) Vs))) with
    (S k + length (map (shift 0 1) Vs)); [|easy].
 apply IHN2 with env; auto.
 rewrite <- map_app.
 erewrite env_typing_shift_noop; eauto.
Qed.

(** Shifting creates a term with a "dummy" (unused) variable;
    substituting at that variable has no effect, so we can drop it off
    the environment for substitution. *)
Lemma subst_dummyvar :
  forall N h t k,
    subst_env k (h::t) (shift k 1 N) = subst_env (S k) t (shift k 1 N).
Proof.
 induction N; intros h t1 k; try (solve[simpl; f_equal; eauto]).
 (* TmVar *)
 unfold shift, shift_var.
 destruct (le_gt_dec k x).
  unfold subst_env.
  replace (x + 1 - k) with (S (x - k)) by lia.
  replace (nth_error (h::t1) (S (x - k))) with (nth_error t1 (x - k)) by auto.
  replace (x + 1 - (S k)) with (x - k) by lia.
  repeat breakauto.
 unfold subst_env.
 repeat breakauto.
Qed.

Lemma subst_var_outside_range:
  forall q env x,
    outside_range q (length env + q) x = true ->
      subst_env q env (TmVar x) = TmVar x.
Proof.
 unfold outside_range.
 intros.
 simpl.
 magic.
 break_in H; lia. (* Maybe break should explore hypotheses anyway? *)
Qed.

Lemma subst_var_inside_range:
  forall q env x,
    outside_range q (length env + q) x = false ->
      exists X, value X = nth_error env (x - q) /\
                (subst_env q env (TmVar x)) = X.
Proof.
 unfold outside_range.
 intros.
 simpl.
 break_in H. (* If break_in were done in magic, whole proof would be automated. *)
 - magic.
   * break_in H; easy.
   * eauto.
 - easy.
Qed.

Definition set_remove := Listkit.Sets.set_remove.

(** [unshift q k] commutes with subst, if we offset the environment by
    [k] and [shift q k] all its terms.

    TODO: Consider making this use outside_range.
*)
Lemma subst_unshift :
  forall M env q k n,
    q <= n ->
    all_Type _ eq_nat_dec (fun x => Outside_Range q (k + q) x) (freevars M) ->
      subst_env n env (unshift q k M) =
      unshift q k (subst_env (n + k) (map (shift q k) env) M).
Proof.
 induction M; simpl; intros env q k n q_le_n fvs_dichot;
   try (apply all_Type_union_rev in fvs_dichot; destruct fvs_dichot);
   try (f_equal; eauto).
 (* Case TmVar *)
     assert (H : {x < q} + {x >= k + q}).
      unfold all_Type in fvs_dichot.
      apply fvs_dichot.
      simpl.
      auto.
     unfold unshift, shift, unshift_var, shift_var.
     simpl.
     rewrite nth_error_map.
     replace (x - (n + k)) with (x - k - n) by lia.

     destruct H.
     (* x < q *)
      break; break; break; try break; finish.
     (* x >= k + q *)
     destruct (le_gt_dec (k + q) x); [ | finish].
     destruct (le_gt_dec n (x - k)).
      destruct (le_gt_dec (n + k) x); [ | finish].
      nth_error_dichotomize bounds is_error v v_def.
       break; finish.
      rewrite unshift_shift; auto.
     destruct (le_gt_dec (n + k) x); [ finish | ].
     break; finish.

 (* Case TmAbs *)
  simpl in *.
  rewrite map_map.
  replace (map (fun x => shift 0 1 (shift q k x)) env)
     with (map (fun x => shift (S q) k (shift 0 1 x)) env)
       by (apply map_ext ; intro M'; apply shift_shift_commute; solve [auto|lia]).
  rewrite IHM.
    rewrite -> map_map; solve [trivial].
   solve [lia].

  (* Obligation: that if {x - 1 | x \in (S \\ {0})} is all outside [q, k + q),
     then {x | x \in S} is all outside [Sq, k + Sq). *)
  clear IHM.
  unfold all_Type in *.
  intros x H.
  destruct x.
   unfold Outside_Range.
   left; lia.
  specialize (fvs_dichot x).
  lapply fvs_dichot.
  unfold Outside_Range; firstorder lia.
  replace x with (pred (S x)) by lia.
  apply set_map_intro.
  solve [auto with Listkit].

 (* Case TmBind *)
 rewrite IHM2; (try lia || auto).
  f_equal.
  apply shift_subst_commute_helper.
 apply all_Type_map_fwd in a0.
 unfold all_Type.
 unfold all_Type in a0.
 intros.
 unfold Term.set_remove in a0.
 destruct (eq_nat_dec x 0).
  subst x.
  unfold Outside_Range.
  left; lia.
 specialize (a0 x).
 lapply a0.
  unfold Outside_Range.
  intros H0.
  destruct H0.
   left; lia.
  right; lia.
 apply set_remove_intro.
 intuition.

 (* Case TmIf *)
 apply all_Type_union_rev in a0 as [a0 a1].
 rewrite (IHM2 _ _ _ _); auto.
 apply all_Type_union_rev in a0 as [a0 a1].
 rewrite (IHM3 _ _ _ _); auto.
Qed.

Import Setoid.

Lemma union_distrib: forall A B C, eq_sets _ (A ∪ (B ∪ C)) ((A ∪ B) ∪ (A ∪ C)).
Proof.
 intros.
 split; solve_set_union_inclusion.
Qed.

(* Notation "{ q / env } M" := (subst_env q env M) (at level 100). *)
Notation "A ⊆ B" := (incl_sets nat A B) (at level 100).
Notation "A % x" := (Term.set_remove nat eq_nat_dec x A) (at level 100).

Lemma subst_freevars_binder:
 forall M env q,
 set_map Nat.eq_dec Init.Nat.pred
   ((set_unions nat Nat.eq_dec (map freevars (map (shift 0 1) env))
     ∪ set_filter nat
         (fun x : nat =>
          outside_range (S q) (length (map (shift 0 1) env) + S q) x)
         (freevars M)) % 0)
 ⊆ (set_unions nat Nat.eq_dec (map freevars env)
    ∪ set_filter nat (fun x : nat => outside_range q (length env + q) x)
        (set_map Nat.eq_dec Init.Nat.pred (freevars M % 0))).
Proof.
 intros M env q.

 (* consider that this works as well as the explicit rewrites below :-/ *)
 (* Hint Rewrite map_length map_map set_filter_map union_remove unions_remove map_union set_unions_map : idunno. *)
 (* autorewrite with idunno. *)

 rewrite map_length.
 rewrite map_map.
 rewrite set_filter_map.
 rewrite union_remove.
 rewrite unions_remove.
 rewrite map_map.
 rewrite map_union.
 rewrite set_unions_map.
 rewrite map_map.

 (* Corresponding sides of the union are \subseteq *)

 apply incl_sets_union.
 (* Left side *)
  rewrite <- filter_remove.
  set (f := fun x : nat => outside_range (S q) (length env + S q) x).
  set (g := fun x : nat => outside_range q (length env + q) (pred x)).
  rewrite filter_extensionality with (g:=g); [solve [auto with Listkit]|].
  intros.
  assert (x <> 0).
   apply set_remove_elim in H.
   intuition.
  unfold f, g.
  unfold outside_range.
  break; break; try (break; try break); auto; finish.
 (* Right side *)
 apply unions2_mor.
 apply compwise_eq_sets_map.
 intros x.
 setoid_replace (set_remove nat eq_nat_dec 0 (freevars (shift 0 1 x)))
        with (freevars (shift 0 1 x)).
 rewrite pred_freevars_shift; solve [auto with Listkit].
 solve[apply remove_0_shift_0_1].
Qed.

(** After making a substitution, the freevars of the result is:
     - the freevars of the original term,
     - less the range of variables we replaced
     - union the freevars of all the substituted terms.
 *)
Lemma subst_freevars:
  forall M env q,
    incl_sets _
      (freevars (subst_env q env M))
      (set_union eq_nat_dec
        (set_unions nat eq_nat_dec (map freevars env))
        (set_filter nat (fun x => outside_range q (length env + q) x) (freevars M))).
Proof.
 induction M; intros env q.
 (* Case TmConst *)
            simpl; solve [auto with Listkit].

 (* Case TmVar *)
           case_eq (outside_range q (length env + q) x); intro H.
           (* Case x is outside [q, k + q). *)
            rewrite subst_var_outside_range by trivial.
           simpl.
           rewrite H.
           apply incl_sets_union2.

           (* Case x is inside [q, k + q). *)
           destruct (subst_var_inside_range q env x H) as [M [H0 H1]].
           rewrite H1.
           apply incl_union_left.
           apply nth_error_set_unions with (n := x - q).
           rewrite nth_error_map.
           rewrite <- H0.
           sauto...

 (* Case TmPair *)
          simpl.
          rewrite IHM1 by auto.
          rewrite IHM2 by auto.
          rewrite set_filter_union.
          solve_set_union_inclusion. (* TODO: Make this opaque-ify anything that doesn't contain
                                           set_union *)

 (* Case TmProj *)
         simpl.
         apply IHM; auto.

 (* Case TmAbs *)
        simpl.
        rewrite IHM by auto.
        clear IHM.
        apply subst_freevars_binder; auto.

 (* Case TmApp *)
       simpl.
       rewrite IHM1 by auto.
       rewrite IHM2 by auto.
       setoid_rewrite set_filter_union.
       solve_set_union_inclusion.

 (* Case TmNull*)
      simpl.
      solve [auto with Listkit].

 (* Case TmSingle*)
     simpl.
     rewrite IHM.
     solve [auto with Listkit].

 (* Case TmUnion*)
    simpl.
    rewrite IHM1 by auto.
    rewrite IHM2 by auto.
    rewrite set_filter_union.
    solve_set_union_inclusion.

 (* Case TmBind *)
   simpl.
   rewrite IHM1 by auto.
   rewrite set_union_assoc.
   rewrite set_filter_union.

   rewrite <- set_union_assoc.
   remember (set_unions nat eq_nat_dec (map freevars env)).
   remember (set_filter nat (fun x : nat => outside_range q (length env + q) x)
            (freevars M1)).
   remember (set_filter nat (fun x : nat => outside_range q (length env + q) x)
              (set_map eq_nat_dec pred (freevars M2 % 0))).
   setoid_replace (s ∪ (l ∪ l0)) with ((s ∪ l) ∪ (s ∪ l0)) by (apply union_distrib).

   apply incl_sets_union; [| solve [auto with Listkit]].
   subst s l l0.

   rewrite IHM2.
   simpl.
   apply subst_freevars_binder.

 (* Case TmIf *)
  simpl.
  rewrite IHM1, IHM2, IHM3 by auto.
  rewrite set_filter_union.
  rewrite set_filter_union.
  solve_set_union_inclusion.

 (* Case TmTable *)
 simpl.
 solve [auto with Listkit].
Qed.

Lemma subst_unused_noop_binder:
 forall M : Term,
 (forall (env : list Term) (n : nat),
  all nat (fun x : nat => ~ in_env_domain n env x) (freevars M) ->
  subst_env n env M = M) ->
 forall (env : list Term) (n : nat),
 all nat (fun x : nat => ~ in_env_domain n env x)
  (set_map Nat.eq_dec Init.Nat.pred (freevars M % 0)) ->
 subst_env (S n) (map (shift 0 1) env) M = M.
Proof.
  intros M IHM env n H.
  rewrite IHM; [auto|].
  unfold all in *.
  intros.
  specialize (H (pred x)).
  unfold in_env_domain in *.
  destruct (eq_nat_dec x 0).
  { lia. }
  lapply H.
  { rewrite map_length.
    intros.
    lia. }
  apply set_map_intro.
  apply set_remove_intro.
  auto.
Qed.

Lemma subst_unused_noop:
  forall M env n,
    all nat (fun x => not (in_env_domain n env x)) (freevars M)
    -> subst_env n env M = M.
Proof.
 induction M; simpl; intros; try (
   try (rewrite all_union in H; destruct H);
   f_equal; auto
 ).
 (* Case TmVar *)
   assert (~in_env_domain n env x).
    unfold all in H.
    apply H.
    unfold set_In, In.
    auto.
   unfold in_env_domain in H0.
   break; auto.
   nth_error_dichotomize bounds is_error v v_def; finish.
 (* Case TmAbs *)
  apply subst_unused_noop_binder; auto.
 (* Case TmBind *)
 apply subst_unused_noop_binder; auto.

 (* Case TmIf *)
 apply all_union in H0; destruct H0.
 auto.
 apply all_union in H0; destruct H0.
 auto.
Qed.

Lemma subst_factor_binder:
  forall N m n env env',
  (forall (m n : nat) (env : set Term) (env' : list Term),
      all Term
        (fun z : Term =>
         all nat (fun x : nat => ~ in_env_domain m env' x) (freevars z)) env ->
      m + length env' <= n \/ n + length env <= m ->
      subst_env m (map (subst_env n env) env') (subst_env n env N) =
      subst_env n env (subst_env m env' N)) ->
  all Term
       (fun z : Term =>
        all nat (fun x : nat => ~ in_env_domain m env' x) (freevars z)) env ->
  m + length env' <= n \/ n + length env <= m ->
  subst_env (S m) (map (shift 0 1) (map (subst_env n env) env'))
    (subst_env (S n) (map (shift 0 1) env) N) =
  subst_env (S n) (map (shift 0 1) env)
    (subst_env (S m) (map (shift 0 1) env') N).
Proof.
 intros N m n env env' IHN H0 H1.
 replace (S m) with (m + 1) by lia.
 replace (S n) with (n + 1) by lia.
 rewrite map_map.
 rewrite map_ext with (g:=(fun x => subst_env (n + 1) (map (shift 0 1) env) (shift 0 1 x))).
  replace (map (fun x : Term => subst_env (n + 1) (map (shift 0 1) env) (shift 0 1 x)) env')
     with (map (subst_env (n + 1) (map (shift 0 1) env)) (map (shift 0 1) env')).
   apply IHN.

    (* Preservation of the free-variable relationship. *)
    unfold (*all_terms,*) all in H0 |- *.
    intros Z Z_source x x_free_in_Z.
    destruct (map_image _ _ (shift 0 1) Z env Z_source) as [X' [X_X'_eq X'_in_env]].
    pose (n0 := H0 X' X'_in_env (pred x)).
    subst Z.
    unfold in_env_domain in *.
    rewrite map_length.
    lapply n0.
     lia.
    apply freevars_shift in x_free_in_Z.
    apply set_map_image in x_free_in_Z.
    destruct x_free_in_Z as [x' [x'_def x'_in_X'_fvs]].
    subst x.
    replace (pred (shift_var 0 1 x')) with (x'); auto.
    unfold shift_var. break; lia.
   solve[map_lia].
  rewrite map_map; solve [trivial]...
 intro.
 rewrite shift_subst_commute_lo; [auto|].
 solve [lia]...
Qed.

Lemma subst_factor_var:
 forall x m n env env',
 (* If *)
 (* 1. All freevars of all items in env are not in the domain of env', *)
 all _ (fun z =>
            all _ (fun x => not (in_env_domain m env' x)) (freevars z)) env ->
 (* 2. and the domain (m,env') does not contain n, and (n,env) does not contain m,
    i.e. they are nonoverlapping: *)
 (m + length env' <= n \/ n + length env <= m) ->
 (* Then *)
 (* We can "commute" the two substitutions, with a modification to one: *)
   subst_env m (map (subst_env n env) env') (subst_env n env (TmVar x)) =
   subst_env n env (subst_env m env' (TmVar x)).
Proof.
  simpl.
  intros x m n env env' H0 H1.
(* Either we are in the range of [n x env] or we are in the range of
  [m x env'] or neither--since they don't overlap. *)
  set (P := m <= x < m + length env').
  set (Q := n <= x < n + length env).

  assert (H : not P /\ Q \/ P /\ not Q \/ not P /\ not Q).
  subst P Q.

  intuition.
    destruct (le_gt_dec x n);
      destruct (le_gt_dec x m);
      lia.
  destruct (le_gt_dec x n);
    destruct (le_gt_dec x m);
    lia.

  destruct H as [H | [H | H]].
  (* x is in the (n, env) range and not in (m, env') *)
  - destruct H; subst P Q.
    assert (H3: x - n < length env) by lia.
    destruct (nth_error_exists _ env (x - n) H3)
      as [v v_def].
    pose (v_fvs_notin_m_env' := nth_error_all _ _ _ _ _ v_def H0).
    clearbody v_fvs_notin_m_env'.

    assert (v_subst_env'_noop: forall f, subst_env m (map f env') v = v).
    { intro f.
      apply subst_unused_noop.
      rewrite in_env_domain_map.
      auto.
    }

    repeat magic.

  (* x is in the (m, env') range and not in (n, env) *)
  - destruct H; subst P Q.
    repeat magic.

  (* x is in the (m, env') range and not in (n, env) *)
  - destruct H; subst P Q.
    repeat magic.
Qed.

Lemma subst_factor :
  forall N m n env env',
    (* If *)
    (* 1. All freevars of all items in env are not in the domain of env', *)
    all _ (fun z =>
                all _ (fun x => not (in_env_domain m env' x)) (freevars z)) env ->
    (* 2. and the domain (m,env') does not contain n, and (n,env) does not contain m,
       i.e. they are nonoverlapping: *)
    (m + length env' <= n \/ n + length env <= m) ->
    (* Then *)
    (* We can "commute" the two substitutions, with a modification to one: *)
      subst_env m (map (subst_env n env) env') (subst_env n env N) =
      subst_env n env (subst_env m env' N).
(* TODO: reverse the orientation of that equation. *)
Proof.
 induction N; intros m n env env' H0 H1; simpl; try (solve[f_equal; auto using subst_factor_binder]).
 (* Case TmVar *)
 - apply subst_factor_var; auto.
 Qed.

(* Some notations might be nice, but I'm not sure I've got the right ones yet.

(*
Notation "N { M / x }" := (subst_env x (M :: nil) N) (at level 900). *)
Notation "{ x / env } N" := (subst_env x env N) (at level 100).
Notation "{ x :/ M } N" := (subst_env x (M :: nil) N) (at level 100).

Notation "^^ M" := (shift 0 1 M) (at level 98).
Notation ",, M" := (unshift 0 1 M) (at level 98).
*)

Lemma closing_subst_closes:
  forall vs ts m t,
    env_typing vs ts ->
    Typing ts m t ->
    Typing nil (subst_env 0 vs m) t.
Proof.
 intros.
 apply subst_env_preserves_typing with (env' := ts); simpl; auto.
Qed.

(*End Subst.*)


From iris.proofmode Require Import tactics monpred.
From iris.algebra Require Import frac.
From iris.base_logic Require Import base_logic.
From iris.base_logic.lib Require Import invariants cancelable_invariants na_invariants.

Section base_logic_tests.
  Context {M : ucmraT}.
  Implicit Types P Q R : uPred M.

  (* Test scopes for bupd *)
  Definition use_bupd_uPred (n : nat) : uPred M :=
    □ |==> ∃ m : nat , ⌜ n = 2 ⌝.
  Definition use_plainly_uPred (n : nat) : uPred M :=
    ■ |==> ∃ m : nat , ⌜ n = 2 ⌝.

  Lemma test_random_stuff (P1 P2 P3 : nat → uPred M) :
    ⊢ ∀ (x y : nat) a b,
      x ≡ y →
      □ (uPred_ownM (a ⋅ b) -∗
      (∃ y1 y2 c, P1 ((x + y1) + y2) ∧ True ∧ □ uPred_ownM c) -∗
      □ ▷ (∀ z, P2 z ∨ True → P2 z) -∗
      ▷ (∀ n m : nat, P1 n → □ ((True ∧ P2 n) → □ (⌜n = n⌝ ↔ P3 n))) -∗
      ▷ ⌜x = 0⌝ ∨ ∃ x z, ▷ P3 (x + z) ∗ uPred_ownM b ∗ uPred_ownM (core b)).
  Proof.
    iIntros (i [|j] a b ?) "!> [Ha Hb] H1 #H2 H3"; setoid_subst.
    { iLeft. by iNext. }
    iRight.
    iDestruct "H1" as (z1 z2 c) "(H1&_&#Hc)".
    iPoseProof "Hc" as "foo".
    iRevert (a b) "Ha Hb". iIntros (b a) "Hb {foo} Ha".
    iAssert (uPred_ownM (a ⋅ core a)) with "[Ha]" as "[Ha #Hac]".
    { by rewrite cmra_core_r. }
    iIntros "{$Hac $Ha}".
    iExists (S j + z1), z2.
    iNext.
    iApply ("H3" $! _ 0 with "[$]").
    - iSplit. done. iApply "H2". iLeft. iApply "H2". by iRight.
    - done.
  Qed.

  Lemma test_iFrame_pure (x y z : M) :
    ✓ x → ⌜y ≡ z⌝ -∗ (✓ x ∧ ✓ x ∧ y ≡ z : uPred M).
  Proof. iIntros (Hv) "Hxy". by iFrame (Hv) "Hxy". Qed.

  Lemma test_iAssert_modality P : (|==> False) -∗ |==> P.
  Proof. iIntros. iAssert False%I with "[> - //]" as %[]. Qed.

  Lemma test_iStartProof_1 P : P -∗ P.
  Proof. iStartProof. iStartProof. iIntros "$". Qed.
  Lemma test_iStartProof_2 P : P -∗ P.
  Proof. iStartProof (uPred _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_3 P : P -∗ P.
  Proof. iStartProof (uPredI _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_4 P : P -∗ P.
  Proof. iStartProof (uPredI _). iStartProof (uPred _). iIntros "$". Qed.
End base_logic_tests.

Section iris_tests.
  Context `{!invG Σ, !cinvG Σ, !na_invG Σ}.
  Implicit Types P Q R : iProp Σ.

  (* Test scopes for bupd and fupd *)
  Definition use_bupd_iProp (n : nat) : iProp Σ :=
    □ |==> ∃ m : nat , ⌜ n = 2 ⌝.
  Definition use_fupd_iProp (n : nat) : iProp Σ :=
    □ |={⊤}=> ∃ m : nat , ⌜ n = 2 ⌝.

  Lemma test_masks  N E P Q R :
    ↑N ⊆ E →
    (True -∗ P -∗ inv N Q -∗ True -∗ R) -∗ P -∗ ▷ Q ={E}=∗ R.
  Proof.
    iIntros (?) "H HP HQ".
    iApply ("H" with "[% //] [$] [> HQ] [> //]").
    by iApply inv_alloc.
  Qed.

  Lemma test_iInv_0 N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    iIntros "#H".
    iInv N as "#H2". Show.
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_0_with_close N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    iIntros "#H".
    iInv N as "#H2" "Hclose". Show.
    iMod ("Hclose" with "H2").
    iModIntro. by iNext.
  Qed.

  Lemma test_iInv_1 N E P:
    ↑N ⊆ E →
    inv N (<pers> P) ={E}=∗ ▷ P.
  Proof.
    iIntros (?) "#H".
    iInv N as "#H2".
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_2 γ p N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p ={⊤}=∗ cinv_own γ p ∗ ▷ P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)". Show.
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_2_with_close γ p N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p ={⊤}=∗ cinv_own γ p ∗ ▷ P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)" "Hclose". Show.
    iMod ("Hclose" with "HP").
    iModIntro. iFrame. by iNext.
  Qed.

  Lemma test_iInv_3 γ p1 p2 N P:
    cinv N γ (<pers> P) ∗ cinv_own γ p1 ∗ cinv_own γ p2
      ={⊤}=∗ cinv_own γ p1 ∗ cinv_own γ p2  ∗ ▷ P.
  Proof.
    iIntros "(#?&Hown1&Hown2)".
    iInv N with "[Hown2 //]" as "(#HP&Hown2)".
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_4 t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
         ⊢ |={⊤}=> na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)". Show.
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_4_with_close t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
         ⊢ |={⊤}=> na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)" "Hclose". Show.
    iMod ("Hclose" with "[HP Hown2]").
    { iFrame. done. }
    iModIntro. iFrame. by iNext.
  Qed.

  (* test named selection of which na_own to use *)
  Lemma test_iInv_5 t N E1 E2 P:
    ↑N ⊆ E2 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown2" as "(#HP&Hown2)".
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_6 t N E1 E2 P:
    ↑N ⊆ E1 →
    na_inv t N (<pers> P) ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test robustness in presence of other invariants *)
  Lemma test_iInv_7 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#?&#?&Hown1&Hown2)".
    iInv N3 with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* iInv should work even where we have "inv N P" in which P contains an evar *)
  Lemma test_iInv_8 N : ∃ P, inv N P ={⊤}=∗ P ≡ True ∧ inv N P.
  Proof.
    eexists. iIntros "#H".
    iInv N as "HP". iFrame "HP". auto.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_9 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_10 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 →
    inv N1 P ∗ na_inv t N3 (<pers> P) ∗ inv N2 P  ∗ na_own t E1 ∗ na_own t E2
      ={⊤}=∗ na_own t E1 ∗ na_own t E2  ∗ ▷ P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by ident name *)
  Lemma test_iInv_11 N P: inv N (<pers> P) ={⊤}=∗ ▷ P.
  Proof.
    let H := iFresh in
    (iIntros H; iInv H as "#H2"). auto.
  Qed.

  (* error messages *)
  Check "test_iInv_12".
  Lemma test_iInv_12 N P: inv N (<pers> P) ={⊤}=∗ True.
  Proof.
    iIntros "H".
    Fail iInv 34 as "#H2".
    Fail iInv nroot as "#H2".
    Fail iInv "H2" as "#H2".
    done.
  Qed.

  (* test destruction of existentials when opening an invariant *)
  Lemma test_iInv_13 N:
    inv N (∃ (v1 v2 v3 : nat), emp ∗ emp ∗ emp) ={⊤}=∗ ▷ emp.
  Proof.
    iIntros "H"; iInv "H" as (v1 v2 v3) "(?&?&_)".
    eauto.
  Qed.

  Theorem test_iApply_inG `{!inG Σ A} γ (x x' : A) :
    x' ≼ x →
    own γ x -∗ own γ x'.
  Proof. intros. by iApply own_mono. Qed.

  Check "test_frac_split_combine".
  Lemma test_frac_split_combine `{!inG Σ fracR} γ :
    own γ 1%Qp -∗ own γ 1%Qp.
  Proof.
    iIntros "[H1 H2]". Show.
    iCombine "H1 H2" as "H". Show.
    iExact "H".
  Qed.

End iris_tests.

Section monpred_tests.
  Context `{!invG Σ}.
  Context {I : biIndex}.
  Local Notation monPred := (monPred I (iPropI Σ)).
  Local Notation monPredI := (monPredI I (iPropI Σ)).
  Implicit Types P Q R : monPred.
  Implicit Types 𝓟 𝓠 𝓡 : iProp Σ.

  Check "test_iInv".
  Lemma test_iInv N E 𝓟 :
    ↑N ⊆ E →
    ⎡inv N 𝓟⎤ ⊢@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP". Show.
    iFrame "HP". auto.
  Qed.

  Check "test_iInv_with_close".
  Lemma test_iInv_with_close N E 𝓟 :
    ↑N ⊆ E →
    ⎡inv N 𝓟⎤ ⊢@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP" "Hclose". Show.
    iMod ("Hclose" with "HP"). auto.
  Qed.

End monpred_tests.


Require Import
  HoTT.Types.Universe
  HoTT.Types.Sigma
  HoTT.Types.Prod
  HoTT.Types.Arrow.
Require Export
  HoTT.Classes.interfaces.abstract_algebra.
Require Import HoTT.Classes.theory.rings.

Module SemiRings.

Class Operations
  := operations : sigT (fun T => Plus T * Mult T * Zero T * One T)%type.

Definition BuildOperations (T : Type) `{Plus T} `{Mult T} `{Zero T} `{One T}
  : Operations
  := existT _ T (plus,mult,zero,one).

Coercion SR_carrier (s : Operations) : Type := s.1.
Instance SR_plus (s : Operations) : Plus s := fst (fst (fst s.2)).
Instance SR_mult (s : Operations) : Mult s := snd (fst (fst s.2)).
Instance SR_zero (s : Operations) : Zero s := snd (fst s.2).
Instance SR_one (s : Operations) : One s := snd s.2.

Arguments SR_plus !_ / _ _.
Arguments SR_mult !_ / _ _.
Arguments SR_zero !_ /.
Arguments SR_one !_ /.

Section contents.
Universe U V.
Context `{Funext} `{Univalence}.
Context (A B : Operations@{U V}).

Context (f : A -> B) `{!IsEquiv f} `{!IsSemiRingPreserving f}.

Lemma iso_same_semirings : A = B.
Proof.
apply path_sigma_uncurried.
destruct A as [TA [[[plA mlA] zA] uA]], B as [TB [[[plB mlB] zB] uB]];simpl in *.
change plA with (@plus TA plA);change plB with (@plus TB plB);
change mlA with (@mult TA mlA);change mlB with (@mult TB mlB);
change zA with (@zero TA zA);change zB with (@zero TB zB);
change uA with (@one TA uA);change uB with (@one TB uB).
exists (path_universe f).
rewrite !transport_prod;simpl.
unfold Plus,Mult,Zero,One.
repeat apply path_prod;simpl;try
( apply path_forall;intros x;rewrite transport_arrow;
  apply path_forall;intros y;rewrite transport_arrow);
rewrite transport_path_universe, ?transport_path_universe_V.
- rewrite (preserves_plus (f:=f)).
  apply ap011;apply eisretr.
- rewrite (preserves_mult (f:=f)).
  apply ap011;apply eisretr.
- apply preserves_0.
- apply preserves_1.
Qed.

Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B.
Proof.
intros P;apply transport.
(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
first [exact iso_same_semirings|exact iso_same_semirings@{V V}].
Qed.

End contents.

End SemiRings.

Module Rings.

Class Operations
  := operations : sigT (fun T => Plus T * Mult T * Zero T * One T * Negate T)%type.

Definition BuildOperations (T : Type)
  `{Plus T} `{Mult T} `{Zero T} `{One T} `{Negate T}
  : Operations
  := existT _ T (plus,mult,zero,one,negate).

Coercion R_carrier (s : Operations) : Type := s.1.
Instance R_plus (s : Operations) : Plus s := fst (fst (fst (fst s.2))).
Instance R_mult (s : Operations) : Mult s := snd (fst (fst (fst s.2))).
Instance R_zero (s : Operations) : Zero s := snd (fst (fst s.2)).
Instance R_one (s : Operations) : One s := snd (fst s.2).
Instance R_negate (s : Operations) : Negate s := snd s.2.

Arguments R_plus !_ / _ _.
Arguments R_mult !_ / _ _.
Arguments R_zero !_ /.
Arguments R_one !_ /.
Arguments R_negate !_ / _.

Section contents.
Universe U V.
Context `{Funext} `{Univalence}.
Context (A B : Operations@{U V}).

(* NB: we need to know they're rings for preserves_negate *)
Context (f : A -> B) `{!IsEquiv f} `{!IsRing A} `{!IsRing B} `{!IsSemiRingPreserving f}.

Lemma iso_same_rings : A = B.
Proof.
apply path_sigma_uncurried.
destruct A as [TA [[[[plA mlA] zA] uA] nA]],
  B as [TB [[[[plB mlB] zB] uB] nB]];simpl in *.
change plA with (@plus TA plA);change plB with (@plus TB plB);
change mlA with (@mult TA mlA);change mlB with (@mult TB mlB);
change zA with (@zero TA zA);change zB with (@zero TB zB);
change uA with (@one TA uA);change uB with (@one TB uB);
change nA with (@negate TA nA);change nB with (@negate TB nB).
exists (path_universe f).
rewrite !transport_prod;simpl.
unfold Plus,Mult,Zero,One,Negate.
repeat apply path_prod;simpl;try
( apply path_forall;intros x;rewrite transport_arrow;
  try (apply path_forall;intros y;rewrite transport_arrow));
rewrite transport_path_universe, ?transport_path_universe_V.
- rewrite (preserves_plus (f:=f)).
  apply ap011;apply eisretr.
- rewrite (preserves_mult (f:=f)).
  apply ap011;apply eisretr.
- apply preserves_0.
- apply preserves_1.
- rewrite (preserves_negate (f:=f)).
  apply ap,eisretr.
Qed.

Lemma iso_leibnitz : forall P : Operations -> Type, P A -> P B.
Proof.
intros P;apply transport.
(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
first [exact iso_same_rings|exact iso_same_rings@{V V}].
Qed.

End contents.

End Rings.


(* *********************************************************************)
(*                                                                     *)
(*           Original GARUDA Example Policies and Extractions          *)
(*                                                                     *)
(* *********************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.

Require Import Arith ZArith.
Require Import Vector.
Require Import String.
Require Import JMeq.
Require Import List. Import ListNotations.

Require Import Integers.
Require Import lang.
Require Import extraction.
Require Import syntax.
Require Import combinators.

(* ************************)
(*  SecJmp Example Policy *)
(* ************************)
Section test_secjmp.
  Variables i o : id TVec64.
  (*High-order 10 bits of immediate address are zeroed. Because the effective
    address of the jump is calculated in MIPS as pc[0:3]++imm_addr[0:25]++[0;0],
    this enforces that all jumps are within a 2^16 offset of the higher-order 4
    bits of any instruction. Note that this policy doesn't deal with branches
    or indirect jumps. Note also that it's possible in principle to check
    statically that direct jumps are policy compliant.*)
  Definition sec_addr := BFieldRange ImmAddr (ofromz 10) (ofromz 0).
  Definition sec_jmp : pol TVec64 TVec64 :=
    `IF` jump `THEN` PTest sec_addr PId `ELSE` PId.
End test_secjmp.

(* *************************************)
(*  Secure Control Flow Example Policy *)
(* *************************************)
Section scf.
  (*A control-flow isolation policy. We assume that the effective address
    is pre-calculated in the top 32 bits of the input vector. *)
  Variables i o : id TVec64.
  Definition control_domain := ofromz 0.
  Definition sec_addr32 := BFieldRange EffAddr (ofromz 10) control_domain.
  Definition scf: pol TVec64 TVec64 :=
    `IF` ctrl `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
  (*We define a second version of this policy that applies just to indirect
    control flows (direct flows could be checked statically).*)
  Definition scf2: pol TVec64 TVec64 :=
    `IF` jump_indirect `THEN` PTest (BNeg sec_addr32) PId `ELSE` PId.
End scf.

(* ****************************************)
(*  Secure Failt Isolation Example Policy *)
(* ****************************************)
Section sfi.
  (*A write isolation policy, which we called SFI in the original paper. Note that
    SFI sometimes refers to a combination of write isolation and control-flow isolation
    (a point the paper clarifies). Below, the logical fault domain (lfd_mask)
    is the sub-address space beginning with higher-order bits 0^8.*)
  Variables ri ro : id TVec64.

  Definition lfd_start := ofromz 11673330234144325632. (*162<<56*)
  Definition lfd_mask := ofromz 72057594037927935. (*0^8 1^56*)

  Definition mask e := EBinop OAnd (EVal lfd_mask) e.
  Definition force_range e := EBinop OOr (EVal lfd_start) e.

  Definition sfi: pol TVec64 TVec64 :=
    `IF` store `THEN` PConcat (PUpd mask) (PUpd force_range) `ELSE` PId.
End sfi.

(* ******************************)
(*  Simple Taint Example Policy *)
(* ******************************)
Section taint.
  (*Taint tracking through ALU operations only (the monitors could be extended to
    support other taint propagation rules).*)
  Definition rs_taint := TaintBit (ofromz 63).
  Definition rt_taint := TaintBit (ofromz 62).
  Definition pc_taint := TaintBit (ofromz 61).
  Definition TAINTED := ofromz 1.
  Definition NOT_TAINTED := ofromz 0.
  Definition tainted_Itype: pred TVec64 :=
    BField pc_taint TAINTED `orpred` BField rs_taint TAINTED.
  Definition tainted_Rtype: pred TVec64 := BField rt_taint TAINTED.
  Definition taint64: pol TVec64 TVec64 :=
    `IF` tainted_Itype `orpred` (R_type `andpred` tainted_Rtype)
     `THEN` PUpd (fun _ => EVal TAINTED)
     `ELSE` PUpd (fun _ => EVal NOT_TAINTED).

  (*Here's an alternative implementation of taint64 that inputs just the required bits:
    in[0] = is_rtype, in[1] = rs_taint, in[2] = rt_taint, in[3] = pc_taint.*)
  Definition TaintTy := TArr 4 TBit.
  Lemma zlt4: 0 < 4. omega. Qed.
  Lemma olt4: 1 < 4. omega. Qed.
  Lemma tlt4: 2 < 4. omega. Qed.
  Lemma thlt4: 3 < 4. omega. Qed.
  Definition taint: pol TaintTy TBit :=
    let rtype_idx := @Fin.of_nat_lt 0 4 zlt4 in
    let rs_taint_idx := @Fin.of_nat_lt 1 4 olt4 in
    let rt_taint_idx := @Fin.of_nat_lt 2 4 tlt4 in
    let pc_taint_idx := @Fin.of_nat_lt 3 4 thlt4 in
    @PUpd TaintTy TBit _ _ (fun ax: exp TaintTy =>
            match ax with
            | EVar _ a =>
              let is_rtype := EDeref rtype_idx a in
              let rs_taint := EDeref rs_taint_idx a in
              let rt_taint := EDeref rt_taint_idx a in
              let pc_taint := EDeref pc_taint_idx a in
              EBinop OOr pc_taint (EBinop OOr rs_taint (EBinop OAnd is_rtype rt_taint))
            | _ => @EVal TBit _ false (*BOGUS: Can't occur by defn. of compile_pol.*)
            end).
End taint.

(* *********************)
(*  Print the Programs *)
(* *********************)
Require Import extraction.

(* ****************)
(*  Define Fields *)
(* ****************)
Definition i : id TVec64 := "i".
Definition o : id TVec64 := "o".
Definition ri : id TVec64 := "ri".
Definition ro : id TVec64 := "ro".
(* These don't really mean anything: *)
(*
Definition Es : id TVec64 := "Es".
Definition Eos : id TVec64 := "Eos".
Definition Mos : id TVec64 := "Mos".
Definition Ms : id TVec64 := "Ms".
*)

(* ***********************)
(*  Define Pols Compiled *)
(* ***********************)
Definition sec_jmp_compiled : prog := compile i o sec_jmp.
Definition SFI_compiled : prog := compile ri ro sfi.
Definition sec_jmp_sfi_compiled : prog := compile i o (PConcat sec_jmp sfi).
Opaque sec_jmp.
Opaque sfi.

Definition taint_i: id TaintTy := "ti".
Definition taint_o: id TBit := "to".
Definition taint_compiled : prog := compile taint_i taint_o taint.

Definition scf_compiled : prog := compile i o scf.

(* ****************************)
(*  Define HS Print Functions *)
(* ****************************)
Definition pretty_print_sec_jmp :=
  pretty_print_tb "secjmp" sec_jmp_compiled.
Definition pretty_print_SFI :=
  pretty_print_tb "SFI" SFI_compiled.
Definition pretty_print_taint :=
  pretty_print_tb "taint" taint_compiled.
Definition pretty_print_SCF :=
  pretty_print_tb "SCF" scf_compiled.
Definition pretty_print_SJSFI :=
  pretty_print_tb "SJSFI" sec_jmp_sfi_compiled.

(* ************************)
(*  Extraction to Haskell *)
(* ************************)
(* run the program 'secjmp.hs' and pipe to a file to get verilog       *)
(* Ignore warnings on opacity, see the end of the section on realizing *)
(* axioms for a proper explanation on why this is safe to do so:       *)
(* https://coq.inria.fr/refman/addendum/extraction.html?highlight=extraction%20warning#realizing-axioms *)
Extract Constant main => "Prelude.putStrLn pretty_print_sec_jmp".
Extraction "secjmp.hs" pretty_print_sec_jmp main.
Extract Constant main => "Prelude.putStrLn pretty_print_SFI".
Extraction "SFI.hs" pretty_print_SFI main.
Extract Constant main => "Prelude.putStrLn pretty_print_taint".
Extraction "taint.hs" pretty_print_taint main.
Extract Constant main => "Prelude.putStrLn pretty_print_SCF".
Extraction "SCF.hs" pretty_print_SCF main.
Extract Constant main => "Prelude.putStrLn pretty_print_SJSFI".
Extraction "SJSFI.hs" pretty_print_SJSFI main.


From stdpp Require Export list fin_maps.
From iris.program_logic Require Import hoare.
From iris.heap_lang Require Export lifting notation.
From iris_hashtable Require Import util.

Class Hashable Σ `{heapG Σ} (Key : Type) `{EqDecision Key} (Hash : Key -> nat) :=
  { equalf : val;
    hashf : val;
    as_key : val -> option Key;

    equal_spec (k1 k2: Key) (v1 v2: val) :
      as_key v1 = Some k1 ->
      as_key v2 = Some k2 ->
      WP equalf v1 v2 {{u, ⌜u = #(bool_decide (k1 = k2))⌝}}%I;

    hash_spec k v : as_key v = Some k -> WP hashf v {{u, ⌜u = #(Hash k)⌝}}%I }.

Section model.
  Context {Σ Key Hash map} `{FinMap Key map, heapG Σ, !Hashable Σ Key Hash}.

  Implicit Type m : map (list val).

  Definition insert_val m k x := (<[k := x :: from_option id [] (m !! k)]>m).

  Definition remove_val m k := match m !! k with
                               | Some (x :: y :: l) => <[k := y :: l]> m
                               | Some _ => delete k m
                               | None => m
                               end.

                                 (*(<[ k := tail (lookup_all M k)]>M).*)

  Definition all_elements m := map_fold (fun k l acc => ((fun v => (k, v)) <$> l) ++ acc) [] m.

  Definition table_wf m := map_Forall (fun _ l => exists x xs, l = x :: xs) m.

  Lemma table_wf_empty : table_wf ∅.
  Proof. apply map_Forall_empty. Qed.

  Lemma table_wf_insert_val m k x : table_wf m -> table_wf (insert_val m k x).
  Proof. apply map_Forall_insert_2. eauto. Qed.

  Lemma table_wf_remove_val m k : table_wf m -> table_wf (remove_val m k).
  Proof.
    unfold remove_val.
    case_eq (m !! k) ; last done.
    intros [|?[|]] Hlookup ; last (apply map_Forall_insert_2 ; eauto).
    all: rewrite -{1}(insert_id _ _ _ Hlookup) -insert_delete ;
      apply map_Forall_insert_12, lookup_delete.
  Qed.

  Definition lookup_insert_val_ne m k k' x :
    k ≠ k' -> (insert_val m k x) !! k' = m !! k'.
  Proof.
    intros Hne. rewrite /insert_val lookup_insert_ne //.
  Qed.

  Definition lookup_remove_val_ne m k k' :
    k ≠ k' -> (remove_val m k) !! k' = m !! k'.
  Proof.
    intros Hne. unfold remove_val.
    case_eq (m !! k) ; last done.
    intros [|?[|]] Hlookup ; [apply lookup_delete_ne ..| apply lookup_insert_ne] ; done.
  Qed.

  Inductive removal : map (list val) -> list (val * val) -> map (list val) -> Prop :=
  | RemovalNil {m} : removal m [] m
  | RemovalCons {k k' x xs l m m' } :
      as_key k = Some k' ->
      m !! k' = Some (x :: xs) ->
      removal (remove_val m k') l m' ->
      removal m ((k, x) :: l) m'.

  Lemma removal_app_1 m seq m' seq' m'':
    removal m seq m' ->
    removal m' seq' m'' ->
    removal m (seq ++ seq') m''.
  Proof.
    intro HRem. induction HRem as [|] ; [done | econstructor ; eauto].
  Qed.

  Lemma removal_app_2 m m' seq seq' :
    removal m (seq ++ seq') m' ->
    exists m'', removal m seq m'' /\ removal m'' seq' m'.
  Proof.
    revert m.
    induction seq as [|[k x] seq IH].
    - simpl. intros m ?. exists m. split. by constructor 1. assumption.
    - simpl. intros m Hrem. inversion Hrem as [| ? k' ??????? Hrem']. simplify_eq.
      specialize (IH (remove_val m k') Hrem'). destruct IH as [m'' [Hseq Hseq']].
      exists m''. split.
      by econstructor. assumption.
  Qed.

  Definition permitted m seq := exists m', removal m seq m'.
  Definition complete m seq := removal m seq ∅ .

  Lemma complete_all_elements m seq:
    complete m seq ->
    exists seq', Forall2 (fun '(k, x) '(k', x') => x = x' /\ as_key k' = Some k) seq' seq /\
                 seq' ≡ₚ all_elements m.
  Proof.
    assert (forall (k : Key) (l : list val),
               Proper (Permutation ==> Permutation) (fun acc => ((fun x => (k, x)) <$> l) ++ acc)).
    { solve_proper. }
    assert ( forall A (l1 l2 l3 : list A),
               l1 ++ l2 ++ l3 ≡ₚ l2 ++ l1 ++ l3).
    { intros. do 2 rewrite app_assoc. f_equiv. apply Permutation_app_comm. }
    revert m. induction seq as [|[k x] seq IH].
    - intros m HCom. exists [].
      split ; first done. inversion HCom.
       by rewrite  /all_elements map_fold_empty.
    - intros m HCom. inversion HCom as [| ??k'?????? Hlookup HRem].
      specialize (IH _ HRem). destruct IH as [seq' [Hforall HPerm]].
      exists ((k', x) :: seq'). split.
      + by apply Forall2_cons.
      + rewrite HPerm /all_elements /remove_val Hlookup. destruct xs.
        * rewrite -{2}(insert_id m k' [x]) // -insert_delete.
          rewrite (map_fold_insert Permutation) //. apply lookup_delete.
        * rewrite -insert_delete (map_fold_insert Permutation) // ; last apply lookup_delete.
          rewrite app_comm_cons  -fmap_cons.
          rewrite -{2}(insert_id m k' (x :: v :: xs)) // -insert_delete.
          rewrite (map_fold_insert Permutation) //. apply lookup_delete.
  Qed.

End model.

Structure table Σ key hash map `{FinMap key map, heapG Σ, !Hashable Σ key hash} : Type :=
  { table_create : val ;
    table_insert : val ;
    table_remove : val ;
    table_lookup : val ;
    table_fold : val ;
    table_cascade : val ;

    table_state : Type ;
    table_in_state : map (list val) -> table_state -> val -> iProp Σ ;
    is_cascade : map (list val) -> val -> list (val * val) -> table_state -> val -> iProp Σ ;

    table_in_state_wf m state t : (table_in_state m state t → ⌜table_wf m⌝)%I ;
    is_cascade_persistent m f seq state t : PersistentP (is_cascade m f seq state t) ;

    table_create_spec (n : nat) : (n > 0)%nat -> WP table_create #n {{t, ∃ state, table_in_state ∅ state t}}%I ;

    table_insert_spec (t k x : val) m state k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_insert t k x
        {{{state', RET #(); table_in_state (insert_val m k' x) state' t}}} ;

    table_remove_spec m state t k k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_remove t k
      {{{ state', RET match m !! k' with
                      | Some (v :: _) => SOMEV v
                      | _ => NONEV end ;
          table_in_state (remove_val m k') state' t }}} ;

    table_lookup_spec m state t k k' :
      as_key k = Some k' ->
      {{{table_in_state m state t}}}
        table_lookup t k
        {{{ RET match m !! k' with
                | Some (v :: _) => SOMEV v
                | _ => NONEV end ;
            table_in_state m state t }}} ;

    table_fold_spec m state I (f t a : val) :
      {{{(∀ k x seq (a' : val),
              {{⌜permitted m (seq ++ [(k,x)])⌝ ∗I seq a'}}
                f k x a'
              {{v, I (seq ++ [(k,x)]) v }}) ∗
         table_in_state m state t ∗ I [] a}}}
        table_fold f t a
      {{{v seq, RET v; ⌜complete m seq⌝ ∗ table_in_state m state t ∗ I seq v}}} ;

    is_cascade_spec m f seq state t:
      {{{ is_cascade m f seq state t ∗ table_in_state m state t }}}
        f #()
      {{{v k x f' , RET v; table_in_state m state t ∗
                           ((⌜v = NONEV⌝ ∗ ⌜complete m seq⌝) ∨
                            (⌜v = SOMEV ((k, x), f')⌝ ∗
                             ⌜permitted m (seq ++ [(k, x)])⌝ ∗
                             is_cascade m f' (seq ++ [(k, x)]) state t)) }}};

    table_cascade_spec m state t:
      {{{table_in_state m state t}}}
        table_cascade t
        {{{f, RET f; is_cascade m f [] state t ∗ table_in_state m state t }}}
  }.
Arguments table_create {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_insert {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_remove {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_lookup {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_fold {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_cascade {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_state {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _.
Arguments table_in_state {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _.
Arguments is_cascade {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _.
Arguments table_in_state_wf {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _.
Arguments is_cascade_persistent {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _.
Arguments table_create_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _.
Arguments table_insert_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _ _.
Arguments table_remove_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _.
Arguments table_lookup_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _ _.
Arguments table_fold_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _.
Arguments is_cascade_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _ _ _.
Arguments table_cascade_spec {_ _ _ _ _ _ _ _ _ _ _ _ _ _ _} _ _ _ _ _.

Existing Instance is_cascade_persistent.