(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * 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.
 *)

(** printing NRoot %\ensuremath{\sqrt[n]{\cdot}}% *)
(** printing sqrt %\ensuremath{\sqrt{\cdot}}% *)

Require Export CoRN.reals.OddPolyRootIR.
Import CRing_Homomorphisms.coercions.

(**
* Roots of Real Numbers *)

Section NRoot.
(**
** Existence of roots

%\begin{convention}% Let [n] be a natural number and [c] a nonnegative real.
[p] is the auxiliary polynomial [_X_[^]n[-] (_C_ c)].
%\end{convention}%
*)

Variable n : nat.
Hypothesis n_pos : 0 < n.
Variable c : IR.
Hypothesis c_nonneg : [0] [<=] c.

(* begin hide *)
Let p := _X_[^]n[-]_C_ c.
(* end hide *)

Lemma CnrootIR : {x : IR | [0] [<=] x | x[^]n [=] c}.
Proof.
 intros.
 cut (monic n p). intro.
  elim (Ccpoly_pos' _ p [0] n); auto.
  intro X. intros H0 H1.
  cut {x : IR | [0] [<=] x /\ x [<=] X /\ p ! x [=] [0]}. intro H2.
   elim H2. clear H2. intro. intro H2.
   elim H2. clear H2. intros H2 H3. elim H3. clear H3. intros.
   exists x. auto.
    apply cg_inv_unique_2.
   astepl (_X_ ! x[^]n[-] (_C_ c) ! x).
   astepl ((_X_[^]n) ! x[-] (_C_ c) ! x).
   Step_final (_X_[^]n[-]_C_ c) ! x.
  apply Civt_poly; auto.
   apply monic_apzero with n; auto.
  unfold p in |- *.
  astepl ((_X_[^]n) ! [0][-] (_C_ c) ! [0]).
  astepl (_X_ ! [0][^]n[-]c).
  astepl ([0][^]n[-]c).
  astepl ([0][-]c).
  astepl ( [--]c).
  astepr ( [--]ZeroR). apply inv_resp_leEq. auto.
  unfold p in |- *.
 apply monic_minus with 0.
   apply degree_le_c_.
  pattern n at 1 in |- *. replace n with (1 * n).
  apply monic_nexp.
   apply monic_x_.
  auto with arith.
 auto.
Qed.

End NRoot.

(** We define the root of order [n] for any nonnegative real number and
prove its main properties:
 - $\left(\sqrt[n]x\right)^n=x$#(sqrt(n) x)^n =x#;
 - $0\leq\sqrt[n]x$#0≤sqrt(n)x#;
 - if [[0] [<] x] then $0<\sqrt[n]x$#0<sqrt(n)x#;
 - $\sqrt[n]{x^n}=x$#sqrt(n) x^n =x#;
 - the nth root is monotonous;
 - in particular, if [x [<] [1]] then $\sqrt[n]x<1$#sqrt(n) x<1#.

[(nroot ??)] will be written as [NRoot].
*)

Section Nth_Root.

Lemma nroot : forall x k, [0] [<=] x -> 0 < k -> {y : IR | [0] [<=] y | y[^]k [=] x}.
Proof.
 intros.
 elim (CnrootIR k H0 x H). intro y. intros.
 exists y; auto.
Qed.

Definition NRoot x n Hx Hn : IR := proj1_sig2T _ _ _ (nroot x n Hx Hn).

Lemma NRoot_power : forall x k Hx Hk, NRoot x k Hx Hk[^]k [=] x.
Proof.
 intros.
 unfold NRoot in |- *.
 apply proj2b_sig2T.
Qed.

Hint Resolve NRoot_power: algebra.

Lemma NRoot_nonneg : forall x k Hx Hk, [0] [<=] NRoot x k Hx Hk.
Proof.
 intros.
 unfold NRoot in |- *.
 apply proj2a_sig2T.
Qed.

Lemma NRoot_pos : forall x Hx k Hk, [0] [<] x -> [0] [<] NRoot x k Hx Hk.
Proof.
 intros. rename X into H.
 cut ([0] [<=] NRoot x k Hx Hk); intros.
  cut (NRoot x k Hx Hk [<] [0] or [0] [<] NRoot x k Hx Hk). intros H1.
   elim H1; clear H1; intro H1.
    rewrite -> leEq_def in H0; elim (H0 H1).
   auto.
  apply ap_imp_less.
  apply un_op_strext_unfolded with (nexp_op (R:=IR) k).
  astepl x; astepr ZeroR.
  apply pos_ap_zero; auto.
 apply NRoot_nonneg.
Qed.

Lemma NRoot_power' : forall x k Hx' Hk, [0] [<=] x -> NRoot (x[^]k) k Hx' Hk [=] x.
Proof.
 intros.
 apply root_unique with k; auto.
  apply NRoot_nonneg.
 apply NRoot_power.
Qed.

Lemma NRoot_pres_less : forall x Hx y Hy k Hk, x [<] y -> NRoot x k Hx Hk [<] NRoot y k Hy Hk.
Proof.
 intros.
 apply power_cancel_less with k.
  apply NRoot_nonneg.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 eapply less_wdr.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 auto.
Qed.

Lemma NRoot_less_one : forall x Hx k Hk, x [<] [1] -> NRoot x k Hx Hk [<] [1].
Proof.
 intros.
 apply power_cancel_less with k.
  apply less_leEq; apply pos_one.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply NRoot_power.
 astepr OneR.
 assumption.
Qed.

Lemma NRoot_cancel : forall x Hx y Hy k Hk, NRoot x k Hx Hk [=] NRoot y k Hy Hk -> x [=] y.
Proof.
 intros.
 apply eq_transitive_unfolded with (NRoot x k Hx Hk[^]k).
  apply eq_symmetric_unfolded; apply NRoot_power.
 apply eq_transitive_unfolded with (NRoot y k Hy Hk[^]k).
  2: apply NRoot_power.
 apply nexp_wd; algebra.
Qed.

(** %\begin{convention}% Let [x,y] be nonnegative real numbers.
%\end{convention}% *)

Variables x y : IR.
Hypothesis Hx : [0] [<=] x.
Hypothesis Hy : [0] [<=] y.

Lemma NRoot_wd : forall k Hk Hk', x [=] y -> NRoot x k Hx Hk [=] NRoot y k Hy Hk'.
Proof.
 intros.
 apply root_unique with k; auto.
   apply NRoot_nonneg.
  apply NRoot_nonneg.
 eapply eq_transitive_unfolded.
  eapply eq_transitive_unfolded.
   2: apply H.
  apply NRoot_power.
 apply eq_symmetric_unfolded; apply NRoot_power.
Qed.

Lemma NRoot_unique : forall k Hk, [0] [<] x -> x[^]k [=] y -> x [=] NRoot y k Hy Hk.
Proof.
 intros. rename H into H0.
 apply root_unique with k; auto.
  apply NRoot_nonneg.
 eapply eq_transitive_unfolded.
  apply H0.
 apply eq_symmetric_unfolded; apply NRoot_power.
Qed.

End Nth_Root.

Arguments NRoot [x n].

#[global]
Hint Resolve NRoot_power NRoot_power': algebra.

Lemma NRoot_resp_leEq : forall x y xpos ypos k kpos,
 x [<=] y -> NRoot (x:=x) (n:=k) xpos kpos [<=] NRoot (x:=y) (n:=k) ypos kpos.
Proof.
 intros.
 rewrite -> leEq_def; intro H0.
 assert (NRoot ypos kpos[^]k [<=] NRoot xpos kpos[^]k).
  apply power_resp_leEq.
   apply NRoot_nonneg.
  apply less_leEq; auto.
 assert (x [=] y).
  apply leEq_imp_eq; auto.
  eapply leEq_wdl.
   eapply leEq_wdr.
    eexact H1.
   algebra.
  algebra.
 clear H H1.
 generalize (NRoot_wd _ _ xpos ypos k kpos kpos H2).
 intro.
 apply (less_irreflexive_unfolded _ (NRoot ypos kpos)).
 astepr (NRoot xpos kpos).
 auto.
Qed.

Lemma NRoot_cancel_less : forall x (Hx:[0][<=]x) y (Hy:[0][<=]y) k (Hk Hk':0<k), NRoot Hx Hk [<] NRoot Hy Hk' -> x [<] y.
Proof.
 intros x Hx y Hy k Hk Hk' H.
 astepl (NRoot Hx Hk[^]k).
 astepr (NRoot Hy Hk'[^]k).
 apply nexp_resp_less.
   auto with *.
  apply NRoot_nonneg.
 assumption.
Qed.

Lemma NRoot_str_ext : forall k (Hk Hk':0 < k) x y (Hx:[0][<=]x) (Hy:[0][<=]y), NRoot Hx Hk [#] NRoot Hy Hk' -> x[#]y.
Proof.
 intros k Hk Hk' x y Hx Hy H0.
 destruct (ap_imp_less _ _ _ H0) as [H1|H1].
  apply less_imp_ap.
  refine (NRoot_cancel_less _ _ _ _ _ _ _ H1).
 apply Greater_imp_ap.
 refine (NRoot_cancel_less _ _ _ _ _ _ _ H1).
Qed.

(*---------------------------------*)
Section Square_root.
(*---------------------------------*)

(**
** Square root *)

Definition sqrt x xpos : IR := NRoot (x:=x) (n:=2) xpos (lt_O_Sn 1).

Lemma sqrt_sqr : forall x xpos, sqrt x xpos[^]2 [=] x.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_power.
Qed.

Hint Resolve sqrt_sqr: algebra.

Lemma sqrt_nonneg : forall x xpos, [0] [<=] sqrt x xpos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_nonneg.
Qed.

Lemma sqrt_wd : forall x y xpos ypos, x [=] y -> sqrt x xpos [=] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_wd.
 auto.
Qed.

Hint Resolve sqrt_wd: algebra_c.

Lemma sqrt_to_nonneg : forall x, [0] [<=] x -> forall x2pos, sqrt (x[^]2) x2pos [=] x.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg. auto. auto.
   Step_final (x[^]2).
Qed.

Lemma sqrt_to_nonpos : forall x, x [<=] [0] -> forall x2pos, sqrt (x[^]2) x2pos [=] [--]x.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg.
   astepl ( [--]ZeroR). apply inv_resp_leEq. auto.
   auto.
 astepl (x[^]2). rational.
Qed.

Lemma sqrt_mult : forall x y xpos ypos xypos, sqrt (x[*]y) xypos [=] sqrt x xpos[*]sqrt y ypos.
Proof.
 intros.
 apply root_unique with 2.
    apply sqrt_nonneg.
   apply mult_resp_nonneg; apply sqrt_nonneg.
  auto.
 astepl (x[*]y).
 astepl (sqrt x xpos[^]2[*]sqrt y ypos[^]2).
 rational.
Qed.

Hint Resolve sqrt_mult: algebra.

Lemma sqrt_mult_wd : forall x y z xpos ypos zpos,
 z [=] x[*]y -> sqrt z zpos [=] sqrt x xpos[*]sqrt y ypos.
Proof.
 intros.
 cut ([0] [<=] x[*]y). intro.
  Step_final (sqrt (x[*]y) H0).
 apply mult_resp_nonneg; auto.
Qed.

Lemma sqrt_less : forall x y ypos, x[^]2 [<] y -> x [<] sqrt y ypos.
Proof.
 intros.
 apply power_cancel_less with 2.
  apply sqrt_nonneg.
 astepr y. auto.
Qed.

Lemma sqrt_less' : forall x y ypos, x[^]2 [<] y -> [--]x [<] sqrt y ypos.
Proof.
 intros.
 apply power_cancel_less with 2.
  apply sqrt_nonneg.
 rstepl (x[^]2). astepr y. auto.
Qed.

Lemma sqrt_resp_leEq : forall x y xpos ypos, x [<=] y -> sqrt x xpos [<=] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_resp_leEq.
 auto.
Qed.

Lemma sqrt_resp_less : forall x y xpos ypos, x [<] y -> sqrt x xpos [<] sqrt y ypos.
Proof.
 intros.
 unfold sqrt in |- *.
 apply NRoot_pres_less.
 auto.
Qed.

End Square_root.

#[global]
Hint Resolve sqrt_wd: algebra_c.
#[global]
Hint Resolve sqrt_sqr sqrt_mult: algebra.

Section Absolute_Props.

(**
** More on absolute value

With the help of square roots, we can prove some more properties of absolute
values in [IR].
*)

Lemma AbsIR_sqrt_sqr : forall x x2pos, AbsIR x [=] sqrt (x[^]2) x2pos.
Proof.
 intros x xxpos. unfold AbsIR in |- *. simpl in |- *. unfold ABSIR in |- *.
 apply equiv_imp_eq_max; intros.
   apply power_cancel_leEq with 2.
     auto.
    apply mult_cancel_leEq with (Two:IR). apply pos_two.
     rstepl (x[+][--]x).
    rstepr (y[+]y).
    apply plus_resp_leEq_both; auto.
   astepl ([1][*]x[*]x).
   rstepl (x[^]2[+][0]).
   apply shift_plus_leEq'.
   rstepr ((y[-]x) [*] (y[-][--]x)).
   apply mult_resp_nonneg.
    apply shift_zero_leEq_minus. auto.
    apply shift_zero_leEq_minus. auto.
   apply leEq_transitive with (sqrt (x[^]2) xxpos).
   apply power_cancel_leEq with 2. auto.
     apply sqrt_nonneg.
   astepr (x[^]2).
   apply leEq_reflexive.
  auto.
 apply leEq_transitive with (sqrt (x[^]2) xxpos).
  apply power_cancel_leEq with 2. auto.
    apply sqrt_nonneg.
  astepr (x[^]2).
  rstepl (x[^]2).
  apply leEq_reflexive.
 auto.
Qed.

Hint Resolve AbsIR_sqrt_sqr: algebra.

Lemma AbsIR_resp_mult : forall x y, AbsIR (x[*]y) [=] AbsIR x[*]AbsIR y.
Proof.
 intros.
 astepl (sqrt ((x[*]y) [^]2) (sqr_nonneg _ (x[*]y))).
 cut ([0] [<=] x[^]2[*]y[^]2). intro.
  astepl (sqrt (x[^]2[*]y[^]2) H).
  Step_final (sqrt (x[^]2) (sqr_nonneg _ x) [*]sqrt (y[^]2) (sqr_nonneg _ y)).
 apply mult_resp_nonneg; apply sqr_nonneg.
Qed.

Lemma AbsIR_mult_pos : forall x y, [0] [<=] y -> AbsIR (x[*]y) [=] AbsIR x[*]y.
Proof.
 intros.
 apply eq_transitive_unfolded with (AbsIR x[*]AbsIR y).
  apply AbsIR_resp_mult.
 apply bin_op_wd_unfolded.
  algebra.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--]y y).
  apply Max_comm.
 apply leEq_imp_Max_is_rht.
 apply leEq_transitive with ZeroR.
  astepr ( [--]ZeroR).
  apply inv_resp_leEq; assumption.
 assumption.
Qed.

Lemma AbsIR_mult_pos' : forall x y, [0] [<=] x -> AbsIR (x[*]y) [=] x[*]AbsIR y.
Proof.
 intros.
 astepl (AbsIR (y[*]x)).
 eapply eq_transitive_unfolded.
  apply AbsIR_mult_pos; auto.
 algebra.
Qed.

Lemma AbsIR_nexp : forall x n, AbsIR (nexp _ n x) [=] nexp _ n (AbsIR x).
Proof.
 intros.
 induction  n as [| n Hrecn].
  simpl in |- *; apply AbsIR_eq_x; apply less_leEq; apply pos_one.
 simpl in |- *.
 eapply eq_transitive_unfolded.
  apply AbsIR_resp_mult.
 algebra.
Qed.

Lemma AbsIR_nexp_op : forall n x, AbsIR (x[^]n) [=] AbsIR x[^]n.
Proof.
 intros; simpl in |- *; apply AbsIR_nexp.
Qed.

Lemma AbsIR_less_square : forall x y, AbsIR x [<] y -> x[^]2 [<] y[^]2.
Proof.
 intros.
 eapply less_wdl.
  2: apply AbsIR_eq_x; apply sqr_nonneg.
 eapply less_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op.
 apply nexp_resp_less; auto.
 apply AbsIR_nonneg.
Qed.

Lemma AbsIR_leEq_square : forall x y, AbsIR x [<=] y -> x[^]2 [<=] y[^]2.
Proof.
 intros.
 eapply leEq_wdl.
  2: apply AbsIR_eq_x; apply sqr_nonneg.
 eapply leEq_wdl.
  2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op.
 apply nexp_resp_leEq; auto.
 apply AbsIR_nonneg.
Qed.

Lemma AbsIR_division : forall x y y_ y__, AbsIR (x[/] y[//]y_) [=] (AbsIR x[/] AbsIR y[//]y__).
Proof.
 intros x y H Hy.
 rstepr (AbsIR x[*] ([1][/] AbsIR y[//]Hy)).
 apply eq_transitive_unfolded with (AbsIR (x[*] ([1][/] y[//]H))).
  apply un_op_wd_unfolded; rational.
 apply eq_transitive_unfolded with (AbsIR x[*]AbsIR ([1][/] y[//]H)).
  apply AbsIR_resp_mult.
 apply mult_wdr.
 cut (y [<] [0] or [0] [<] y).
  intros H0.
  elim H0.
   intros.
   apply eq_transitive_unfolded with ( [--] ([1][/] y[//]H)).
    apply AbsIR_eq_inv_x.
    rstepr ([0][/] [--]y[//]inv_resp_ap_zero _ _ H).
    apply shift_leEq_div.
     astepl ( [--]ZeroR).
     apply inv_resp_less; assumption.
    rstepl ( [--]OneR).
    astepr ( [--]ZeroR); apply inv_resp_leEq; apply less_leEq; apply pos_one.
   rstepl ([1][/] [--]y[//]inv_resp_ap_zero _ _ H).
   apply div_wd.
    algebra.
   apply eq_symmetric_unfolded; apply AbsIR_eq_inv_x.
   apply less_leEq; assumption.
  intros.
  apply eq_transitive_unfolded with ([1][/] y[//]H).
   apply AbsIR_eq_x.
   apply less_leEq; apply recip_resp_pos; assumption.
  apply div_wd; [ algebra
    | apply eq_symmetric_unfolded; apply AbsIR_eq_x; apply less_leEq; assumption ].
 apply ap_imp_less.
 assumption.
Qed.

(** Some special cases. *)

Lemma AbsIR_recip : forall x x_ x__, AbsIR ([1][/] x[//]x_) [=] ([1][/] AbsIR x[//]x__).
Proof.
 intros x H Ha.
 apply eq_transitive_unfolded with (AbsIR [1][/] AbsIR x[//]Ha).
  apply AbsIR_division.
 apply div_wd.
  2: algebra.
 apply AbsIR_eq_x; apply less_leEq; apply pos_one.
Qed.

Lemma AbsIR_div_two : forall x, AbsIR (x [/]TwoNZ) [=] AbsIR x [/]TwoNZ.
Proof.
 intros.
 apply eq_transitive_unfolded with (AbsIR x[/] AbsIR Two[//] AbsIR_resp_ap_zero _
   (ap_symmetric_unfolded _ _ _ (less_imp_ap _ _ _ (pos_two _)))).
  apply AbsIR_division.
 apply div_wd.
  algebra.
 apply AbsIR_eq_x; apply less_leEq; apply pos_two.
Qed.

(** Cauchy-Schwartz for IR and variants on that subject. *)

Lemma triangle_IR : forall x y, AbsIR (x[+]y) [<=] AbsIR x[+]AbsIR y.
Proof.
 intros.
 astepl (sqrt ((x[+]y) [^]2) (sqr_nonneg _ (x[+]y))).
 astepr (sqrt (x[^]2) (sqr_nonneg _ x) [+]sqrt (y[^]2) (sqr_nonneg _ y)).
 apply power_cancel_leEq with 2. auto.
   astepl ([0][+]ZeroR). apply plus_resp_leEq_both; apply sqrt_nonneg.
  astepl ((x[+]y) [^]2).
 rstepl (x[^]2[+]y[^]2[+]Two[*] (x[*]y)).
 rstepr (sqrt (x[^]2) (sqr_nonneg IR x) [^]2[+]sqrt (y[^]2) (sqr_nonneg IR y) [^]2[+]
   Two[*] (sqrt (x[^]2) (sqr_nonneg IR x) [*]sqrt (y[^]2) (sqr_nonneg IR y))).
 apply plus_resp_leEq_both.
  astepr (x[^]2[+]y[^]2). apply leEq_reflexive.
  apply mult_resp_leEq_lft.
  apply power_cancel_leEq with 2. auto.
    apply mult_resp_nonneg; apply sqrt_nonneg.
  rstepr (sqrt (x[^]2) (sqr_nonneg _ x) [^]2[*]sqrt (y[^]2) (sqr_nonneg _ y) [^]2).
  astepr (x[^]2[*]y[^]2).
  astepl (x[^]2[*]y[^]2).
  apply leEq_reflexive.
 apply less_leEq. apply pos_two.
Qed.

Lemma triangle_SumIR : forall k l s,
 k <= S l -> AbsIR (Sum k l s) [<=] Sum k l (fun i => AbsIR (s i)).
Proof.
 intros. induction  l as [| l Hrecl].
 generalize (toCle _ _ H); clear H; intro H.
  inversion H as [|m H0 H1].
   unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
   rstepr ZeroR.
   astepr (AbsIR [0]).
   apply eq_imp_leEq. apply AbsIR_wd. rational.
   inversion H0.
  unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
  rstepr (ABSIR (s 0)).
  apply eq_imp_leEq. apply AbsIR_wd. rational.
  elim (le_lt_eq_dec k (S (S l))); try intro y.
   apply leEq_wdl with (AbsIR (Sum k l s[+]s (S l))).
    apply leEq_wdr with (Sum k l (fun i : nat => AbsIR (s i)) [+]AbsIR (s (S l))).
     apply leEq_transitive with (AbsIR (Sum k l s) [+]AbsIR (s (S l))).
      apply triangle_IR.
     apply plus_resp_leEq. apply Hrecl. auto with arith.
     apply eq_symmetric_unfolded.
    apply Sum_last with (f := fun i : nat => AbsIR (s i)).
   apply AbsIR_wd.
   apply eq_symmetric_unfolded. apply Sum_last.
   rewrite y.
  unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *.
  rstepr ZeroR.
  astepr (AbsIR [0]).
  apply eq_imp_leEq. apply AbsIR_wd. rational.
  auto.
Qed.

Lemma triangle_IR_minus : forall x y, AbsIR (x[-]y) [<=] AbsIR x[+]AbsIR y.
Proof.
 intros.
 unfold cg_minus in |- *.
 apply leEq_wdr with (AbsIR x[+]AbsIR [--]y).
  apply triangle_IR.
 apply bin_op_wd_unfolded.
  algebra.
 unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *.
 apply eq_transitive_unfolded with (Max [--]y y).
  apply bin_op_wd_unfolded; algebra.
 apply Max_comm.
Qed.

Lemma weird_triangleIR : forall x y, AbsIR x[-]AbsIR (y[-]x) [<=] AbsIR y.
Proof.
 intros.
 apply shift_minus_leEq.
 simpl in |- *; unfold ABSIR in |- *; apply Max_leEq.
  rstepl (y[+][--] (y[-]x)).
  apply plus_resp_leEq_both; [ apply lft_leEq_Max | apply rht_leEq_Max ].
 rstepl ( [--]y[+] (y[-]x)).
 apply plus_resp_leEq_both; [ apply rht_leEq_Max | apply lft_leEq_Max ].
Qed.

Lemma triangle_IR_minus' : forall x y, AbsIR x[-]AbsIR y [<=] AbsIR (x[-]y).
Proof.
 intros.
 eapply leEq_wdr.
  2: apply AbsIR_minus.
 apply shift_minus_leEq; apply shift_leEq_plus'.
 apply weird_triangleIR.
Qed.

Lemma triangle_SumxIR : forall n (f : forall i, i < n -> IR),
 AbsIR (Sumx f) [<=] Sumx (fun i H => AbsIR (f i H)).
Proof.
 simple induction n.
  intros; simpl in |- *.
  apply eq_imp_leEq; apply AbsIRz_isz.
 clear n; intros.
 simpl in |- *; eapply leEq_transitive.
  apply triangle_IR.
 apply plus_resp_leEq.
 eapply leEq_wdr.
  apply H.
 apply Sumx_wd.
 intros; algebra.
Qed.

Lemma triangle_Sum2IR : forall m n (f : forall i, m <= i -> i <= n -> IR),
 m <= S n -> AbsIR (Sum2 f) [<=] Sum2 (fun i Hm Hn => AbsIR (f i Hm Hn)).
Proof.
 intros.
 unfold Sum2 in |- *.
 eapply leEq_wdr.
  apply triangle_SumIR.
  assumption.
 apply Sum_wd'.
  assumption.
 intros.
 elim (le_lt_dec m i); intro;
   [ simpl in |- * | exfalso; apply (le_not_lt m i); auto with arith ].
 elim (le_lt_dec i n); intro;
   [ simpl in |- * | exfalso; apply (le_not_lt i n); auto with arith ].
 algebra.
Qed.

Lemma AbsIR_str_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<] e -> AbsIR b [<] AbsIR a[+]e.
Proof.
 do 3 intro. intro H.
 apply shift_less_plus'.
 eapply leEq_less_trans.
  apply triangle_IR_minus'.
 eapply less_wdl; [ apply H | apply AbsIR_minus ].
Qed.

Lemma AbsIR_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<=] e -> AbsIR b [<=] AbsIR a[+]e.
Proof.
 intros.
 apply shift_leEq_plus'.
 eapply leEq_transitive.
  apply triangle_IR_minus'.
 eapply leEq_wdl; [ apply H | apply AbsIR_minus ].
Qed.

End Absolute_Props.

Section Consequences.

(**
** Cauchy sequences

With these results, we can also prove that the sequence of reciprocals of a
Cauchy sequence that is never zero and whose Limit is not zero is also a
Cauchy sequence.
*)

Lemma Cauchy_Lim_recip : forall seq y, Cauchy_Lim_prop2 seq y ->
 forall seq_ y_, Cauchy_Lim_prop2 (fun n : nat => [1][/] seq n[//]seq_ n) ([1][/] y[//]y_).
Proof.
 intros seq y H Hn Hy.
 red in |- *; red in H.
 intros eps He.
 cut {n0 : nat | forall n : nat, n0 <= n -> AbsIR y [/]TwoNZ [<=] AbsIR (seq n)}.
  intro H0.
  elim H0; clear H0; intros n0 Hn0.
  cut ([0] [<] eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y)).
   intro H0.
   elim (H _ H0); clear H.
   intros N HN.
   exists (max N n0).
   intros.
   apply AbsIR_imp_AbsSmall.
   apply leEq_wdl with (([1][/] _[//]AbsIR_resp_ap_zero _ (Hn m)) [*]
     ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*]AbsIR (seq m[-]y)).
    rstepr ((Two[/] _[//]AbsIR_resp_ap_zero _ Hy) [*] ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*]
      (eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y))).
    apply mult_resp_leEq_both.
       astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive.
        apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hn.
       apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy.
      apply AbsIR_nonneg.
     apply mult_resp_leEq_rht.
      rstepr ([1][/] _[//] div_resp_ap_zero_rev _ _ _ (two_ap_zero _) (AbsIR_resp_ap_zero _ Hy)).
      apply recip_resp_leEq.
       apply pos_div_two; apply AbsIR_pos; apply Hy.
      apply Hn0.
      apply le_trans with (max N n0); auto with arith.
     apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy.
    apply AbsSmall_imp_AbsIR.
    apply HN.
    apply le_trans with (max N n0); auto with arith.
   apply eq_transitive_unfolded with
     (AbsIR ([1][/] _[//]Hn m) [*]AbsIR ([1][/] _[//]Hy) [*]AbsIR (y[-]seq m)).
    repeat apply mult_wd; apply eq_symmetric_unfolded.
      apply AbsIR_recip.
     apply AbsIR_recip.
    apply AbsIR_minus.
   apply eq_transitive_unfolded with (AbsIR (([1][/] _[//]Hn m) [*] ([1][/] _[//]Hy) [*] (y[-]seq m))).
    eapply eq_transitive_unfolded.
     2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
    apply mult_wdl.
    apply eq_symmetric_unfolded; apply AbsIR_resp_mult.
   apply AbsIR_wd.
   rational.
  astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive.
   apply pos_div_two; assumption.
  astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive;
    apply AbsIR_pos; apply Hy.
 cut {n0 : nat | forall n : nat, n0 <= n -> AbsSmall (AbsIR y [/]TwoNZ) (seq n[-]y)}.
  2: apply H.
  2: eapply less_wdr.
   3: apply AbsIR_div_two.
  2: apply AbsIR_pos.
  2: apply div_resp_ap_zero_rev; apply Hy.
 intro H0.
 elim H0; intros n0 Hn0; clear H0; exists n0; intros.
 apply leEq_transitive with (AbsIR y[-]AbsIR (seq n[-]y)).
  apply shift_leEq_minus; apply shift_plus_leEq'.
  rstepr (AbsIR y [/]TwoNZ).
  apply AbsSmall_imp_AbsIR.
  apply Hn0; assumption.
 apply weird_triangleIR.
Qed.

Lemma Cauchy_recip : forall seq seq_, Lim seq [#] ([0]:IR) ->
 Cauchy_prop (fun n => [1][/] seq n[//]seq_ n).
Proof.
 intros seq Hn Hy.
 apply Cauchy_prop2_prop.
 exists ([1][/] _[//]Hy).
 apply Cauchy_Lim_recip.
 apply Cauchy_complete.
Qed.

Lemma Lim_recip : forall seq seq_ seq__,
 Lim (Build_CauchySeq _ _ (Cauchy_recip seq seq_ seq__)) [=] ([1][/] _[//]seq__).
Proof.
 intros.
 apply eq_symmetric_unfolded; apply Limits_unique.
 simpl in |- *; apply Cauchy_Lim_recip.
 apply Cauchy_complete.
Qed.

End Consequences.

Section Part_Function_NRoot.

(** *** Functional Operators

%\begin{convention}%
Let [F:PartIR] and denote by [P] its domain, which must be entirely nonnegative.
%\end{convention}%
*)

Variables F : PartIR.

Let P := Dom F.

Let R := extend P (fun x Hx => [0][<=]F x Hx).

Let Ext2R := ext2 (P:=P) (R:=fun x Hx => [0][<=]F x Hx).

Variable n : nat.

Hypothesis Hn : 0 < n.

Lemma part_function_NRoot_strext : forall x y Hx Hy,
 NRoot (Ext2R x Hx) Hn [#] NRoot (Ext2R y Hy) Hn -> x [#] y.
Proof.
 intros x y Hx Hy H.
 refine (pfstrx _ _ _ _ _ _ (NRoot_str_ext _ _ _ _ _ _ _ H)).
Qed.

Lemma part_function_NRoot_pred_wd : pred_wd _ R.
Proof.
 intros x y H H0.
 elim H.
 intros H1 H2.
 split.
  apply (dom_wd _ F x y H1 H0).
 intros H3.
 astepr (F x H1).
 auto.
Qed.

Definition FNRoot := Build_PartFunct IR _ part_function_NRoot_pred_wd
 (fun x Hx => NRoot (Ext2R x Hx) Hn) part_function_NRoot_strext.

Section Included.

Variable S:IR -> CProp.

Lemma included_FNRoot : included S P ->
 (forall x, S x -> forall Hx, [0][<=]F x Hx) -> included S (Dom FNRoot).
Proof.
 intros H H0.
 simpl in |- *.
 unfold extend in |- *.
 split.
  apply H; assumption.
 intros; apply H0; assumption.
Qed.

Lemma included_FNRoot' : included S (Dom FNRoot) -> included S P.
Proof.
 intro H; simpl in H; eapply included_extend; unfold R in *; apply H.
Qed.

End Included.

End Part_Function_NRoot.

#[global]
Hint Resolve included_FNRoot included_FNRoot' : included.


Require Import LogRelIE.InstPTy.
Require Import LogRelIE.PseudoType.

Require Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.

Module B := Coq.Init.Datatypes.

Require Import RecTypes.Contraction.

Require Import InstPTy.

Require Import Coq.micromega.Lia.

Inductive SimplePContr : PTy → Prop :=
  | SimpContrPUnit : SimplePContr ptunit
  | SimpContrPBool : SimplePContr ptbool
  | SimpContrPArrow {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptarr τ τ')
  | SimpContrPSum {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptsum τ τ')
  | SimpContrPProd {τ τ'} : SimplePRec τ → SimplePRec τ' → SimplePContr (ptprod τ τ')
  | SimpContrPRec {τ} : SimplePContr τ → SimplePContr (ptrec τ)
  | SimpContrPEmulDV {n p τ} : SimpleContr τ → SimplePContr (pEmulDV n p τ)
  with SimplePRec : PTy → Prop :=
  | SimplePAlpha {i} : SimplePRec (ptvar i)
  | SimplePRecContr {τ} : SimplePContr τ → SimplePRec τ.

Scheme simp_p_contr_mut_ind := Induction for SimplePContr Sort Prop
  with simp_p_rec_mut_ind := Induction for SimplePRec Sort Prop.

Combined Scheme simp_p_contr_comb_ind from simp_p_contr_mut_ind, simp_p_rec_mut_ind.

#[export]
Hint Constructors SimplePContr : simple_p_contr_rec.
#[export]
Hint Constructors SimplePRec : simple_p_contr_rec.

Definition pUnfoldOnce (τ : PTy) : PTy :=
  match τ with
    | ptrec τ => τ [(beta1 (ptrec τ))]
    | _ => τ
  end.

Fixpoint pUnfoldn (n : nat) (τ : PTy) :=
  match n with
    | 0 => τ
    | S n => pUnfoldn n (pUnfoldOnce τ)
  end.

Inductive ContrPEnv : PEnv → Prop :=
| ContrPEnvEmpty : ContrPEnv pempty
| ContrPEnvEvar {Γ τ} :
  ContrPEnv Γ →
  SimplePContr τ →
  ContrPEnv (Γ p▻ τ).

Definition SimplePContrSub ( ξ : Sub PTy) : Prop := forall i : Ix, SimplePContr (ξ i).
Definition SimplePRecSub ( ξ : Sub PTy) : Prop := forall i : Ix, SimplePRec (ξ i).

Lemma SimplePContrRec_ren :
  (forall τ (sτ : SimplePContr τ) (ξ : Sub Ix), SimplePContr τ[ξ]) /\
  (forall τ (sτ : SimplePRec τ) (ξ : Sub Ix), SimplePRec τ[ξ]).
Proof.
  apply simp_p_contr_comb_ind; cbn; intros;
    repeat change (apPTy ?ξ ?τ) with τ[ξ];
    constructor; auto.
Qed.

Corollary SimplePRec_wk {τ} : SimplePRec τ → SimplePRec τ[wk].
Proof. intros s. now apply SimplePContrRec_ren. Qed.

Lemma SimplePContrSub_implies_SimplePRecSub {ξ} : SimplePContrSub ξ → SimplePRecSub ξ.
Proof.
  unfold SimplePContrSub, SimplePRecSub.
  intros.
  specialize (H i).
  exact (SimplePRecContr H).
Qed.

Lemma SimplePRecSub_implies_SimplePRecSubUp {ξ} : SimplePRecSub ξ → SimplePRecSub (up ξ).
Proof.
  unfold SimplePRecSub.
  intros.

  destruct i; cbn.
  constructor.

  apply SimplePRec_wk.
  exact (H i).
Qed.

Lemma SimplePRecSub_implies_SimplePRec {τ ξ} : SimplePRec τ → SimplePRecSub ξ → SimplePRec τ[ξ].
Proof.
  intro H.
  apply (simp_p_rec_mut_ind
           (fun τ (_ : SimplePContr τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePContr τ[ξ]))
           (fun τ (_ : SimplePRec τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePRec τ[ξ]))); cbn; eauto with simple_p_contr_rec.

  intros.
  constructor.
  eauto using H0, SimplePRecSub_implies_SimplePRecSubUp.
Qed.

Lemma SimplePContrSub_implies_SimplePContr {τ ξ} : SimplePContr τ → SimplePRecSub ξ → SimplePContr τ[ξ].
  intro H.
  apply (simp_p_contr_mut_ind
           (fun τ (_ : SimplePContr τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePContr τ[ξ]))
           (fun τ (_ : SimplePRec τ) => (forall ξ : Sub PTy, SimplePRecSub ξ → SimplePRec τ[ξ]))).
  cbn.
  constructor.

  intros.
  cbn.
  constructor.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply H1.
  assumption.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply H1.
  assumption.

  intros.
  cbn.
  constructor.
  apply H0.
  assumption.
  apply (H1 ξ0 H2).

  intros.
  cbn.
  constructor.
  apply (H0 ξ0↑).
  apply SimplePRecSub_implies_SimplePRecSubUp.
  assumption.

  intros.
  cbn.
  constructor.
  assumption.

  intros.
  cbn.
  exact (H0 i).

  intros.
  specialize (H0 ξ0).
  apply SimplePRecSub_implies_SimplePRec.
  apply SimplePRecContr.
  assumption.
  assumption.
  assumption.
Qed.

Lemma SimplePRecSub_beta {τ} : SimplePContr τ -> SimplePRecSub (beta1 τ).
Proof.
  intros srec i; cbn.
  destruct i; cbn; constructor; auto.
Qed.

Lemma punfold_preserves_contr {τ} : SimplePContr τ -> SimplePContr (τ [beta1 (ptrec τ)]).
Proof.
  eauto using SimplePContrSub_implies_SimplePContr, SimplePRecSub_beta, SimpContrPRec.
Qed.

Lemma SimplePContr_pUnfoldOnce (τ : PTy) : SimplePContr τ -> SimplePContr (pUnfoldOnce τ).
Proof.
  destruct τ; cbn; eauto with simple_p_contr_rec.
  intros contr.
  dependent destruction contr.
  eauto using punfold_preserves_contr.
Qed.

#[export]
Hint Resolve SimplePContr_pUnfoldOnce : simple_p_contr_rec.

Lemma SimplePRec_pUnfoldOnce (τ : PTy) : SimplePRec τ -> SimplePRec (pUnfoldOnce τ).
Proof.
  destruct 1;
  eauto using SimplePRec, SimplePContr_pUnfoldOnce.
Qed.

#[export]
Hint Resolve SimplePRec_pUnfoldOnce : simple_contr_rec.

Lemma SimplePRec_invert_arrow {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec τ ∧ SimplePRec σ.
Proof.
  intros carr.
  remember (τ p⇒ σ) as τ'.
  destruct carr; [inversion Heqτ'|].
  destruct H; inversion Heqτ'.
  now subst.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow : simple_contr_p_rec.

Lemma SimplePRec_invert_arrow_argty {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec τ.
Proof.
  eapply SimplePRec_invert_arrow.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow_argty : simple_contr_p_rec.

Lemma SimplePRec_invert_arrow_retty {τ σ} :
  SimplePRec (τ p⇒ σ) → SimplePRec σ.
Proof.
  eapply SimplePRec_invert_arrow.
Qed.

#[export]
Hint Resolve SimplePRec_invert_arrow_retty : simple_contr_p_rec.

Fixpoint LMC_pty (τ : PTy) {struct τ} : nat :=
  match τ with
  | ptrec τ => S (LMC_pty τ)
  | _ => 0
  end.

Lemma LMC_ind_pty : forall (P : PTy -> Type),
    (forall τ, SimplePContr τ -> LMC_pty τ = 0 -> P τ) ->
    (forall n, (forall τ, SimplePContr τ -> LMC_pty τ = n -> P τ) -> (forall τ, SimplePContr τ -> LMC_pty τ = S n -> P τ)) ->
    forall τ, SimplePContr τ -> P τ.
Proof.
  intros P P0 Ps τ.
  remember (LMC_pty τ) as n.
  revert τ Heqn.
  induction n; eauto.
Qed.

Lemma decide_pmu (τ : PTy) : (exists τ', τ = ptrec τ') \/ LMC_pty τ = 0.
Proof.
  destruct τ; cbn; eauto.
Qed.

Lemma LMC_SimplePContr (τ : PTy) : SimplePContr τ → forall ξ, LMC_pty τ[ξ] = LMC_pty τ.
Proof.
  induction τ; cbn; try lia.
  intros.
  f_equal.
  eapply IHτ.
  intros.
  inversion H.
  assumption.
  intros.
  exfalso.
  inversion H.
Qed.

Lemma LMC_pUnfoldOnce (τ : PTy) : SimplePContr τ → LMC_pty τ > 0 → LMC_pty (pUnfoldOnce τ) = pred (LMC_pty τ).
Proof.
  intros.
  destruct (decide_pmu τ) as [(τ' & ?) | ?]; [| lia].
  subst. cbn. pose proof (LMC_SimplePContr τ').
  assert (SimplePContr τ') by (inversion H; assumption).
  specialize (H1 H2 (beta1 (ptrec τ'))).
  rewrite H1.
  lia.
Qed.

Lemma pUnfoldn_dec_lmc (τ : PTy) (n : nat) : SimplePContr τ → LMC_pty τ >= n → LMC_pty (pUnfoldn n τ) = LMC_pty τ - n.
Proof.
  revert τ; induction n; intros.
  - cbn; lia.
  - cbn.
    replace (LMC_pty τ - S n) with (LMC_pty (pUnfoldOnce τ) - n).
    eapply IHn.
    + eauto with simple_p_contr_rec.
    + rewrite LMC_pUnfoldOnce; try lia.
      assumption.
    + rewrite LMC_pUnfoldOnce; try lia.
      assumption.
Qed.

Lemma pUnfoldn_LMC {τ} : SimplePContr τ -> LMC_pty (pUnfoldn (LMC_pty τ) τ) = 0.
Proof.
  intros contrτ.
  replace 0 with (LMC_pty τ - LMC_pty τ) by lia.
  eapply pUnfoldn_dec_lmc.
  - assumption.
  - lia.
Qed.

Lemma pUnfoldn_LMC_rec {τ} : SimplePRec τ -> LMC_pty (pUnfoldn (LMC_pty τ) τ) = 0.
Proof.
  destruct 1.
  - now cbn.
  - now eapply pUnfoldn_LMC.
Qed.


Require Export Coq.Strings.String.

Definition beq_string x y :=
  if string_dec x y then true else false.

Definition total_map (A:Type) := string -> A.

Definition t_update {A:Type} (m : total_map A) (x : string) (v : A) :=
  fun x' => if beq_string x x' then v else m x'.

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

Notation "{ --> d }" := (t_empty d) (at level 0).

(* xxx *)
Lemma t_apply_empty: forall (A: Type) (x: string) (v: A), { --> v } x = v.
Proof.
intros.
trivial.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal84.

Set Printing Depth 1000.
Definition lfind_eval  y:=
Succ y.

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Zero).

Compute lfind_eval  (Zero).


(*---------------------------------------------------------------------------
    This file axiomatises the inference rules of an intuitionistic logic and
    offers some parametric instances to make it straightforward to create a new
    logic that satisfies those axioms. The purpose is to factor out what the
    assertion logic and specification logic of a separation logic framework
    have in common.
  ---------------------------------------------------------------------------*)
Require Import Setoid Morphisms RelationClasses Program.Basics Omega.
Require Import Equiv.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

(* The natural numbers in descending order. *)
Global Instance ge_Pre: PreOrder ge.
Proof. repeat constructor. hnf. eauto with arith. Qed.

(* These tactics are meant to relieve the user from remembering morphism names.
   In most cases they will apply the most general morphism for the arity
   requested. *)
(* TODO: move this somewhere more general. *)
Ltac postcancel := unfold Basics.flip; trivial.
Ltac cancel1 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _) _));
  postcancel.
Ltac cancel2 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _) _));
  postcancel.
Ltac cancel3 :=
  apply (proper_prf (Proper := _: Proper (_ ==> _ ==> _ ==> _) _));
  postcancel.

Class Inhabited A := { cinhabited : inhabited A}.

Instance inhabitedNat: Inhabited nat. Proof. split; split; apply 0. Qed.
Instance inhabitedBool: Inhabited bool. Proof. split; split; apply true. Qed.

Generalizable Variables Frm.

(* Logical connectives *)
Class ILogicOps Frm := {
  lentails: relation Frm;
  ltrue: Frm;
  lfalse: Frm;
  limpl: Frm -> Frm -> Frm;
  land: Frm -> Frm -> Frm;
  lor: Frm -> Frm -> Frm;
  lforall: forall {T}, (T -> Frm) -> Frm;
  lexists: forall {T}, (T -> Frm) -> Frm
}.

(* These notations have to sit strictly between level 80 (precendence of /\)
   and level 70 (precedence of =). *)
Infix "|--"  := lentails (at level 79, no associativity).
Infix "//\\"   := land (at level 75, right associativity).
Infix "\\//"   := lor (at level 76, right associativity).
Infix "-->>"   := limpl (at level 77, right associativity).
Notation "'Forall' x : T , p" :=
  (lforall (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Forall' x , p" :=
  (lforall (fun x => p)) (at level 78, x ident, right associativity).
Notation "'Exists' x : T , p" :=
  (lexists (fun x : T => p)) (at level 78, x ident, right associativity).
Notation "'Exists' x , p" :=
  (lexists (fun x => p)) (at level 78, x ident, right associativity).

(* Axioms of an intuitionistic logic, presented in a sequent calculus style
   with singleton contexts on the left of the turnstile. This form is
   particularly suited for the undisciplined context manipulation that tends to
   happen in separation logic.

   Every connective has a number of L-rules and a number of R-rules describing
   what can be done to prove a goal that has the connective as the head symbol
   of the left, respectively right, side of a turnstile. The notable exception
   to this pattern is implication, which is required to be the right adjoint of
   conjunction. This makes singleton contexts work. *)
Class ILogic Frm {ILOps: ILogicOps Frm} := {
  lentailsPre:> PreOrder lentails;
  ltrueR: forall C, C |-- ltrue;
  lfalseL: forall C, lfalse |-- C;
  lforallL: forall T x (P: T -> Frm) C, P x |-- C -> lforall P |-- C;
  lforallR: forall T (P: T -> Frm) C, (forall x, C |-- P x) -> C |-- lforall P;
  lexistsL: forall T (P: T -> Frm) C, (forall x, P x |-- C) -> lexists P |-- C;
  lexistsR: forall T x (P: T -> Frm) C, C |-- P x -> C |-- lexists P;
  landL1: forall P Q C, P |-- C  ->  P //\\ Q |-- C;
  landL2: forall P Q C, Q |-- C  ->  P //\\ Q |-- C;
  lorR1:  forall P Q C, C |-- P  ->  C |-- P \\// Q;
  lorR2:  forall P Q C, C |-- Q  ->  C |-- P \\// Q;
  landR:  forall P Q C, C |-- P  ->  C |-- Q  ->  C |-- P //\\ Q;
  lorL:   forall P Q C, P |-- C  ->  Q |-- C  ->  P \\// Q |-- C;
  landAdj: forall P Q C, C |-- (P -->> Q) -> C //\\ P |-- Q;
  limplAdj: forall P Q C, C //\\ P |-- Q -> C |-- (P -->> Q)
}.
Implicit Arguments ILogic [[ILOps]].
Implicit Arguments lforallL [[ILOps] [Frm] [ILogic] [T] [P] [C]].
Implicit Arguments lexistsR [[ILOps] [Frm] [ILogic] [T] [P] [C]].

Notation "|-- P" := (ltrue |-- P) (at level 85, no associativity).
Hint Extern 0 (?x |-- ?x) => reflexivity.
Hint Extern 0 (_ |-- ltrue) => apply ltrueR.
Hint Extern 0 (lfalse |-- _) => apply lfalseL.
Hint Extern 0 (?P |-- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

Section ILogicExtra.
  Context `{IL: ILogic Frm}.

  Definition lequiv P Q := P |-- Q /\ Q |-- P.
  Definition lpropand (p: Prop) Q := Exists _: p, Q.
  Definition lpropimpl (p: Prop) Q := Forall _: p, Q.

  Global Instance lequivEquiv : Equiv Frm | 0 := { equiv := lequiv }.
End ILogicExtra.

Infix "/\\" := lpropand (at level 75, right associativity).
Infix "->>" := lpropimpl (at level 77, right associativity).
Infix "-|-"  := lequiv (at level 85, no associativity).

Hint Extern 0 (?x -|- ?x) => reflexivity.
Hint Extern 0 (?P -|- ?Q) => (is_evar P; reflexivity) || (is_evar Q; reflexivity).

(* TODO: also add lforwardR. *)
Lemma lforwardL {Frm} `{IL: ILogic Frm} {Q R}:
    Q |-- R -> forall P G,
    P |-- Q ->
    (P |-- R -> G) ->
    G.
Proof. intros HQR ** HPQ HG. apply HG. etransitivity; eassumption. Qed.

Tactic Notation "lforwardL" hyp(H) :=
  eapply (lforwardL H); clear H; [|intros H].

Section ILogicMorphisms.
  Context `{IL: ILogic Frm}.

  Global Instance lequivEqu : Equivalence lequiv.
  Proof.
    unfold lequiv. constructor; red.
    + split; reflexivity.
    + intuition.
    + intros P Q R [HPQ HQP] [HQR HRQ];
      split; etransitivity; eassumption.
  Qed.

  Global Instance lequiv_lentails : subrelation lequiv lentails.
  Proof. firstorder. Qed.
  Global Instance lequiv_inverse_lentails: subrelation lequiv (inverse lentails).
  Proof. firstorder. Qed.

  Global Instance lforall_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lforall.
  Proof.
    intros P P' HP. apply lforallR; intro x;  apply lforallL with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lforall_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lforall.
  Proof.
    intros P P' HP; split; apply lforall_lentails_m; intro x; apply HP.
  Qed.

  Global Instance lexists_lentails_m T:
    Proper (pointwise_relation T lentails ++> lentails) lexists.
  Proof.
    intros P P' HP. apply lexistsL; intro x; apply lexistsR with x.
    rewrite HP; reflexivity.
  Qed.

  Global Instance lexists_lequiv_m T:
    Proper (pointwise_relation T lequiv ++> lequiv) lexists.
  Proof.
    intros P P' HP; split; apply lexists_lentails_m; intro x; apply HP.
  Qed.

  Global Instance : Proper (lequiv ==> lequiv ==> iff) lequiv.
  Proof.
    intuition.
  Qed.

  Global Instance lequiv_lentails_m : Proper (lequiv ==> lequiv ==> iff) lentails.
  Proof.
    cbv; intuition; (etransitivity; [etransitivity|]); eassumption.
  Qed.

  Global Instance lentails_lentails_m: Proper (lentails --> lentails ++> impl) lentails.
  Proof.
    intuition.
  Qed.

  Global Instance land_lentails_m:
    Proper (lentails ++> lentails ++> lentails) land.
  Proof.
    intros P P' HP Q Q' HQ.
    apply landR; [apply landL1 | apply landL2]; assumption.
  Qed.

  Global Instance land_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) land.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply land_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lor_lentails_m:
    Proper (lentails ++> lentails ++> lentails) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    apply lorL; [apply lorR1 | apply lorR2]; assumption.
  Qed.

  Global Instance lor_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) lor.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply lor_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance limpl_lentails_m:
    Proper (lentails --> lentails ++> lentails) limpl.
  Proof.
    intros P P' HP Q Q' HQ; red in HP.
    apply limplAdj; rewrite <- HQ, HP; apply landAdj; reflexivity.
  Qed.

  Global Instance limpl_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) limpl.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply limpl_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance lpropand_lentails_m:
    Proper (impl ++> lentails ++> lentails) lpropand.
  Proof.
    intros p p' Hp Q Q' HQ.
    apply lexistsL; intro H. apply lexistsR; [apply Hp|]; assumption.
  Qed.

  Global Instance lpropand_lequiv_m:
    Proper (iff ==> lequiv ==> lequiv) lpropand.
  Proof.
    intros p p' Hp Q Q' HQ.
    split; cancel2; unfold impl; (apply Hp || apply HQ).
  Qed.

  Global Instance lpropimpl_lentails_m:
    Proper (impl --> lentails ++> lentails) lpropimpl.
  Proof.
    intros p p' Hp Q Q' HQ.
    apply lforallR; intro H. apply lforallL; [apply Hp|]; assumption.
  Qed.

  Global Instance lpropimpl_lequiv_m:
    Proper (iff ==> lequiv ==> lequiv) lpropimpl.
  Proof.
    intros p p' Hp Q Q' HQ.
    split; cancel2; unfold flip, impl; (apply Hp || apply HQ).
  Qed.

End ILogicMorphisms.

Section ILogicFacts.
  Context `{IL: ILogic Frm}.

  (* Experiments with proof search. *)
  Ltac landR :=
    repeat match goal with
    | |- _ |-- _ //\\ _ => apply landR
    end.

  Ltac landL :=
    repeat match goal with
    | |- ?L1 //\\ ?L2 |-- ?R =>
        match L1 with
        | context [R] => apply landL1
        | _ =>
          match L2 with
          | context [R] => apply landL2
          end
        end
    end.

  Lemma landC P Q: P //\\ Q -|- Q //\\ P.
  Proof. split; landR; landL; reflexivity. Qed.

  Lemma landA P Q R: (P //\\ Q) //\\ R -|- P //\\ (Q //\\ R).
  Proof. split; landR; landL; reflexivity. Qed.

  (* Derivable but useful *)
  Lemma lpropandTrue P : True /\\ P -|- P.
  Proof. unfold lpropand. split; [apply lexistsL | apply lexistsR]; trivial. Qed.

  Lemma lpropandFalse P : False /\\ P -|- lfalse.
  Proof. unfold lpropand. split; [apply lexistsL |]; intuition. Qed.

  (* Left-rule for limpl. This breaks the discipline of the ILogic presentation
     since the implication is not strictly the top symbol of the left-hand side,
     but it remains a convenient rule. *)
  Lemma limplL P Q CL CR (HP: CL |-- P) (HR: Q //\\ CL |-- CR) :
    (P -->> Q) //\\ CL |-- CR.
  Proof.
    rewrite <-HR, <-HP. apply landR; [apply landAdj |apply landL2]; reflexivity.
  Qed.

  Lemma lpropandL (p: Prop) Q C (H: p -> Q |-- C) :
    p /\\ Q |-- C.
  Proof. apply lexistsL; intro Hp. apply H; assumption. Qed.

  Lemma lpropandR C (p: Prop) Q (Hp: p) (HQ: C |-- Q) :
    C |-- p /\\ Q.
  Proof. apply lexistsR with Hp; assumption. Qed.

  Lemma lpropimplL (p: Prop) (Q C: Frm) (Hp: p) (HQ: Q |-- C) :
    p ->> Q |-- C.
  Proof. apply lforallL with Hp; assumption. Qed.

  Lemma lpropimplR C (p: Prop) Q (H: p -> C |-- Q) :
    C |-- p ->> Q.
  Proof. apply lforallR; intro Hp. apply H; assumption. Qed.

  (* Special case of limplAdj/landAdj when there is just ltrue on the lhs *)
  Lemma limplValid P Q:
    |-- P -->> Q <->
    P |-- Q.
  Proof.
    split; intro H.
    - etransitivity; [eapply landR; [apply ltrueR|reflexivity]|].
      apply landAdj; assumption.
    - apply limplAdj. apply landL2; assumption.
  Qed.

  Lemma landexistsD {A} (f : A -> Frm) (P : Frm) :
    (Exists a, f a) //\\ P -|- Exists a, (f a //\\ P).
  Proof.
    split.
    + apply landAdj; apply lexistsL; intro a;
      apply limplAdj; apply lexistsR with a; reflexivity.
    + apply lexistsL; intro a; apply landR.
      - apply landL1; apply lexistsR with a; reflexivity.
      - apply landL2; reflexivity.
  Qed.

  Lemma landforallDL {A} (f : A -> Frm) (P : Frm) :
    (Forall a, f a) //\\ P |-- Forall a, (f a //\\ P).
  Proof.
    apply lforallR; intro a; apply landR.
    + apply landL1; apply lforallL with a; reflexivity.
    + apply landL2; reflexivity.
  Qed.

  Lemma landforallDR {A} {H: Inhabited A} (f : A -> Frm) (P : Frm) :
    Forall a, (f a //\\ P) |-- (Forall a, f a) //\\ P.
  Proof.
    apply landR.
    + apply lforallR; intro a; apply lforallL with a; apply landL1; reflexivity.
    + destruct H as [[a]]. apply lforallL with a; apply landL2; reflexivity.
  Qed.

  Lemma lpropandexistsD {A} (f : A -> Frm) (P : Prop) :
    P /\\ (Exists a, f a) -|- Exists a, (P /\\ f a).
  Proof.
    split.
    + apply lpropandL; intro HP; apply lexistsL; intro a.
      apply lexistsR with a; apply lpropandR; auto.
    + apply lexistsL; intro a; apply lpropandL; intro HP; apply lpropandR; [assumption|].
      apply lexistsR with a; reflexivity.
  Qed.

  Lemma lpropandforallDL {A} (f : A -> Frm) (P : Prop) :
    P /\\ (Forall a, f a) |-- Forall a, (P /\\ f a).
  Proof.
    apply lpropandL; intro HP; apply lforallR; intro a; apply lpropandR; [assumption|].
    apply lforallL with a; reflexivity.
  Qed.

  Lemma lpropandforallDR {A} {H: Inhabited A} (f : A -> Frm) (P : Prop) :
    Forall a, (P /\\ f a) |-- P /\\ (Forall a, f a).
  Proof.
    assert ((P /\\ ltrue) //\\ (Forall a, f a) |-- P /\\ (Forall a, f a)) as H0.
    + apply landAdj. apply lpropandL; intros HP. apply limplAdj; apply landL2.
      apply lpropandR; [assumption|].
      apply lforallR; intro a; apply lforallL with a; reflexivity.
    + rewrite <- H0; apply landR.
      - destruct H as [[a]]; apply lforallL with a;
        apply lpropandL; intros; apply lpropandR; auto.
      - apply lforallR; intro a; apply lforallL with a;
        apply lpropandL; intros; reflexivity.
  Qed.

End ILogicFacts.

(* Most of the connectives in ILogicOps are redundant. They can be derived from
   lexists, lforall and limpl, and the choice of limpl is unique up to lequiv
   since it is an adjoint. *)
Section ILogicEquiv.
  Context `{IL: ILogic Frm}.

  Lemma land_is_forall P Q :
    P //\\ Q -|- Forall b : bool, if b then P else Q.
  Proof.
    split.
    - apply lforallR; intro x; destruct x.
      + apply landL1; reflexivity.
      + apply landL2; reflexivity.
    - apply landR.
      + apply lforallL with true; reflexivity.
      + apply lforallL with false; reflexivity.
  Qed.

  Lemma lor_is_exists P Q:
    P \\// Q -|- Exists b : bool, if b then P else Q.
  Proof.
    split.
    - apply lorL.
      + apply lexistsR with true; reflexivity.
      + apply lexistsR with false; reflexivity.
    - apply lexistsL; intro x; destruct x.
      + apply lorR1; reflexivity.
      + apply lorR2; reflexivity.
  Qed.

  Lemma ltrue_is_forall:
    ltrue -|- Forall x: Empty_set, Empty_set_rect _ x.
  Proof. split; [apply lforallR|]; intuition. Qed.

  Lemma lfalse_is_exists:
    lfalse -|- Exists x: Empty_set, Empty_set_rect _ x.
  Proof. split; [|apply lexistsL]; intuition. Qed.

End ILogicEquiv.

Section ILogicEmbed.
  Context {A} `{ILOpsA: ILogicOps A}.
  Context {B} `{ILOpsB: ILogicOps B}.

  Class EmbedOp := { embed : A -> B }.

  Class Embed {EmbOp: EmbedOp} := {
     embed_sound p q : p |-- q -> embed p |-- embed q;

     embedlforall T f : Forall x : T, embed (f x) -|- embed (Forall x : T, f x);
     embedlexists T f : Exists x : T, embed (f x) -|- embed (Exists x : T, f x);
     embedImpl a b : (embed a) -->> (embed b) -|- embed (a -->> b)
  }.
End ILogicEmbed.

Implicit Arguments EmbedOp [].
Implicit Arguments Embed [[ILOpsA] [ILOpsB] [EmbOp]].

Section ILogicEmbedFacts.
  Context {A B} `{HAB: Embed A B} {ILA: ILogic A} {ILB: ILogic B}.

  Global Instance embed_lentails_m :
    Proper (lentails ==> lentails) embed.
  Proof.
    intros a b Hab; apply embed_sound; assumption.
  Qed.

  Global Instance embed_lequiv_m :
    Proper (lequiv ==> lequiv) embed.
  Proof.
    intros a b Hab; split; destruct Hab; apply embed_sound; assumption.
  Qed.

  Lemma embedland a b : embed a //\\ embed b -|- embed (a //\\ b).
  Proof.
    do 2 rewrite land_is_forall; rewrite <- embedlforall; split;
    apply lforallR; intro x; apply lforallL with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlor a b : embed a \\// embed b -|- embed (a \\// b).
  Proof.
    do 2 rewrite lor_is_exists; erewrite <- embedlexists; split;
    apply lexistsL; intro x; apply lexistsR with x;
    destruct x; reflexivity.
  Qed.

  Lemma embedlfalse : embed lfalse -|- lfalse.
  Proof.
    rewrite lfalse_is_exists; erewrite <- embedlexists; split;
    [apply lexistsL; intro x; destruct x | apply lfalseL].
  Qed.

  Lemma embedltrue : embed ltrue -|- ltrue.
  Proof.
    rewrite ltrue_is_forall; rewrite <- embedlforall; split;
    [apply ltrueR | apply lforallR; intro x; destruct x].
  Qed.

End ILogicEmbedFacts.

(* Prop is an intuitionistic logic *)
Global Instance ILogicOps_Prop : ILogicOps Prop := {|
  lentails P Q := P -> Q;
  ltrue        := True;
  lfalse       := False;
  limpl    P Q := P -> Q;
  land     P Q := P /\ Q;
  lor      P Q := P \/ Q;
  lforall  T F := forall x:T, F x;
  lexists  T F := exists x:T, F x
|}.

Global Instance ILogic_Prop : ILogic Prop.
Proof.
  split; cbv; firstorder.
Qed.

(* Make the setoid system realize that these are the same things (in the
   direction that seems useful. *)
Instance: subrelation lentails Basics.impl.
Proof. reflexivity. Qed.
Instance: subrelation lequiv iff.
Proof. reflexivity. Qed.

(* Coq tends to unfold lentails on [simpl], which triggers unfolding of
   several other connectives. When that happens, the goal can become quite
   unreadable. The workaround is to make the definition of entailment and
   connectives opaque. If a module wants to unfold those definitions, it should
   do [Transparent IL?_Ops], where ? is Pre or Fun. *)


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus from Project Coq                                *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                      Closed.v                                      *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Omega.
Require Import Max.
Require Import Lambda.Terms.
Require Import Lambda.Lambda_tactics.
Require Import Lambda.Substitution_term.

(* closed terms *)

Fixpoint maxvar (M: lambda) :=
match M with
| Ref i => S i
| App M1 M2 => max (maxvar M1) (maxvar M2)
| Abs N => pred (maxvar N)
end.

Lemma maxvar_lift_rec : forall M n k, maxvar M + k >= maxvar (lift_rec M n k) .
Proof.
induction M; split_all.
unfold relocate. elim(test n0 n); split_all; omega.
assert(pred (maxvar M) + k >= pred (maxvar M + k)) by omega.
assert(maxvar M + k >= maxvar (lift_rec M (S n) k)) by eapply2 IHM.
omega.
rewrite max_plus.
eapply2 max_monotonic.
Qed.

Lemma subst_decreases_maxvar :
forall M N k,  max (pred (maxvar M)) (maxvar N + k) >= maxvar(subst_rec M N k).
Proof.
induction M; split_all.
unfold insert_Ref.
elim(compare k n); split_all.
elim a; split_all.
assert(max n (maxvar N + k) >= n) by eapply2 max_is_max.
omega.
unfold lift.
elim(maxvar_lift_rec N 0 k); split_all.
eapply2 max_is_max.
assert(max n (S m) >= max n m) by (eapply2 max_monotonic; omega).
omega.
assert(max n (maxvar N + k) >= maxvar N + k) by eapply2 max_is_max.
omega.

(* 2 subgoals *)
assert(max (pred (pred (maxvar M))) (maxvar N + k) >= pred(max (pred (maxvar M)) (maxvar N + (S k)))).
rewrite max_pred.
eapply2 max_monotonic.
omega.
assert(max (pred (maxvar M)) (maxvar N + S k) >= maxvar (subst_rec M N (S k)))
by eapply2 IHM.
assert(pred (max (pred (maxvar M)) (maxvar N + S k)) >= pred (maxvar (subst_rec M N (S k)))) by omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k)) >= max (maxvar (subst_rec M1 N k)) (maxvar (subst_rec M2 N k))).
eapply2 max_monotonic.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N + k)  >=
max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k))).
2: omega.
eapply2 max_max2; eapply2 max_monotonic; eapply2 max_is_max.
Qed.

Definition decreases  (rank: lambda -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma lift_rec_closed: forall M n, n>= maxvar M  -> forall k, lift_rec M n k = M.
Proof. induction M; split_all; subst; unfold lift; unfold lift_rec; fold lift_rec.
unfold relocate. elim(test n0 n); split_all; try noway.
rewrite IHM.  auto. omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; congruence.
Qed.

Lemma lift_closed: forall M, maxvar M =0 -> forall k, lift k M = M.
Proof.  split_all; eapply2 lift_rec_closed. omega. Qed.

Lemma subst_rec_closed : forall M n, n>= maxvar M -> forall N, subst_rec M N n = M.
Proof.
induction M; split_all; subst.
unfold insert_Ref.
elim(compare n0 n); split_all; try noway.  elim a; split_all; try noway.
rewrite IHM; try omega; split_all.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Lemma maxvar_subst_rec: forall M k, maxvar M <= k -> forall N, subst_rec M N k = M.
Proof.
induction M; unfold subst_rec; fold subst_rec; split_all; subst.
unfold insert_Ref. elim(compare k n); split_all; try noway.
elim a; split_all; try noway.
rewrite IHM; split_all; omega.

assert(k>= maxvar M1 /\ k>= maxvar M2) by eapply2 max_max; split_all.
rewrite IHM1; split_all.
rewrite IHM2; split_all.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

(* restore ??

Lemma decreases_maxvar_lamF_red1: decreases maxvar lambda_red1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, lambda_red1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto; try (repeat (eapply2 max_monotonic); fail); try omega; repeat (eapply2 max_max2); try (max_r; fail); try (repeat max_l; fail).
(* 5 *)
unfold subst.
assert(max (pred (maxvar M)) (maxvar N + 0) >= maxvar(subst_rec M N 0)).
eapply2 subst_decreases_maxvar.
replace (maxvar N + 0) with (maxvar N) in H by omega.
omega.
(* 4 *)
max_l. max_r.
(* 3 *)
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
(* 2 *)
max_l. max_l. eapply2 left_component_preserves_maxvar.
max_l. max_l. eapply2 right_component_preserves_maxvar.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar lambda_red.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_lamF_red1. Qed.

*)


Require Import List Omega ZArith.Int.
Require Import Util EqDec DecSolve.
Require Import OrderedTypeEx MoreList.

Set Implicit Arguments.

(** * Definitions related to variables *)

(** ** A class for counted types *)
(** A counted type is a type for which an injection to the naturals exists *)
Class Counted (A : Type) := {
  counted     : A -> nat;
  counted_inj : forall (x y : A), counted x = counted y -> x = y;
  incc        : forall (x : A), nat -> A
}.

(** ** Variables *)
(* We take naturals directly as variables *)
Notation "'var'" := positive (only parsing).
Definition default_var : var := 1%positive.
Instance var_dec (x y:var) : Computable (x = y).
Proof.
  eapply Pos.eq_dec.
Qed.

(*
Definition var_to_nat (v:var) := v.

Coercion var_to_nat : nat >-> nat.
*)

Lemma var_eq_eq (x y : var)
  : _eq x y -> x = y.
Proof.
  inversion 1; eauto.
Qed.

(*Definition var : Type := nat.

Global Instance inst_defaulted_var : Defaulted var := Build_Defaulted default_var.
Global Instance inst_eq_dec_var : EqDec var eq := nat_eq_eqdec.
Global Program Instance inst_counted_var : Counted var :=
  Build_Counted (fun x => x) _ (fun x => fun y => x + y).
*)
(** ** Locations *)

Inductive loc : Type :=
  | LocI : nat -> loc.
Definition default_loc : loc := LocI 0.
Global Instance inst_eq_dec_loc : EqDec loc eq.
hnf; intros. destruct x,y. decide (n=n0).
subst; left; reflexivity.
right. intro. inversion H. eauto.
Defined.

Definition locN l :=
  match l with
    | LocI n => n
  end.

Lemma locN_inj (x y : loc)
  : locN x = locN y -> x = y.
Proof.
  destruct x,y; eauto.
Qed.

Definition locInc (l:loc) (d:nat) := match l with LocI n => LocI (d + n) end.

Global Instance inst_counted_loc : Counted loc :=
  Build_Counted locN locN_inj locInc.

(** ** Labels **)
(* Labels are used as identifiers for blocks *)
Inductive lab : Type :=
| LabI : nat -> lab.

Definition default_lab := LabI 0.

Lemma eq_dec_lab (x y : lab) :
  {x=y} + {x<>y}.
Proof.
  repeat decide equality.
Defined.

(** *** equality of labels is decidable *)
Global Instance inst_eq_dec_lab : EqDec lab eq := {
  equiv_dec := eq_dec_lab
}.

(** *** labels are counted *)
Coercion labN (x : lab) : nat :=
  match x with
  | LabI x => x
  end.

Lemma labN_inj (x y : lab)
  : labN x = labN y -> x = y.
Proof.
  destruct x,y; eauto.
Qed.

Smpl Add 50
     match goal with
     | [ H : labN ?x = labN ?y |- _ ] => eapply labN_inj in H; first [is_var x; subst x | is_var y; subst y| idtac ]
     end : inv_get.

Definition labInc (l:lab) (d:nat) := match l with LabI n => LabI (d + n) end.

Global Instance inst_counted_lab : Counted lab :=
  Build_Counted labN labN_inj labInc.

Lemma counted_labI (n : nat) :
  counted (LabI n) = n.
Proof.
  eauto.
Qed.

(** incremented equality implies equality *)
Lemma labeq_incr:
forall n1 n2,
LabI (1 + n1) = LabI (1 + n2)
-> LabI n1  = LabI n2.

Proof.
  intros; general induction n1; eauto.
Qed.

Definition lt (l l':lab) :=
  match l, l' with
    LabI n, LabI m => lt n m
  end.

(** ** [lab] *)
Instance lab_StrictOrder : StrictOrder lt (@eq lab).
econstructor. hnf; intros. destruct x,y,z; simpl in *. omega.
intros. destruct x,y; simpl in *. assert (n <> n0) by omega.
hnf; intros. inv H1. congruence.
Qed.

Fixpoint lab_compare (l l' : lab) :=
  match l, l' with
    | LabI n, LabI m => nat_compare n m
  end.

Program Instance lab_OrderedType : UsualOrderedType lab := {
  SOT_lt := lt;
  SOT_cmp := lab_compare;
  SOT_StrictOrder := lab_StrictOrder
}.
Next Obligation.
  case_eq (lab_compare x y); destruct x,y; simpl; intro Hcomp; constructor.
  eapply nat_compare_eq in Hcomp; eauto.
  apply nat_compare_lt in Hcomp; assumption.
  apply nat_compare_gt in Hcomp; assumption.
Qed.

Instance proper_var (ϱ:var -> var)
: Proper (_eq ==> _eq) ϱ.
Proof.
  intuition.
Qed.

Hint Extern 20 (@Proper
               (@respectful _ _
                            (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))
                            (@_eq _ (@SOT_as_OT _ (@eq nat) nat_OrderedType))) ?ϱ) => eapply proper_var.

Instance comparison_dec (x y: comparison) : Computable (x = y).
Proof.
  destruct x,y; dec_solve.
Qed.

Instance pos_lt_computable x y : Computable ((x < y)%positive).
Proof.
  unfold Pos.lt. eauto with typeclass_instances.
Qed.

Instance pos_le_computable x y : Computable ((x <= y)%positive).
Proof.
  unfold Pos.le. eauto with typeclass_instances.
Qed.

Instance pos_ge_computable x y : Computable ((x >= y)%positive).
Proof.
    unfold Pos.le. eauto with typeclass_instances.
Qed.

Instance pos_gt_computable x y : Computable ((x > y)%positive).
Proof.
    unfold Pos.le. eauto with typeclass_instances.
Qed.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrfun ssrbool.

(******************************************************************************)
(* This file defines two "base" combinatorial interfaces:                     *)
(*    eqType == the structure for types with a decidable equality.            *)
(*              Equality mixins can be made Canonical to allow generic        *)
(*              folding of equality predicates.                               *)
(* subType p == the structure for types isomorphic to {x : T | p x} with      *)
(*              p : pred T for some type T.                                   *)
(* The eqType interface supports the following operations:                    *)
(*          x == y <=> x compares equal to y (this is a boolean test).        *)
(*     x == y :> T <=> x == y at type T.                                      *)
(*          x != y <=> x and y compare unequal.                               *)
(*     x != y :> T <=>  "    "      "    "     at type T.                     *)
(*         x =P y  :: a proof of reflect (x = y) (x == y); this coerces       *)
(*                     to x == y -> x = y.                                    *)
(*    comparable T <-> equality on T is decidable                             *)
(*                    := forall x y : T, decidable (x = y)                    *)
(*  comparableClass compT == eqType mixin/class for compT : comparable T.     *)
(*             pred1 a == the singleton predicate [pred x | x == a].          *)
(* pred2, pred3, pred4 == pair, triple, quad predicates.                      *)
(*            predC1 a == [pred x | x != a].                                  *)
(*      [predU1 a & A] == [pred x | (x == a) || (x \in A)].                   *)
(*      [predD1 A & a] == [pred x | x != a & x \in A].                        *)
(*  predU1 a P, predD1 P a == applicative versions of the above.              *)
(*              frel f == the relation associated with f : T -> T.            *)
(*                     := [rel x y | f x == y].                               *)
(*       invariant k f == elements of T whose k-class is f-invariant.         *)
(*                     := [pred x | k (f x) == k x] with f : T -> T.          *)
(*  [fun x : T => e0 with a1 |-> e1, .., a_n |-> e_n]                         *)
(*  [eta f with a1 |-> e1, .., a_n |-> e_n] ==                                *)
(*    the auto-expanding function that maps x = a_i to e_i, and other values  *)
(*    of x to e0 (resp. f x). In the first form the `: T' is optional and x   *)
(*    can occur in a_i or e_i.                                                *)
(* Equality on an eqType is proof-irrelevant (lemma eq_irrelevance).          *)
(*   The eqType interface is implemented for most standard datatypes:         *)
(*  bool, unit, void, option, prod (denoted A * B), sum (denoted A + B),      *)
(*  sig (denoted {x | P}), sigT (denoted {i : I & T}).                        *)
(*   The fields of sig, sig2, and sigT are renamed sval, svalP, s2val,        *)
(* s2valP, s2valP', tag, and tagged, respectively. We also define             *)
(*   Tagged T_ x == eta-friendly constructor for {i : I | T_ i}, x : T_ i.    *)
(*   tagged_as u v == v cast as T_(tag u) if tag v == tag u, else u.          *)
(*  -> We have u == v <=> (tag u == tag v) && (tagged u == tagged_as u v).    *)
(* The subType interface supports the following operations:                   *)
(*      val == the generic injection from a subType S of T into T.            *)
(*             For example, if u : {x : T | P}, then val u : T.               *)
(*             val is injective because P is proof-irrelevant (P is in bool,  *)
(*             and the is_true coercion expands to P = true).                 *)
(*     valP == the generic proof of P (val u) for u : subType P.              *)
(* Sub x Px == the generic constructor for a subType P; Px is a proof of P x  *)
(*             and P should be inferred from the expected return type.        *)
(*  insub x == the generic partial projection of T into a subType S of T.     *)
(*             This returns an option S; if S : subType P then                *)
(*                insub x = Some u with val u = x if P x,                     *)
(*                          None if ~~ P x                                    *)
(*             The insubP lemma encapsulates this dichotomy.                  *)
(*             P should be infered from the expected return type.             *)
(*  innew x == total (non-option) variant of insub when P = predT.            *)
(* {? x | P} == option {x | P} (syntax for casting insub x).                  *)
(* insubd u0 x == the generic projection with default value u0.               *)
(*             := odflt u0 (insub x).                                         *)
(* insigd A0 x == special case of insubd for S == {x | x \in A}, where A0 is  *)
(*                a proof of x0 \in A.                                        *)
(* insub_eq x == transparent version of insub x that expands to Some/None     *)
(*               when P x can evaluate.                                       *)
(*  The subType P interface is most often implemented using one of:           *)
(*   [subType for S_val]                                                      *)
(*     where S_val : S -> T is the first projection of a type S isomorphic to *)
(*     {x : T | P}.                                                           *)
(*   [newType for S_val]                                                      *)
(*     where S_val : S -> T is the projection of a type S isomorphic to       *)
(*     wrapped T; in this case P must be predT.                               *)
(*   [subType for S_val by Srect], [newType for S_val by Srect]               *)
(*     variants of the above where the eliminator is explicitly provided.     *)
(*     Here S no longer needs to be syntactically identical to {x | P x} or   *)
(*     wrapped T, but it must have a derived constructor S_Sub statisfying an *)
(*     eliminator Srect identical to the one the Coq Inductive command would  *)
(*     have generated, and S_val (S_Sub x Px) (resp. S_val (S_sub x) for the  *)
(*     newType form) must be convertible to x.                                *)
(*     variant of the above when S is a wrapper type for T (so P = predT).    *)
(*   [subType of S], [subType of S for S_val]                                 *)
(*     clones the canonical subType structure for S; if S_val is specified,   *)
(*     then it replaces the inferred projector.                               *)
(* Subtypes inherit the eqType structure of their base types; the generic     *)
(* structure should be explicitly instantiated using the                      *)
(*   [eqMixin of S by <:]                                                     *)
(* construct to declare the Equality mixin; this pattern is repeated for all  *)
(* the combinatorial interfaces (Choice, Countable, Finite).                  *)
(*   More generally, the eqType structure can be transfered by (partial)      *)
(* injections, using:                                                         *)
(*   InjEqMixin injf == an Equality mixin for T, using an f : T -> eT where   *)
(*                      eT has an eqType structure and injf : injective f.    *)
(*    PcanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse partial function g and fK : pcancel f g.      *)
(*     CanEqMixin fK == an Equality mixin similarly derived from f and a left *)
(*                      inverse function g and fK : cancel f g.               *)
(*   We add the following to the standard suffixes documented in ssrbool.v:   *)
(*  1, 2, 3, 4 -- explicit enumeration predicate for 1 (singleton), 2, 3, or  *)
(*                4 values.                                                   *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack {sort; _ : class_of sort; _ : Type}.
Local Coercion sort : type >-> Sortclass.
Variables (T : Type) (cT : type).

Definition class := let: Pack _ c _ := cT return class_of cT in c.

Definition pack c := @Pack T c T.
Definition clone := fun c & cT -> T & phant_id (pack c) cT => pack c.

End ClassDef.

Module Exports.
Coercion sort : type >-> Sortclass.
Notation eqType := type.
Notation EqMixin := Mixin.
Notation EqType T m := (@pack T m).
Notation "[ 'eqMixin' 'of' T ]" := (class _ : mixin_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T ]") : form_scope.
Notation "[ 'eqType' 'of' T 'for' C ]" := (@clone T C _ idfun id)
  (at level 0, format "[ 'eqType'  'of'  T  'for'  C ]") : form_scope.
Notation "[ 'eqType' 'of' T ]" := (@clone T _ _ id id)
  (at level 0, format "[ 'eqType'  'of'  T ]") : form_scope.
End Exports.

End Equality.
Export Equality.Exports.

Definition eq_op T := Equality.op (Equality.class T).

Lemma eqE T x : eq_op x = Equality.op (Equality.class T) x.
Proof. by []. Qed.

Lemma eqP T : Equality.axiom (@eq_op T).
Proof. by case: T => ? []. Qed.
Implicit Arguments eqP [T x y].

Delimit Scope eq_scope with EQ.
Open Scope eq_scope.

Notation "x == y" := (eq_op x y)
  (at level 70, no associativity) : bool_scope.
Notation "x == y :> T" := ((x : T) == (y : T))
  (at level 70, y at next level) : bool_scope.
Notation "x != y" := (~~ (x == y))
  (at level 70, no associativity) : bool_scope.
Notation "x != y :> T" := (~~ (x == y :> T))
  (at level 70, y at next level) : bool_scope.
Notation "x =P y" := (eqP : reflect (x = y) (x == y))
  (at level 70, no associativity) : eq_scope.
Notation "x =P y :> T" := (eqP : reflect (x = y :> T) (x == y :> T))
  (at level 70, y at next level, no associativity) : eq_scope.

Prenex Implicits eq_op eqP.

Lemma eq_refl (T : eqType) (x : T) : x == x. Proof. exact/eqP. Qed.
Notation eqxx := eq_refl.

Lemma eq_sym (T : eqType) (x y : T) : (x == y) = (y == x).
Proof. exact/eqP/eqP. Qed.

Hint Resolve eq_refl eq_sym.

Section Contrapositives.

Variable T : eqType.
Implicit Types (A : pred T) (b : bool) (x : T).

Lemma contraTeq b x y : (x != y -> ~~ b) -> b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraTT hyp. Qed.

Lemma contraNeq b x y : (x != y -> b) -> ~~ b -> x = y.
Proof. by move=> imp hyp; apply/eqP; apply: contraNT hyp. Qed.

Lemma contraFeq b x y : (x != y -> b) -> b = false -> x = y.
Proof. by move=> imp /negbT; apply: contraNeq. Qed.

Lemma contraTneq b x y : (x = y -> ~~ b) -> b -> x != y.
Proof. by move=> imp; apply: contraTN => /eqP. Qed.

Lemma contraNneq b x y : (x = y -> b) -> ~~ b -> x != y.
Proof. by move=> imp; apply: contraNN => /eqP. Qed.

Lemma contraFneq b x y : (x = y -> b) -> b = false -> x != y.
Proof. by move=> imp /negbT; apply: contraNneq. Qed.

Lemma contra_eqN b x y : (b -> x != y) -> x = y -> ~~ b.
Proof. by move=> imp /eqP; apply: contraL. Qed.

Lemma contra_eqF b x y : (b -> x != y) -> x = y -> b = false.
Proof. by move=> imp /eqP; apply: contraTF. Qed.

Lemma contra_eqT b x y : (~~ b -> x != y) -> x = y -> b.
Proof. by move=> imp /eqP; apply: contraLR. Qed.

Lemma contra_eq x1 y1 x2 y2 : (x2 != y2 -> x1 != y1) -> x1 = y1 -> x2 = y2.
Proof. by move=> imp /eqP; apply: contraTeq. Qed.

Lemma contra_neq x1 y1 x2 y2 : (x2 = y2 -> x1 = y1) -> x1 != y1 -> x2 != y2.
Proof. by move=> imp; apply: contraNneq => /imp->. Qed.

Lemma memPn A x : reflect {in A, forall y, y != x} (x \notin A).
Proof.
apply: (iffP idP) => [notDx y | notDx]; first by apply: contraTneq => ->.
exact: contraL (notDx x) _.
Qed.

Lemma ifN_eq R x y vT vF : x != y -> (if x == y then vT else vF) = vF :> R.
Proof. exact: ifN. Qed.

Lemma ifN_eqC R x y vT vF : x != y -> (if y == x then vT else vF) = vF :> R.
Proof. by rewrite eq_sym; apply: ifN. Qed.

End Contrapositives.

Implicit Arguments memPn [T A x].

Theorem eq_irrelevance (T : eqType) x y : forall e1 e2 : x = y :> T, e1 = e2.
Proof.
pose proj z e := if x =P z is ReflectT e0 then e0 else e.
suff: injective (proj y) by rewrite /proj => injp e e'; apply: injp; case: eqP.
pose join (e : x = _) := etrans (esym e).
apply: can_inj (join x y (proj x (erefl x))) _.
by case: y /; case: _ / (proj x _).
Qed.

Corollary eq_axiomK (T : eqType) (x : T) : all_equal_to (erefl x).
Proof. move=> eq_x_x; exact: eq_irrelevance. Qed.

(* We use the module system to circumvent a silly limitation that  *)
(* forbids using the same constant to coerce to different targets. *)
Module Type EqTypePredSig.
Parameter sort : eqType -> predArgType.
End EqTypePredSig.
Module MakeEqTypePred (eqmod : EqTypePredSig).
Coercion eqmod.sort : eqType >-> predArgType.
End MakeEqTypePred.
Module Export EqTypePred := MakeEqTypePred Equality.

Lemma unit_eqP : Equality.axiom (fun _ _ : unit => true).
Proof. by do 2!case; left. Qed.

Definition unit_eqMixin := EqMixin unit_eqP.
Canonical unit_eqType := Eval hnf in EqType unit unit_eqMixin.

(* Comparison for booleans. *)

(* This is extensionally equal, but not convertible to Bool.eqb. *)
Definition eqb b := addb (~~ b).

Lemma eqbP : Equality.axiom eqb.
Proof. by do 2!case; constructor. Qed.

Canonical bool_eqMixin := EqMixin eqbP.
Canonical bool_eqType := Eval hnf in EqType bool bool_eqMixin.

Lemma eqbE : eqb = eq_op. Proof. by []. Qed.

Lemma bool_irrelevance (x y : bool) (E E' : x = y) : E = E'.
Proof. exact: eq_irrelevance. Qed.

Lemma negb_add b1 b2 : ~~ (b1 (+) b2) = (b1 == b2).
Proof. by rewrite -addNb. Qed.

Lemma negb_eqb b1 b2 : (b1 != b2) = b1 (+) b2.
Proof. by rewrite -addNb negbK. Qed.

Lemma eqb_id b : (b == true) = b.
Proof. by case: b. Qed.

Lemma eqbF_neg b : (b == false) = ~~ b.
Proof. by case: b. Qed.

Lemma eqb_negLR b1 b2 : (~~ b1 == b2) = (b1 == ~~ b2).
Proof. by case: b1; case: b2. Qed.

(* Equality-based predicates.       *)

Notation xpred1 := (fun a1 x => x == a1).
Notation xpred2 := (fun a1 a2 x => (x == a1) || (x == a2)).
Notation xpred3 := (fun a1 a2 a3 x => [|| x == a1, x == a2 | x == a3]).
Notation xpred4 :=
  (fun a1 a2 a3 a4 x => [|| x == a1, x == a2, x == a3 | x == a4]).
Notation xpredU1 := (fun a1 (p : pred _) x => (x == a1) || p x).
Notation xpredC1 := (fun a1 x => x != a1).
Notation xpredD1 := (fun (p : pred _) a1 x => (x != a1) && p x).

Section EqPred.

Variable T : eqType.

Definition pred1 (a1 : T) := SimplPred (xpred1 a1).
Definition pred2 (a1 a2 : T) := SimplPred (xpred2 a1 a2).
Definition pred3 (a1 a2 a3 : T) := SimplPred (xpred3 a1 a2 a3).
Definition pred4 (a1 a2 a3 a4 : T) := SimplPred (xpred4 a1 a2 a3 a4).
Definition predU1 (a1 : T) p := SimplPred (xpredU1 a1 p).
Definition predC1 (a1 : T) := SimplPred (xpredC1 a1).
Definition predD1 p (a1 : T) := SimplPred (xpredD1 p a1).

Lemma pred1E : pred1 =2 eq_op. Proof. move=> x y; exact: eq_sym. Qed.

Variables (T2 : eqType) (x y : T) (z u : T2) (b : bool).

Lemma predU1P : reflect (x = y \/ b) ((x == y) || b).
Proof. apply: (iffP orP) => [] []; by [right | move/eqP; left]. Qed.

Lemma pred2P : reflect (x = y \/ z = u) ((x == y) || (z == u)).
Proof. by apply: (iffP orP) => [] [] /eqP; by [left | right]. Qed.

Lemma predD1P : reflect (x <> y /\ b) ((x != y) && b).
Proof. by apply: (iffP andP)=> [] [] // /eqP. Qed.

Lemma predU1l : x = y -> (x == y) || b.
Proof. by move->; rewrite eqxx. Qed.

Lemma predU1r : b -> (x == y) || b.
Proof. by move->; rewrite orbT. Qed.

Lemma eqVneq : {x = y} + {x != y}.
Proof. by case: eqP; [left | right]. Qed.

End EqPred.

Implicit Arguments predU1P [T x y b].
Implicit Arguments pred2P [T T2 x y z u].
Implicit Arguments predD1P [T x y b].
Prenex Implicits pred1 pred2 pred3 pred4 predU1 predC1 predD1 predU1P.

Notation "[ 'predU1' x & A ]" := (predU1 x [mem A])
  (at level 0, format "[ 'predU1'  x  &  A ]") : fun_scope.
Notation "[ 'predD1' A & x ]" := (predD1 [mem A] x)
  (at level 0, format "[ 'predD1'  A  &  x ]") : fun_scope.

(* Lemmas for reflected equality and functions.   *)

Section EqFun.

Section Exo.

Variables (aT rT : eqType) (D : pred aT) (f : aT -> rT) (g : rT -> aT).

Lemma inj_eq : injective f -> forall x y, (f x == f y) = (x == y).
Proof. by move=> inj_f x y; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed.

Lemma can_eq : cancel f g -> forall x y, (f x == f y) = (x == y).
Proof. move/can_inj; exact: inj_eq. Qed.

Lemma bij_eq : bijective f -> forall x y, (f x == f y) = (x == y).
Proof. move/bij_inj; apply: inj_eq. Qed.

Lemma can2_eq : cancel f g -> cancel g f -> forall x y, (f x == y) = (x == g y).
Proof. by move=> fK gK x y; rewrite -{1}[y]gK; exact: can_eq. Qed.

Lemma inj_in_eq :
  {in D &, injective f} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move=> inj_f x y Dx Dy; apply/eqP/eqP=> [|-> //]; exact: inj_f. Qed.

Lemma can_in_eq :
  {in D, cancel f g} -> {in D &, forall x y, (f x == f y) = (x == y)}.
Proof. by move/can_in_inj; exact: inj_in_eq. Qed.

End Exo.

Section Endo.

Variable T : eqType.

Definition frel f := [rel x y : T | f x == y].

Lemma inv_eq f : involutive f -> forall x y : T, (f x == y) = (x == f y).
Proof. by move=> fK; exact: can2_eq. Qed.

Lemma eq_frel f f' : f =1 f' -> frel f =2 frel f'.
Proof. by move=> eq_f x y; rewrite /= eq_f. Qed.

End Endo.

Variable aT : Type.

(* The invariant of an function f wrt a projection k is the pred of points *)
(* that have the same projection as their image.                           *)

Definition invariant (rT : eqType) f (k : aT -> rT) :=
  [pred x | k (f x) == k x].

Variables (rT1 rT2 : eqType) (f : aT -> aT) (h : rT1 -> rT2) (k : aT -> rT1).

Lemma invariant_comp : subpred (invariant f k) (invariant f (h \o k)).
Proof. by move=> x eq_kfx; rewrite /= (eqP eq_kfx). Qed.

Lemma invariant_inj : injective h -> invariant f (h \o k) =1 invariant f k.
Proof. move=> inj_h x; exact: (inj_eq inj_h). Qed.

End EqFun.

Prenex Implicits frel.

(* The coercion to rel must be explicit for derived Notations to unparse. *)
Notation coerced_frel f := (rel_of_simpl_rel (frel f)) (only parsing).

Section FunWith.

Variables (aT : eqType) (rT : Type).

CoInductive fun_delta : Type := FunDelta of aT & rT.

Definition fwith x y (f : aT -> rT) := [fun z => if z == x then y else f z].

Definition app_fdelta df f z :=
  let: FunDelta x y := df in if z == x then y else f z.

End FunWith.

Prenex Implicits fwith.

Notation "x |-> y" := (FunDelta x y)
  (at level 190, no associativity,
   format "'[hv' x '/ '  |->  y ']'") : fun_delta_scope.

Delimit Scope fun_delta_scope with FUN_DELTA.
Arguments Scope app_fdelta [_ type_scope fun_delta_scope _ _].

Notation "[ 'fun' z : T => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z : T =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA  (fun _ => F)) ..))
  (at level 0, z ident, only parsing) : fun_scope.

Notation "[ 'fun' z => F 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun z =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA (fun _ => F)) ..))
  (at level 0, z ident, format
   "'[hv' [ '[' 'fun'  z  => '/ '  F ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
   ) : fun_scope.

Notation "[ 'eta' f 'with' d1 , .. , dn ]" :=
  (SimplFunDelta (fun _ =>
     app_fdelta d1%FUN_DELTA .. (app_fdelta dn%FUN_DELTA f) ..))
  (at level 0, z ident, format
  "'[hv' [ '[' 'eta' '/ '  f ']' '/'  'with'  '[' d1 , '/'  .. , '/'  dn ']' ] ']'"
  ) : fun_scope.

(* Various EqType constructions.                                         *)

Section ComparableType.

Variable T : Type.

Definition comparable := forall x y : T, decidable (x = y).

Hypothesis Hcompare : comparable.

Definition compareb x y : bool := Hcompare x y.

Lemma compareP : Equality.axiom compareb.
Proof. by move=> x y; exact: sumboolP. Qed.

Definition comparableClass := EqMixin compareP.

End ComparableType.

Definition eq_comparable (T : eqType) : comparable T :=
  fun x y => decP (x =P y).

Section SubType.

Variables (T : Type) (P : pred T).

Structure subType : Type := SubType {
  sub_sort :> Type;
  val : sub_sort -> T;
  Sub : forall x, P x -> sub_sort;
  _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
  _ : forall x Px, val (@Sub x Px) = x
}.

Implicit Arguments Sub [s].
Lemma vrefl : forall x, P x -> x = x. Proof. by []. Qed.
Definition vrefl_rect := vrefl.

Definition clone_subType U v :=
  fun sT & sub_sort sT -> U =>
  fun c Urec cK (sT' := @SubType U v c Urec cK) & phant_id sT' sT => sT'.

Variable sT : subType.

CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px).

Lemma SubP u : Sub_spec u.
Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed.

Lemma SubK x Px : @val sT (Sub x Px) = x.
Proof. by case: sT. Qed.

Definition insub x :=
  if @idP (P x) is ReflectT Px then @Some sT (Sub x Px) else None.

Definition insubd u0 x := odflt u0 (insub x).

CoInductive insub_spec x : option sT -> Type :=
  | InsubSome u of P x & val u = x : insub_spec x (Some u)
  | InsubNone   of ~~ P x          : insub_spec x None.

Lemma insubP x : insub_spec x (insub x).
Proof.
by rewrite /insub; case: {-}_ / idP; [left; rewrite ?SubK | right; exact/negP].
Qed.

Lemma insubT x Px : insub x = Some (Sub x Px).
Proof.
case: insubP; last by case/negP.
case/SubP=> y Py _ def_x; rewrite -def_x SubK in Px *.
congr (Some (Sub _ _)); exact: bool_irrelevance.
Qed.

Lemma insubF x : P x = false -> insub x = None.
Proof. by move/idP; case: insubP. Qed.

Lemma insubN x : ~~ P x -> insub x = None.
Proof. by move/negPf/insubF. Qed.

Lemma isSome_insub : ([eta insub] : pred T) =1 P.
Proof. by apply: fsym => x; case: insubP => // /negPf. Qed.

Lemma insubK : ocancel insub (@val _).
Proof. by move=> x; case: insubP. Qed.

Lemma valP (u : sT) : P (val u).
Proof. by case/SubP: u => x Px; rewrite SubK. Qed.

Lemma valK : pcancel (@val _) insub.
Proof. case/SubP=> x Px; rewrite SubK; exact: insubT. Qed.

Lemma val_inj : injective (@val sT).
Proof. exact: pcan_inj valK. Qed.

Lemma valKd u0 : cancel (@val _) (insubd u0).
Proof. by move=> u; rewrite /insubd valK. Qed.

Lemma val_insubd u0 x : val (insubd u0 x) = if P x then x else val u0.
Proof. by rewrite /insubd; case: insubP => [u -> | /negPf->]. Qed.

Lemma insubdK u0 : {in P, cancel (insubd u0) (@val _)}.
Proof. by move=> x Px; rewrite /= val_insubd [P x]Px. Qed.

Definition insub_eq x :=
  let Some_sub Px := Some (Sub x Px : sT) in
  let None_sub _ := None in
  (if P x as Px return P x = Px -> _ then Some_sub else None_sub) (erefl _).

Lemma insub_eqE : insub_eq =1 insub.
Proof.
rewrite /insub_eq /insub => x; case: {2 3}_ / idP (erefl _) => // Px Px'.
by congr (Some _); apply: val_inj; rewrite !SubK.
Qed.

End SubType.

Implicit Arguments SubType [T P].
Implicit Arguments Sub [T P s].
Implicit Arguments vrefl [T P].
Implicit Arguments vrefl_rect [T P].
Implicit Arguments clone_subType [T P sT c Urec cK].
Implicit Arguments insub [T P sT].
Implicit Arguments insubT [T sT x].
Implicit Arguments val_inj [T P sT].
Prenex Implicits val Sub vrefl vrefl_rect insub insubd val_inj.

Local Notation inlined_sub_rect :=
  (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px).

Local Notation inlined_new_rect :=
  (fun K K_S u => let (x) as u return K u := u in K_S x).

Notation "[ 'subType' 'for' v ]" := (SubType _ v _ inlined_sub_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'sub' 'Type' 'for' v ]" := (SubType _ v _ _ vrefl_rect)
 (at level 0, format "[ 'sub' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'subType' 'for' v 'by' rec ]" := (SubType _ v _ rec vrefl)
 (at level 0, format "[ 'subType'  'for'  v  'by'  rec ]") : form_scope.

Notation "[ 'subType' 'of' U 'for' v ]" := (clone_subType U v id idfun)
 (at level 0, format "[ 'subType'  'of'  U  'for'  v ]") : form_scope.

(*
Notation "[ 'subType' 'for' v ]" := (clone_subType _ v id idfun)
 (at level 0, format "[ 'subType'  'for'  v ]") : form_scope.
*)
Notation "[ 'subType' 'of' U ]" := (clone_subType U _ id id)
 (at level 0, format "[ 'subType'  'of'  U ]") : form_scope.

Definition NewType T U v c Urec :=
  let Urec' P IH := Urec P (fun x : T => IH x isT : P _) in
  SubType U v (fun x _ => c x) Urec'.
Implicit Arguments NewType [T U].

Notation "[ 'newType' 'for' v ]" := (NewType v _ inlined_new_rect vrefl_rect)
 (at level 0, only parsing) : form_scope.

Notation "[ 'new' 'Type' 'for' v ]" := (NewType v _ _ vrefl_rect)
 (at level 0, format "[ 'new' 'Type'  'for'  v ]") : form_scope.

Notation "[ 'newType' 'for' v 'by' rec ]" := (NewType v _ rec vrefl)
 (at level 0, format "[ 'newType'  'for'  v  'by'  rec ]") : form_scope.

Definition innew T nT x := @Sub T predT nT x (erefl true).
Implicit Arguments innew [T nT].
Prenex Implicits innew.

Lemma innew_val T nT : cancel val (@innew T nT).
Proof. by move=> u; apply: val_inj; exact: SubK. Qed.

(* Prenex Implicits and renaming. *)
Notation sval := (@proj1_sig _ _).
Notation "@ 'sval'" := (@proj1_sig) (at level 10, format "@ 'sval'").

Section SigProj.

Variables (T : Type) (P Q : T -> Prop).

Lemma svalP : forall u : sig P, P (sval u). Proof. by case. Qed.

Definition s2val (u : sig2 P Q) := let: exist2 x _ _ := u in x.

Lemma s2valP u : P (s2val u). Proof. by case: u. Qed.

Lemma s2valP' u : Q (s2val u). Proof. by case: u. Qed.

End SigProj.

Prenex Implicits svalP s2val s2valP s2valP'.

Canonical sig_subType T (P : pred T) : subType [eta P] :=
  Eval hnf in [subType for @sval T [eta [eta P]]].

(* Shorthand for sigma types over collective predicates. *)
Notation "{ x 'in' A }" := {x | x \in A}
  (at level 0, x at level 99, format  "{ x  'in'  A }") : type_scope.
Notation "{ x 'in' A | P }" := {x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ x  'in'  A  |  P }") : type_scope.

(* Shorthand for the return type of insub. *)
Notation "{ ? x : T | P }" := (option {x : T | is_true P})
  (at level 0, x at level 99, only parsing) : type_scope.
Notation "{ ? x | P }" := {? x : _ | P}
  (at level 0, x at level 99, format  "{ ?  x  |  P }") : type_scope.
Notation "{ ? x 'in' A }" := {? x | x \in A}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A }") : type_scope.
Notation "{ ? x 'in' A | P }" := {? x | (x \in A) && P}
  (at level 0, x at level 99, format  "{ ?  x  'in'  A  |  P }") : type_scope.

(* A variant of injection with default that infers a collective predicate *)
(* from the membership proof for the default value.                       *)
Definition insigd T (A : mem_pred T) x (Ax : in_mem x A) :=
  insubd (exist [eta A] x Ax).

(* There should be a rel definition for the subType equality op, but this *)
(* seems to cause the simpl tactic to diverge on expressions involving == *)
(* on 4+ nested subTypes in a "strict" position (e.g., after ~~).         *)
(* Definition feq f := [rel x y | f x == f y].                            *)

Section TransferEqType.

Variables (T : Type) (eT : eqType) (f : T -> eT).

Lemma inj_eqAxiom : injective f -> Equality.axiom (fun x y => f x == f y).
Proof. by move=> f_inj x y; apply: (iffP eqP) => [|-> //]; exact: f_inj. Qed.

Definition InjEqMixin f_inj := EqMixin (inj_eqAxiom f_inj).

Definition PcanEqMixin g (fK : pcancel f g) := InjEqMixin (pcan_inj fK).

Definition CanEqMixin g (fK : cancel f g) := InjEqMixin (can_inj fK).

End TransferEqType.

Section SubEqType.

Variables (T : eqType) (P : pred T) (sT : subType P).

Notation Local ev_ax := (fun T v => @Equality.axiom T (fun x y => v x == v y)).
Lemma val_eqP : ev_ax sT val. Proof. exact: inj_eqAxiom val_inj. Qed.

Definition sub_eqMixin := EqMixin val_eqP.
Canonical sub_eqType := Eval hnf in EqType sT sub_eqMixin.

Definition SubEqMixin :=
  (let: SubType _ v _ _ _ as sT' := sT
     return ev_ax sT' val -> Equality.class_of sT' in
   fun vP : ev_ax _ v => EqMixin vP
   ) val_eqP.

Lemma val_eqE (u v : sT) : (val u == val v) = (u == v).
Proof. by []. Qed.

End SubEqType.

Implicit Arguments val_eqP [T P sT x y].
Prenex Implicits val_eqP.

Notation "[ 'eqMixin' 'of' T 'by' <: ]" := (SubEqMixin _ : Equality.class_of T)
  (at level 0, format "[ 'eqMixin'  'of'  T  'by'  <: ]") : form_scope.

Section SigEqType.

Variables (T : eqType) (P : pred T).

Definition sig_eqMixin := Eval hnf in [eqMixin of {x | P x} by <:].
Canonical sig_eqType := Eval hnf in EqType {x | P x} sig_eqMixin.

End SigEqType.

Section ProdEqType.

Variable T1 T2 : eqType.

Definition pair_eq := [rel u v : T1 * T2 | (u.1 == v.1) && (u.2 == v.2)].

Lemma pair_eqP : Equality.axiom pair_eq.
Proof.
move=> [x1 x2] [y1 y2] /=; apply: (iffP andP) => [[]|[<- <-]] //=.
by do 2!move/eqP->.
Qed.

Definition prod_eqMixin := EqMixin pair_eqP.
Canonical prod_eqType := Eval hnf in EqType (T1 * T2) prod_eqMixin.

Lemma pair_eqE : pair_eq = eq_op :> rel _. Proof. by []. Qed.

Lemma xpair_eqE (x1 y1 : T1) (x2 y2 : T2) :
  ((x1, x2) == (y1, y2)) = ((x1 == y1) && (x2 == y2)).
Proof. by []. Qed.

Lemma pair_eq1 (u v : T1 * T2) : u == v -> u.1 == v.1.
Proof. by case/andP. Qed.

Lemma pair_eq2 (u v : T1 * T2) : u == v -> u.2 == v.2.
Proof. by case/andP. Qed.

End ProdEqType.

Implicit Arguments pair_eqP [T1 T2].

Prenex Implicits pair_eqP.

Definition predX T1 T2 (p1 : pred T1) (p2 : pred T2) :=
  [pred z | p1 z.1 & p2 z.2].

Notation "[ 'predX' A1 & A2 ]" := (predX [mem A1] [mem A2])
  (at level 0, format "[ 'predX'  A1  &  A2 ]") : fun_scope.

Section OptionEqType.

Variable T : eqType.

Definition opt_eq (u v : option T) : bool :=
  oapp (fun x => oapp (eq_op x) false v) (~~ v) u.

Lemma opt_eqP : Equality.axiom opt_eq.
Proof.
case=> [x|] [y|] /=; by [constructor | apply: (iffP eqP) => [|[]] ->].
Qed.

Canonical option_eqMixin := EqMixin opt_eqP.
Canonical option_eqType := Eval hnf in EqType (option T) option_eqMixin.

End OptionEqType.

Definition tag := projS1.
Definition tagged I T_ :  forall u, T_(tag u) := @projS2 I [eta T_].
Definition Tagged I i T_ x := @existS I [eta T_] i x.
Implicit Arguments Tagged [I i].
Prenex Implicits tag tagged Tagged.

Section TaggedAs.

Variables (I : eqType) (T_ : I -> Type).
Implicit Types u v : {i : I & T_ i}.

Definition tagged_as u v :=
  if tag u =P tag v is ReflectT eq_uv then
    eq_rect_r T_ (tagged v) eq_uv
  else tagged u.

Lemma tagged_asE u x : tagged_as u (Tagged T_ x) = x.
Proof.
by rewrite /tagged_as /=; case: eqP => // eq_uu; rewrite [eq_uu]eq_axiomK.
Qed.

End TaggedAs.

Section TagEqType.

Variables (I : eqType) (T_ : I -> eqType).
Implicit Types u v : {i : I & T_ i}.

Definition tag_eq u v := (tag u == tag v) && (tagged u == tagged_as u v).

Lemma tag_eqP : Equality.axiom tag_eq.
Proof.
rewrite /tag_eq => [] [i x] [j] /=.
case: eqP => [<-|Hij] y; last by right; case.
by apply: (iffP eqP) => [->|<-]; rewrite tagged_asE.
Qed.

Canonical tag_eqMixin := EqMixin tag_eqP.
Canonical tag_eqType := Eval hnf in EqType {i : I & T_ i} tag_eqMixin.

Lemma tag_eqE : tag_eq = eq_op. Proof. by []. Qed.

Lemma eq_tag u v : u == v -> tag u = tag v.
Proof. by move/eqP->. Qed.

Lemma eq_Tagged u x :(u == Tagged _ x) = (tagged u == x).
Proof. by rewrite -tag_eqE /tag_eq eqxx tagged_asE. Qed.

End TagEqType.

Implicit Arguments tag_eqP [I T_ x y].
Prenex Implicits tag_eqP.

Section SumEqType.

Variables T1 T2 : eqType.
Implicit Types u v : T1 + T2.

Definition sum_eq u v :=
  match u, v with
  | inl x, inl y | inr x, inr y => x == y
  | _, _ => false
  end.

Lemma sum_eqP : Equality.axiom sum_eq.
Proof. case=> x [] y /=; by [right | apply: (iffP eqP) => [->|[->]]]. Qed.

Canonical sum_eqMixin := EqMixin sum_eqP.
Canonical sum_eqType := Eval hnf in EqType (T1 + T2) sum_eqMixin.

Lemma sum_eqE : sum_eq = eq_op. Proof. by []. Qed.

End SumEqType.

Implicit Arguments sum_eqP [T1 T2 x y].
Prenex Implicits sum_eqP.


From Coq.ssr Require Import ssreflect.
From stdpp Require Import gmap.
From aneris.prelude Require Import gset_map.

Section sig_gset.
  Context `{EqDecision A, !Countable A}.

  (* TODO: upstream? *)
  Lemma length_elements (X : gset A) : length (elements X) = size X.
  Proof.
    induction X using set_ind_L.
    - rewrite elements_empty size_empty //.
    - rewrite size_union ?size_singleton; [set_solver|].
      rewrite elements_union_singleton //.
  Qed.

  Definition sig_gset (X : gset A) : Type := { a : A | a ∈ X }.

  Program Fixpoint sig_gset_list (X : gset A) (l : list A)
          (Hl : ∀ a, a ∈ l → a ∈ X) : list (sig_gset X) :=
    match l as l' return (∀ a, a ∈ l' → a ∈ X) → list { a : A | a ∈ X } with
    | [] => λ _, []
    | a :: l' => λ H, (a ↾ (H a _)) :: sig_gset_list X l' (λ b Hb, H b _)
    end Hl.
  Next Obligation. constructor. Qed.
  Next Obligation. by constructor. Qed.

  Lemma elem_of_sig_gset_list_lookup X l i (x : sig_gset X) H :
    sig_gset_list X l H !! i = Some x ↔ l !! i = Some (`x).
  Proof.
    revert i; induction l; [done|]. split.
    - destruct i; [by intros [= <-]|]. apply IHl.
    - destruct i; [|by apply IHl].
      intros [= ->]=> /=. f_equal.
      destruct x; simpl. f_equal. apply proof_irrel.
  Qed.

  Lemma length_sig_gset_list X l H :
    length (sig_gset_list X l H) = length l.
  Proof. induction l; naive_solver. Qed.

  Lemma sig_gset_list_proof_irrel X l H1 H2 :
    sig_gset_list X l H1 = sig_gset_list X l H2.
  Proof.
    induction l as [|?? IH]; [done|].
    simpl. f_equal; [|apply IH].
    f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_cons X a l H :
    ∃ Ha Hl, sig_gset_list X (a :: l) H = a ↾ Ha :: sig_gset_list X l Hl.
  Proof.
    assert (∀ a, a ∈ l → a ∈ X) as Hl by set_solver.
    exists (H a (elem_of_list_here _ _)), Hl.
    simpl. f_equal; [| apply sig_gset_list_proof_irrel].
    f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_singleton_list a X H :
    ∃ Ha, sig_gset_list X [a] H = [a ↾ Ha].
  Proof.
    exists (H a (elem_of_list_here _ _)).
    simpl. do 2 f_equal. apply proof_irrel.
  Qed.

  Lemma sig_gset_list_singleton_set a l H :
    l = [a] → ∃ Ha, sig_gset_list {[a]} l H = [a ↾ Ha].
  Proof. intros ->. eexists (H a _). simpl. do 2 f_equal. Qed.

  Program Definition sig_gset_gset (X : gset A) : gset (sig_gset X) :=
    list_to_set (C := gset _) (sig_gset_list X (elements X) _).
  Next Obligation. intros ??. by apply elem_of_elements. Qed.

  Lemma elem_of_sig_gset_gset X a :
    a ∈ sig_gset_gset X ↔ `a ∈ X.
  Proof.
    destruct a. split; [done|].
    intros [i ?]%elem_of_elements%elem_of_list_lookup_1.
    rewrite /sig_gset_gset elem_of_list_to_set.
    apply (elem_of_list_lookup_2 _ i).
    by apply elem_of_sig_gset_list_lookup.
  Qed.

  Lemma sig_gset_gset_singleton a :
    ∃ Ha, sig_gset_gset {[a]} = {[a ↾ Ha]}.
  Proof.
    assert (a ∈ ({[a]} : gset _)) as Ha by set_solver.
    eexists Ha. apply set_eq. intros ?.
    rewrite elem_of_sig_gset_gset //.
  Qed.

  Lemma sig_gset_gset_empty :
    sig_gset_gset ∅ = ∅.
  Proof. done. Qed.

  Lemma size_sig_gset X :
    size X = size (sig_gset_gset X).
  Proof.
    rewrite /sig_gset_gset -length_elements.
    refine ((fix IH l H (Hnodup : NoDup l) :=
               match l as l' return
                     l = l' →
                     NoDup l' →
                     ∀ (H : ∀ x, x ∈ l' → x ∈ _),
                       length l' =
                       size (list_to_set (sig_gset_list X l' H)) with
               | [] => _
               | a :: l' => _
               end eq_refl Hnodup H) (elements X) _ _).
    - intros -> ??. rewrite size_empty //.
    - intros -> Hd ?. inversion Hd; simplify_eq.
      edestruct sig_gset_list_cons as [? [? ->]].
      simpl. rewrite size_union ?size_singleton ?IH //.
      rewrite disjoint_singleton_l.
      rewrite elem_of_list_to_set.
      intros [? Hl']%elem_of_list_lookup_1.
      by apply elem_of_sig_gset_list_lookup, elem_of_list_lookup_2 in Hl'.
    - apply NoDup_elements.
  Qed.

  Lemma sig_gset_map_proj1_sig_subseteq (X : gset A) (Y : gset (sig_gset X)) :
    gset_map proj1_sig Y ⊆ X.
  Proof. set_unfold. by intros ? ([] & -> &?). Qed.

End sig_gset.

#[global] Hint Extern 1 ((`?p) ∈ _) => apply (proj2_sig p) : core.
#[global] Hint Extern 1 (_ ∈ sig_gset_gset _) => apply elem_of_sig_gset_gset : core.