From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint finmap.

Require Import Posrat.

Definition PMeas (A : choiceType) := seq (posrat * A).

Definition integ {A : choiceType} (d : PMeas A) (f : A -> posrat) := \big[padd/0%PR]_(p <- d) (p.1 * f (p.2)).

Lemma integ_nil {A : choiceType} (f : A -> posrat) : integ nil f = 0.
  rewrite /integ.
  rewrite big_nil.
  done.
Qed.

Lemma integ_cons {A : choiceType} (d1 : PMeas A) a f : integ (a :: d1) f = (fst a) * f (snd a) + integ d1 f.
  unfold integ.
  rewrite big_cons.
  done.
Qed.

Definition measReduced {A : choiceType} (M : PMeas A) := 0 \notin (map fst M).
Definition measUnique {A : choiceType} (M : PMeas A) := uniq (map snd M).

Definition nubbed {A : choiceType} (M : PMeas A) :=
  measReduced M && measUnique M.

Fixpoint measAdd {A : choiceType} (M : PMeas A) p (v : A) : PMeas A :=
  if p == 0 then M else
  match M with
    | nil => (p, v) :: nil
    | (p', v') :: m' =>
      if v == v' then (p + p', v) :: m' else (p', v') :: (measAdd m' p v)
                                                      end.

Lemma measAdd_cons {A: choiceType} (M : PMeas A) x p v :
  measAdd (x :: M) p v = if p == 0 then (x :: M) else if v == x.2 then (x.1 + p, v) :: M else x :: measAdd M p v.
 rewrite //=.
 destruct (p == 0); rewrite //=.
 destruct x; rewrite //=.
 rewrite paddrC //=.
Qed.

Check foldl.

Fixpoint measUndup {A : choiceType} (M : PMeas A) :=
  match M with
  | nil => nil
  | (p,v) :: m =>
    measAdd (measUndup m) p v
            end.

Lemma measAddE {A : choiceType} (M : PMeas A) p v f :
  integ (measAdd M p v) f = p * f v + integ M f.
  move: p v.
  induction M => p v.
  rewrite /measAdd.
  elim (eqVneq p 0) => [ -> | hneq].
  rewrite eq_refl integ_nil pmul0r paddr0 //=.
  rewrite (negbTE hneq) integ_cons integ_nil paddr0 //=.
  elim (eqVneq p 0) => [ -> | hneq].
  rewrite measAdd_cons integ_cons pmul0r padd0r //=.
  rewrite measAdd_cons integ_cons (negbTE hneq).
  elim (eqVneq v a.2) => [ -> | hneq2].
  rewrite eq_refl //= integ_cons //=.
  rewrite pmulrDl (paddrC (a.1 * f a.2)) paddrA //=.
  rewrite (negbTE hneq2) integ_cons IHM.
  rewrite paddrC (paddrC (a.1 * f a.2)) paddrA //=.
Qed.

Lemma measAdd_reduced {A : choiceType} (M : PMeas A) p v :
  measReduced M -> measReduced (measAdd M p v).
  rewrite /measReduced.
  move: p v; induction M => p v; rewrite //=.
  elim (eqVneq p 0) => [ -> | hneqp].
  rewrite eq_refl in_nil //=.
  rewrite (negbTE hneqp) //= in_cons in_nil eq_sym (negbTE hneqp) //=.
  elim (eqVneq p 0) => [ -> | hneqp].
  rewrite in_cons negb_or; move/andP; elim => h1 h2; apply/andP; split.
  done.
  done.
  rewrite (negbTE hneqp).
  rewrite in_cons negb_or; move/andP; elim => h1 h2.
  destruct a.
  elim (eqVneq v s) => [ -> | hneqv].
  rewrite eq_refl //=.
  rewrite in_cons negb_or; apply/andP; split.
  rewrite eq_sym -padd0 (negbTE hneqp); rewrite //= in h1; rewrite (negbTE h1).
  done.
  rewrite (negbTE hneqv) //=.
  rewrite in_cons; rewrite //= in h1; rewrite (negbTE h1) IHM.
  done.
  done.
Qed.

Lemma measAdd_in {A : choiceType} (M : PMeas A) p v x :
  p != 0 -> (x \in (map snd (measAdd M p v))) = (x \in map snd M) || (x == v).
  move: p v;
  induction M; rewrite //= => p v hneqp.
  rewrite (negbTE hneqp) in_cons in_nil orbF //=.
  rewrite (negbTE hneqp).
  destruct a.
  rewrite //=.
  elim (eqVneq v s) => [ -> | hneqx].
  rewrite eq_refl //=.
  rewrite in_cons //=.
  destruct (x == s); rewrite //=.
  rewrite orbF //=.
  rewrite !in_cons (negbTE hneqx) //=.
  rewrite in_cons.
  rewrite IHM.
  elim (eqVneq x s) => [ -> | hneqxs].
  rewrite eq_refl //=.
  rewrite (negbTE hneqxs) !orFb.
  done.
  done.
Qed.

Lemma measAdd_unique {A : choiceType} (M : PMeas A) p v :
  measUnique M -> measUnique (measAdd M p v).
  elim (eqVneq p 0) => [ -> | hneqp].
  rewrite /measUnique; move: v; induction M; rewrite //=.
  rewrite /measUnique; move: v; induction M; rewrite //=.
  rewrite (negbTE hneqp) //=.
  rewrite (negbTE hneqp) //=.
  destruct a => v; rewrite //=.
  elim (eqVneq v s) => [ -> | hneqv].
  rewrite eq_refl //=.
  rewrite (negbTE hneqv) //=.
  rewrite measAdd_in.
  rewrite eq_sym (negbTE hneqv) orbF.
  move/andP => [h1 h2].
  apply/andP; split; rewrite //=.
  apply IHM; done.
  done.
Qed.

Lemma measAdd_nubbed {A : choiceType} (M : PMeas A) p v :
  nubbed M -> nubbed (measAdd M p v).
  rewrite /nubbed.
  move/andP => [h1 h2].
  rewrite measAdd_reduced //=.
  rewrite measAdd_unique //=.
Qed.

Lemma measUndupE {A : choiceType} (M : PMeas A) f :
  integ M f = integ (measUndup M) f.
  move: f.
  induction M => f.
  rewrite integ_nil //=.
  rewrite integ_cons //=.
  destruct a; rewrite //=.
  rewrite measAddE.
  rewrite -IHM.
  done.
Qed.

Lemma measUndup_nubbed {A : choiceType} (M : PMeas A) :
  nubbed (measUndup M).
  induction M; rewrite //=.
  destruct a; apply measAdd_nubbed.
  done.
Qed.

Lemma nubbed_cons {A : choiceType} (M : PMeas A) p :
  nubbed (p :: M) -> nubbed M.
  rewrite /nubbed; move/andP => [h1 h2]; apply/andP; split.
  rewrite /measReduced //= in_cons negb_or in h1.
  move/andP: h1; elim; done.
  rewrite /measUnique //= in h2; move/andP: h2; elim; done.
Qed.

Lemma uniq_proj_uniq {A B : eqType} (xs : seq (A * B)) : uniq (map snd xs) -> uniq xs.
  induction xs; rewrite //=.
  move/andP => [h1 h2].
  rewrite IHxs //= andbT.
  apply/contraT; rewrite negbK => Hc.
  move/mapP: h1; elim.
  exists a; rewrite //=.
Qed.

Definition indicator {A : eqType} (x y : A) := if x == y then 1 else 0.

Lemma integ_nubbed_indicator_in {A : choiceType} (M : PMeas A) p :
  nubbed M -> p \in M -> integ M (indicator p.2) = p.1.
  move: p.
  induction M => p hn hin //=.
  rewrite integ_cons.
  move/orP: hin; elim.
  move/eqP => ->.
  have: integ M (indicator a.2) = 0.
  move: hn; clear; rewrite //= /nubbed.
  move/andP => [h1 h2].
  rewrite /measUnique //= in h2.
  move/andP: h2 => [h21 h22].
  move: h21 h22; clear; induction M ;rewrite //=.
  rewrite integ_nil //=.
  rewrite integ_cons //=.
  move => hn /andP; elim => h1 h2.
  rewrite IHM.
  rewrite in_cons negb_or in hn.
  move/andP: hn => [hn1 hn2].
  rewrite /indicator (negbTE hn1) pmulr0 paddr0 //=.
  rewrite in_cons negb_or in hn; move/andP: hn; elim; done.
  done.
  move => ->.
  rewrite /indicator eq_refl pmulr1 paddr0 //=.
  intros.
  rewrite IHM.
  have: a.2 != p.2.
  move/andP: hn; elim => h1 h2.
  rewrite /measUnique //= in h2; move/andP: h2; elim => h21 h22.
  apply/contraT; rewrite negbK; move/eqP => hc.
  rewrite hc in h21.
  move/mapP: h21; elim.
  exists p; done.
  rewrite /indicator => hneq; rewrite eq_sym (negbTE hneq) pmulr0 padd0r //=.
  eapply nubbed_cons; apply hn.
  done.
Qed.

Lemma integ_indicator_notin {A : choiceType} (M : PMeas A) v :
  v \notin (map snd M) -> integ M (indicator v) = 0.
  induction M; rewrite //=.
  rewrite integ_nil //=.
  rewrite in_cons integ_cons //=.
  rewrite negb_or; move /andP => [h1 h2].
  apply/eqP; rewrite -padd0.
  apply/andP; split; rewrite //=.
  rewrite /indicator (negbTE h1) pmulr0 //=.
  rewrite IHM; done.
Qed.

Lemma integ_nubbed_indicator_in_l {A : choiceType} (M : PMeas A) p :
  nubbed M -> p.1 != 0 -> integ M (indicator p.2) = p.1 -> p \in M.
  intros.
  induction M.
  rewrite integ_nil in H1; rewrite H1 eq_refl in H0; done.
  rewrite integ_cons in H1.
  case (eqVneq p.2 a.2) => [heq | hneq].
  rewrite integ_indicator_notin in H1.
  rewrite paddr0 /indicator heq eq_refl pmulr1 //= in H1.
  rewrite in_cons; destruct a; destruct p; rewrite //=.
  simpl in *.
  subst; rewrite eq_refl //=.
  rewrite heq.
  move/andP: H; elim.
  rewrite /measUnique //=.
  move => ? /andP; elim; done.
  rewrite /indicator (negbTE hneq) pmulr0 padd0r in H1.
  rewrite in_cons IHM.
  rewrite orbT //=.
  eapply nubbed_cons; apply H.
  done.
Qed.

Lemma nubbedP {A : choiceType} (M1 M2 : PMeas A) :
  nubbed M1 -> nubbed M2 -> (M1 =i M2 <-> (forall f, integ M1 f = integ M2 f)).
  move => nm1 nm2; split; intros.
  have: perm_eq M1 M2.
  apply uniq_perm_eq.
  apply uniq_proj_uniq; move/andP: nm1; elim; done.
  apply uniq_proj_uniq; move/andP: nm2; elim; done.
  done.
  intros.
  rewrite /integ.
  rewrite (eq_big_perm _ x).
  done.

  apply perm_eq_mem.
  rewrite /perm_eq all_cat; apply/andP; split.

  apply/allP => x xin; rewrite //=.
  rewrite !count_uniq_mem.
  have He := integ_nubbed_indicator_in M1 x nm1 xin.
  rewrite H in He.
  have: x \in M2.
  apply integ_nubbed_indicator_in_l; rewrite //=.
  apply/contraT; rewrite negbK => hc.
  move/andP: nm1 => [h1 h2].
  rewrite /measReduced in h1.
  move/mapP: h1; elim.
  exists x.
  done.
  rewrite (eqP hc); done.
  move => ->; rewrite xin; done.
  apply uniq_proj_uniq; move/andP: nm2; elim; done.
  apply uniq_proj_uniq; move/andP: nm1; elim; done.

  apply/allP => x xin; rewrite //=.
  rewrite !count_uniq_mem.
  have He := integ_nubbed_indicator_in M2 x nm2 xin.
  rewrite -H in He.
  have: x \in M1.
  apply integ_nubbed_indicator_in_l; rewrite //=.
  apply/contraT; rewrite negbK => hc.
  move/andP: nm2 => [h1 h2].
  rewrite /measReduced in h1.
  move/mapP: h1; elim.
  exists x.
  done.
  rewrite (eqP hc); done.
  move => ->; rewrite xin; done.
  apply uniq_proj_uniq; move/andP: nm2; elim; done.
  apply uniq_proj_uniq; move/andP: nm1; elim; done.
Qed.

Lemma nubbed_sortedP {A : choiceType} (M1 M2 : PMeas A) :
  nubbed M1 -> nubbed M2 -> canonical_keys M1 -> canonical_keys M2 -> (M1 = M2 <-> (forall f, integ M1 f = integ M2 f)).
  intros; split.
  move => ->; done.
  intros.
  apply canonical_eq_keys; rewrite //=.
  apply nubbedP; rewrite //=.
Qed.

Lemma nubbed_sort_keys {A : choiceType} (M : PMeas A) :
  nubbed M -> nubbed (sort_keys M).
  intro.
  have: perm_eq (sort_keys M) M.
  have: M = undup M.
  symmetry;
  apply undup_id.
  apply uniq_proj_uniq; move/andP: H; elim; done.
  intro heq.
  rewrite {2}heq.
  apply SortKeys.perm.
  intro.

  apply/andP; split.
  rewrite /measReduced.
  erewrite perm_eq_mem.
  move/andP: H; elim => h1 h2; apply h1.
  apply perm_map.
  done.

  rewrite /measUnique.
  erewrite perm_uniq.
  move/andP: H; elim => h1 h2; apply h2.
  apply perm_eq_mem.
  apply perm_map.
  done.

  apply perm_eq_size.
  apply perm_map.
  done.
Qed.

Lemma integ_app {A : choiceType} (d1 d2 : PMeas A) f : integ (d1 ++ d2) f = integ d1 f + integ d2 f.
  unfold integ.
  rewrite big_cat //=.
Qed.

Lemma indicator_eq0 {A : eqType} (x y : A) : (indicator x y == 0) = (x != y).
  rewrite /indicator; case (x == y); done.
Qed.

Lemma indicator_neq0 {A : eqType} (x y : A) : (indicator x y != 0) = (x == y).
  rewrite /indicator; case (x == y); rewrite //=.
Qed.


(* 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                                                     *)

(** * BoolAux

Pierre Letouzey & Laurent Thery

Some standard properties of booleans.

*)

From Coq Require Export Bool.

Lemma de_morgan1 : forall b1 b2 : bool, negb (b1 || b2) = negb b1 && negb b2.
Proof.
exact negb_orb.
Qed.

Lemma de_morgan2 : forall b1 b2 : bool, negb (b1 && b2) = negb b1 || negb b2.
Proof.
exact negb_andb.
Qed.

Lemma de_morgan3 : forall b1 b2 : bool, b1 && b2 = negb (negb b1 || negb b2).
Proof.
simple destruct b1; simple destruct b2; simpl in |- *; reflexivity.
Qed.

Lemma de_morgan4 : forall b1 b2 : bool, b1 || b2 = negb (negb b1 && negb b2).
Proof.
simple destruct b1; simple destruct b2; simpl in |- *; reflexivity.
Qed.

Lemma implb_b_true : forall b : bool, implb b true = true.
Proof.
exact implb_true_r.
Qed.

Lemma implb_b_false : forall b : bool, implb b false = negb b.
Proof.
exact implb_false_r.
Qed.

Lemma implb_true_b : forall b : bool, implb true b = b.
Proof.
exact implb_true_l.
Qed.

Lemma implb_false_b : forall b : bool, implb false b = true.
Proof.
exact implb_false_l.
Qed.

Lemma implb_elim : forall b1 b2 : bool, implb b1 b2 = negb (b1 && negb b2).
Proof.
simple destruct b1; simple destruct b2; simpl in |- *; auto.
Qed.

Lemma eqb_true_b : forall b : bool, eqb true b = b.
Proof.
simple destruct b; simpl in |- *; auto.
Qed.

Lemma eqb_b_true : forall b : bool, eqb b true = b.
Proof.
simple destruct b; simpl in |- *; auto.
Qed.

Lemma eqb_b_false : forall b : bool, eqb b false = negb b.
Proof.
simple destruct b; simpl in |- *; auto.
Qed.

Lemma eqb_false_b : forall b : bool, eqb false b = negb b.
Proof.
simple destruct b; simpl in |- *; auto.
Qed.

Lemma eqb_com : forall b1 b2 : bool, eqb b1 b2 = eqb b2 b1.
Proof.
simple destruct b1; simple destruct b2; simpl in |- *; auto.
Qed.

Lemma orb_false_1 : forall b b' : bool, b || b' = false -> b = false.
Proof.
intros b b'; case b; case b'; auto; absurd (true = false); auto.
Qed.

Lemma orb_false_2 : forall b b' : bool, b || b' = false -> b' = false.
Proof.
intros b b'; case b; case b'; auto; absurd (true = false); auto.
Qed.

#[export] Hint Resolve de_morgan1 de_morgan2 de_morgan3 de_morgan4 : core.
#[export] Hint Resolve implb_b_true implb_b_false implb_true_b implb_false_b implb_elim : core.
#[export] Hint Resolve eqb_true_b eqb_b_true eqb_b_false eqb_false_b eqb_com : core.


Require Import Prelude.
Require Import Compiler.
Import ListNotations.

Definition bind {a} {r} (f : a -> option r) (u : option a) :=
  match u with | Some y => f y | None => None end.

Lemma exec_app_distributivity: forall c d s,
  exec (c ++ d) s = bind (exec d) (exec c s).
Proof.
  induction c; intros; [auto|].
  destruct a; [simpl; auto|].
  destruct s; [auto|].
  destruct s; [auto|].
  simpl. auto.
Qed.

Lemma comp_correct_helper: forall e s,
  exec (comp e) s =  Some (eval e :: s).
Proof.
  induction e; intros; auto.
  simpl.
  rewrite exec_app_distributivity.
  rewrite IHe1.
  simpl.
  rewrite exec_app_distributivity.
  rewrite IHe2.
  auto.
Qed.

Theorem comp_correct: forall e,
  exec (comp e) [] = Some [eval e].
Proof.
  intros; apply comp_correct_helper; auto.
Qed.


From Coq Require Import Bool List.
From Coq Require Import ZArith Znumtheory micromega.Lia.

From BY Require Import Zlemmas PadicVal Zpower_nat ModInv InductionPrinciples Impl Matrix IZR Rlemmas Tactics.
From BY.Hierarchy Require Import Definitions.
From Coq Require Import Reals Rbase micromega.Lra.

Import Z RinvImpl.

Coercion IZR : Z >-> R.
Local Open Scope Z_scope.

Lemma and_lemma (P Q : Prop) (H1 : P) (H2 : P -> Q) : P /\ Q.
Proof. tauto. Qed.

(**********************************************************)
(** Specification and implementation of q, mod2 and div2 **)
(**********************************************************)

Definition q f g := ((f * (mod_inv (split2 g) (2 ^+ (S (ord2 g))))) mod (2 ^+ (S (ord2 g))))%Z.

Definition div_2 f g : R :=
  q f g / 2 ^+ ord2 g.

Definition mod_2 f g : Z :=
  (f - q f g * (split2 g)).

Notation "a 'mod2' b" := (mod_2 a b) (at level 50).
Notation "a 'div2' b" := (div_2 a b) (at level 30).

Section __.
  Context ( f g : Z )
          ( f_odd : Z.odd f = true ).

  Lemma q_0_r a : q a 0 = 0.
  Proof. unfold q; cbn; rewrite Z.mul_0_r; reflexivity. Qed.

  Lemma q_0_l a : q 0 a = 0.
  Proof.
    unfold q. rewrite Z.mul_0_l, Z.mod_0_l. reflexivity.
    apply Zpower_nat_nonzero; lia. Qed.

  Lemma mod2_0_r a : a mod2 0 = a.
  Proof. unfold mod_2; rewrite q_0_r, Z.sub_0_r; reflexivity. Qed.

  Lemma mod2_0_l a : 0 mod2 a = 0.
  Proof. unfold mod_2; rewrite q_0_l, Z.mul_0_l; reflexivity. Qed.

  Lemma div2_mod2 (g0 : (g <> 0)%Z) : IZR f = ((f div2 g) * (IZR g) + (f mod2 g))%R.
  Proof.
    unfold div_2, mod_2, split2. rewrite minus_IZR, mult_IZR, div_IZR. field.
    apply IZR_neq. apply Zpower_nat_nonzero. lia.
    apply pval_spec; lia. Qed.

  Theorem q_spec (Hg : g <> 0) :
    (odd (q f g) = true) /\ (1 <= q f g < 2 ^+ (S (ord2 g))) /\ (2 ^+ (S (ord2 g)) | (q f g) * (split2 g) - f).
  Proof.
    set (e := ord2 g).
    assert (H1 : 1 < 2 ^+ (S e)) by (apply Zpower_nat_gt1; lia).
    assert (H2 : rel_prime (split2 g) (2 ^+ (S e))).
    { apply rel_prime_pow. lia. apply Zgcd_1_rel_prime. apply odd_gcd. apply odd_split2; assumption. }
    apply and_lemma; [|split].
    - unfold q.
      rewrite odd_mod_pow2.
      rewrite odd_mul, f_odd, andb_true_l. apply odd_gcd. apply Zgcd_1_rel_prime.
      apply (rel_prime_pow _ _ (S e)). lia. apply prime_inv. lia.
      exists (split2 g). rewrite mul_comm. apply mod_inv_spec. assumption. lia. lia.
    - assert (q f g <> 0) by (apply odd_nonzero; assumption).
      enough (0 <= q f g < 2 ^+ S e). lia.
      apply mod_pos_bound. lia.
    - unfold q. replace (ord2 g) with e by reflexivity.
      apply Zmod_divide. lia.
      rewrite <- Zminus_mod_idemp_l, Zmult_mod_idemp_l, <- mul_assoc, <- Zmult_mod_idemp_r.
      rewrite (mul_comm _ (split2 g)), mod_inv_spec, mul_1_r, Zminus_mod_idemp_l.
      rewrite sub_diag, mod_0_l. reflexivity. lia. assumption. lia. Qed.

  Theorem q_unique (Hg : g <> 0) q' :
    (odd q' = true) /\ (1 <= q' < 2 ^+ (S (ord2 g))) /\ (2 ^+ (S (ord2 g)) | q' * (split2 g) - f) -> q' = q f g.
  Proof.
    pose proof (q_spec ltac:(auto)) as [q_odd [q_bound q_div]].
    intros [q'_odd [q'_bound q'_div]].
    assert (2 ^+ (S (ord2 g)) | (q f g) - q').
    apply (Gauss _ (split2 g)). replace ((split2 g) * ((q f g) - q')) with ((q f g) * (split2 g) - f - (q' * (split2 g) - f)) by ring.
    apply divide_sub_r; auto.
    apply rel_prime_sym. apply rel_prime_pow. lia.
    apply odd_rel_prime. apply odd_split2. assumption.
    apply mod_equiv in H. rewrite !mod_small in H; lia. lia. Qed.

  Theorem E1 (Hg : g <> 0) :
    exists! q, (odd q = true) /\ (1 <= q < 2 ^+ S (ord2 g)) /\ (2 ^+ (S (ord2 g)) | q * (split2 g) - f).
  Proof. exists (q f g); split; [apply q_spec; assumption|symmetry; apply q_unique; assumption]. Qed.

  Lemma mod2_div (Hg : g <> 0) : (2 ^+ (S (ord2 g)) | f mod2 g).
  Proof.
    unfold mod_2. apply Zdivide_opp_r_rev.
    replace (- (f - q f g * split2 g)) with ((q f g) * (split2 g) - f) by ring.
    apply q_spec; assumption. Qed.

  Lemma mod2_div' (Hg : g <> 0) : (2 ^+ (ord2 g) | f mod2 g).
  Proof. transitivity (2 ^+ (S (ord2 g))). exists 2. reflexivity. apply mod2_div; assumption. Qed.
End __.

(********************************************************************************)
(** This section defines the Rj number sequence and proves its relation to gcd. *)
(********************************************************************************)

Section __.
  Context (R0 R1 : Z).

  Fixpoint R_ i :=
    match i with
    | 0%nat => R0
    | S j => match j with
            | 0%nat => R1
            | S k => if R_ j =? 0 then 0 else - ((split2 (R_ k)) mod2 (R_ j)) / 2 ^+ (ord2 (R_ j))
            end
    end.

  Notation e i := (ord2 (R_ i)).

  Lemma R_S_S i :
    R_ (S (S i)) = if R_ (S i) =? 0 then 0 else - ((split2 (R_ i)) mod2 (R_ (S i))) / 2 ^+ (e (S i)).
  Proof. reflexivity. Qed.

  Lemma R_zero_S i (R0_nonzero : R0 <> 0) : R_ i = 0 -> R_ (S i) = 0.
  Proof.
    induction i; intros H.
    - simpl in *; lia.
    - rewrite R_S_S, H; reflexivity. Qed.

  Lemma R_zero_S' i : R_ (S i) = 0 -> R_ (S (S i)) = 0.
  Proof.
    induction i; intros H.
    - simpl in *; rewrite H; simpl; lia.
    - rewrite R_S_S, H; reflexivity. Qed.

  Lemma R_nonzero_S i (R0_nonzero : R0 <> 0) : R_ (S i) <> 0 -> R_ i <> 0.
  Proof. intros H H0; apply R_zero_S in H0; [contradiction|assumption]. Qed.

  Lemma R_zero i j (H : R0 <> 0) : R_ i = 0 -> (i <= j)%nat -> R_ j = 0.
  Proof.
    intros H1; revert j; apply (induction_at i).
    - assumption.
    - intros; apply R_zero_S; assumption. Qed.

  Lemma R_zero' i j : R_ (S i) = 0 -> ((S i) <= j)%nat -> R_ j = 0.
  Proof.
    intros H1; revert j; apply (induction_at (S i)).
    - assumption.
    - intros; destruct m; [lia|apply R_zero_S']; assumption. Qed.

  Lemma R_nonzero i j (R0_nonzero : R0 <> 0) : R_ i <> 0 -> (j <= i)%nat -> R_ j <> 0.
  Proof.
    intros i_nonzero j_le_i j_zero.
    destruct j; [simpl in j_zero; lia|]. apply (R_zero' _ i) in j_zero. contradiction. lia. Qed.

  Lemma R_S_S' i (H : R_ (S i) =? 0 = false) :
    R_ (S (S i)) = - ((split2 (R_ i)) mod2 (R_ (S i))) / 2 ^+ (e (S i)).
  Proof. rewrite R_S_S, H; reflexivity. Qed.

  Lemma R_even i (R0_nonzero : R0 <> 0) (R1_even : even R1 = true) : even (R_ (S i)) = true.
  Proof.
    destruct i; [assumption|].
    rewrite R_S_S.
    destruct (R_ (S i) =? 0) eqn:E; [reflexivity|apply Z.eqb_neq in E].
    assert (2 ^+ S (e (S i)) | - (split2 (R_ i) mod2 (R_ (S i)))).
    { apply Zdivide_opp_r; apply mod2_div; [apply odd_split2|assumption]; apply R_nonzero_S; assumption. }
    apply even_div; apply divide_lemma. apply Zpower_nat_pos_nonneg. lia.
    transitivity (2 ^+ S (e (S i))). exists 2.  reflexivity. assumption. rewrite Zpower_nat_mul_r. assumption. Qed.

  Lemma e_ge_1 i (R0_nonzero : R0 <> 0) (R1_even : even R1 = true) : (1 <= e (S i))%nat.
  Proof. apply ord2_even. apply R_even; assumption. Qed.

  Lemma R_eq i :
    IZR ((split2 (R_ i)) mod2 (R_ (S i))) = (split2 (R_ i) - (split2 (R_ i)) div2 (R_ (S i)) * R_ (S i))%R.
  Proof.
    destruct (Z.eq_dec (R_ (S i)) 0) as [e|e].
    - rewrite e, Rmult_0_r, Rminus_0_r, mod2_0_r. reflexivity.
    - rewrite (div2_mod2 (split2 (R_ i)) (R_ (S i))). field. assumption. Qed.

  Lemma R_recurrence i (H : R_ (S i) <> 0) (R0_nonzero : R0 <> 0) :
    2 ^+ (2 * e (S i) + e i) * (R_ (S (S i)))
    = 2 ^+ (e i) * q (split2 (R_ i)) (R_ (S i)) * (R_ (S i)) - 2 ^+ (e (S i)) * (R_ i).
  Proof.
    rewrite R_S_S, ((proj2 (Z.eqb_neq _ _)) H).
    assert (R_ i <> 0) by (apply R_nonzero_S; assumption).
    assert (2 ^+ (2 * e (S i) + e i)  =
            2 ^+ (e i) * 2 ^+ (e (S i)) * 2 ^+ (e (S i))).
    replace (2 * _)%nat with (e (S i) + e (S i))%nat by ring. rewrite !Zpower_nat_is_exp; ring.
    rewrite H1.
    rewrite <- (mul_assoc _ _ (_ / _)). rewrite <- Z_div_exact_2.
    unfold mod_2. ring_simplify.

    set (q' := q (split2 (R_ i)) (R_ (S i))).

    replace (- 2 ^+ e i * 2 ^+ e (S i) * split2 (R_ i)) with
        (- 2 ^+ e (S i) * (2 ^+ e i * split2 (R_ i))) by ring.
    rewrite <- psplit_spec'.

    replace (2 ^+ e i * 2 ^+ e (S i) * q' * split2 (R_ (S i))) with
        (2 ^+ e i * q' * (2 ^+ e (S i) * split2 (R_ (S i)))) by ring.
    rewrite <- psplit_spec'. ring. assumption. lia. assumption. lia.
    apply lt_gt; apply Zpower_nat_pos_nonneg. lia.

    apply Zdivide_mod. apply Zdivide_opp_r. apply mod2_div'. apply odd_split2. assumption. assumption. Qed.

  Lemma R_recurrence' i (H : R_ (S i) <> 0) (R0_nonzero : R0 <> 0) :
    2 ^+ e (S i) * (R_ i)
    = 2 ^+ e i * q (split2 (R_ i)) (R_ (S i)) * (R_ (S i)) - 2 ^+ (2 * e (S i) + e i) * (R_ (S (S i))).
  Proof. rewrite R_recurrence; lia. Qed.

  Local Open Scope R_scope.
  Local Open Scope lmod_scope.
  Local Open Scope vec_scope.
  Local Open Scope mat_scope.

  Theorem E2 i (HR0 : R0 <> 0%Z) (H : R_ (S i) <> 0%Z) :
    [ IZR (split2 (R_ (S i))) , IZR (R_ (S (S i))) ] ≡
    [ IZR 0 , 1 / (2 ^ (e (S i))) ; - 1 / (2 ^ (e (S i))) , (split2 (R_ i) div2 (R_ (S i))) / (2 ^ (e (S i)))] ⋅ [ IZR (split2 (R_ i)) , IZR (R_ (S i))].
  Proof.
    rewrite R_S_S, ((proj2 (Z.eqb_neq _ _)) H).
    split.
    - cbn -[R_ e]. field_simplify; [|apply Rfunctions.pow_nonzero; lra].
      unfold split2. rewrite div_IZR, Zpower_nat_IZR by (apply pval_spec; lia). reflexivity.
    - rewrite div_IZR, Zpower_nat_IZR, opp_IZR, R_eq. cbn -[R_ e]. field.
      apply Rfunctions.pow_nonzero. lra.
      apply Zdivide_opp_r; apply mod2_div'; [apply odd_split2|assumption]; apply R_nonzero_S; assumption. Qed.

  Local Close Scope R_scope.
  Local Open Scope Z_scope.

  Theorem E3 t (R0_odd : odd R0 = true) (R1_even : even R1 = true) :
    R_ (S t) = 0 -> R_ t <> 0 -> abs (split2 (R_ t)) = gcd R0 R1.
  Proof.
    intros.
    set (g := gcd R0 R1).
    assert (R0_nonzero : R0 <> 0) by (apply odd_nonzero; assumption).
    assert (odd g = true).
    { unfold g; apply gcd_odd_l; assumption. }

    assert (forall i, (g | R_ i)).
    - induction i using induction2.
      + unfold g; simpl. apply gcd_divide_l.
      + unfold g; simpl. apply gcd_divide_r.
      + destruct (eq_dec (R_ (S (S i))) 0).
        * rewrite e. apply divide_0_r.
        * eapply Gauss.
          rewrite R_recurrence.
          apply divide_sub_r.
          apply divide_mul_r; assumption.
          apply divide_mul_r; assumption.
          apply R_nonzero_S; assumption. assumption.
          apply odd_rel_prime_pow.
          pose proof (ord2_even _ (R_even i R0_nonzero R1_even)). lia. assumption.
    - set (g' := split2 (R_ t)).
      assert (g | 2 ^+ e t * g').
      { rewrite <- (psplit_spec' 2). apply H2. assumption. lia. }
      assert (g | g').
      { destruct (e t). rewrite Zpower_nat_0_r in H3. rewrite mul_1_l in H3. assumption.
        apply Gauss in H3. assumption. apply odd_rel_prime_pow. lia. assumption. }

      assert (forall i, (g' | R_ i)).
      intros.
      destruct (le_dec i (S t)).
      + generalize i l. apply rev_2_ind.
        * rewrite H. apply divide_0_r.
        * exists (2 ^+ (e t)). apply psplit_spec. assumption. lia.
        * intros. destruct k as [| [|k] ]; [assumption|assumption|].
          rewrite !Nat.pred_succ in *.
          eapply Gauss.
          rewrite R_recurrence'; try assumption.
          apply divide_sub_r.
          apply divide_mul_r; assumption.
          apply divide_mul_r; assumption.

          apply R_nonzero with (i := t); try lia; assumption.

          apply odd_rel_prime_pow.
          pose proof (ord2_even _ (R_even k R0_nonzero R1_even)); lia.
          apply odd_split2; assumption.
      + rewrite R_zero with (i := S t). apply divide_0_r; assumption. assumption. lia. lia.
      + assert (g' | g).
        apply gcd_divide_iff.
        replace R0 with (R_ 0) by reflexivity.
        replace R1 with (R_ 1) by reflexivity.
        split; apply H5.
        rewrite <- abs_eq. apply divide_antisym_abs; assumption.
        unfold g. apply gcd_nonneg. Qed.
End __.


Require Import Coq.Arith.Arith.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Arith.Max.
Require Import Coq.Bool.Bool.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import "Misc/Tactics".
Require Import "Misc/Relation".
Require Import "Misc/Library".
Require Import "Calculus/Sets".
Require Import "Calculus/Terminology".
Require Import "Calculus/MultiStaged/Definitions".

(** * Calculus Properties *)
Module CalculusProperties (Repl:Replacement)
  (Calculus: ReplacementCalculus Repl).

  Module Terminology := StagedTerminology Calculus.
  Import Calculus.CRaw.
  Import Calculus.
  Import Terminology.

  (** ** Complexity *)

  Lemma complexity_exists:
    forall (e:expr), exists n, complexity n e.
  Proof.
    induction e ; simpl ; intros ;
    try(exists 0 ; constructor ; fail) ;
    try(destruct IHe ; exists (S x) ; constructor ; auto ~ ; fail) ;
    try(destruct IHe1 ; destruct IHe2 ;
    exists (S (max x x0)) ; constructor ; auto ~).
  Qed.

  Lemma complexity_unique:
    forall (e:expr) (m n:nat),
    complexity m e -> complexity n e -> m = n.
  Proof.
    induction e ; intros ;
    try(inversion H ; inversion H0 ; auto ~ ; fail).
  Qed.

  (** ** Values *)

  Lemma svalueb_iff:
    forall (e:expr) (n:nat),
    svalueb n e = true <-> svalue n e.
  Proof.
    induction e ; simpl ; split ; intros ; auto ~ ;

    (* Case EConst, ELoc *)
    try(constructor ; auto ~ ; fail) ;

    (* Case ERef, EDeref, ERun, ELift *)
    try(destruct n ; [inversion H|] ;
      apply IHe in H ; constructor ; auto ~ ; fail) ;
    try(inversion H ; subst ; apply IHe in H2 ; auto ~ ; fail) ;

    (* Case EApp, EAssign *)
    try(apply andb_true_iff in H ; destruct H ;
    destruct n ; [inversion H|] ;
    apply IHe1 in H ; apply IHe2 in H0 ; constructor ; auto ~ ; fail) ;
    try(inversion H ; subst ;
    apply IHe1 in H3 ; apply IHe2 in H4 ;
    apply andb_true_iff ; split ; auto ~ ; fail).

    (* Case EAbs *)
    apply orb_true_iff in H.
    destruct H.
    apply beq_nat_true_iff in H ; subst ; constructor.
    apply IHe in H.
    destruct n ; constructor ; auto ~.
    apply orb_true_iff.
    inversion H ; subst.
    apply IHe in H2 ; right ; auto ~.
    left ; rewrite <- beq_nat_refl ; auto ~.

    (* Case EFix *)
    apply orb_true_iff in H.
    destruct H.
    apply beq_nat_true_iff in H ; subst ; constructor.
    apply IHe in H.
    destruct n ; constructor ; auto ~.
    apply orb_true_iff.
    inversion H ; subst.
    apply IHe in H2 ; right ; auto ~.
    left ; rewrite <- beq_nat_refl ; auto ~.

    (* Case EUnbox *)
    destruct n ; [inversion H|].
    destruct n ; [inversion H|].
    simpl in H.
    apply IHe in H ; constructor ; auto ~.
  Qed.

  Lemma svalueb_iff_conv:
    forall (e:expr) (n:nat),
    svalueb n e = false <-> ~ svalue n e.
  Proof.
    intros ; split ; unfold not ; intros.
    apply svalueb_iff in H0.
    rewrite H in H0 ; inversion H0.
    remember (svalueb n e) ; destruct b ; symmetry in Heqb.
    apply svalueb_iff in Heqb.
    exfalso ; tauto.
    reflexivity.
  Qed.

  Lemma svalue_n_Sn_O:
    forall (n:nat) (e:expr),
    svalue n e -> svalue (S n) e \/ n = 0.
  Proof.
   induction 1 ; intros ;
   try(left ; constructor ; fail) ;
   try(destruct IHsvalue ;
     [left ; constructor ; trivial | inversion H0]) ;
   try(right ; reflexivity) ;
   try(
     destruct IHsvalue1 ; try(inversion H1 ; fail) ;
     destruct IHsvalue2 ; try(inversion H2 ; fail) ;
     left ; constructor ; trivial
   ).
  Qed.

  Lemma svalue_Sn_SSn:
    forall (n:nat) (e:expr),
    svalue (S n) e -> svalue (S (S n)) e.
  Proof.
    intros.
    apply svalue_n_Sn_O in H.
    destruct H ; [assumption|inversion H].
  Qed.

  Lemma svalue_le:
    forall (n m:nat) (e:expr),
    svalue (S n) e -> (S n) <= m -> svalue m e.
  Proof.
    intros.
    induction H0 ; subst ; auto ~.
    destruct m ; [exfalso ; omega|].
    apply svalue_Sn_SSn ; auto ~.
  Qed.

  Lemma memory_svalue_get:
    forall (n:nat) (M:Memory.t) (l:location),
    l < length M -> memory_svalue n M ->
    svalue n (Memory.get l M).
  Proof.
    induction M ; simpl ; intros.
    apply lt_n_O in H ; contradiction.
    inversion H0 ; subst.
    destruct l ; simpl ; auto ~.
    unfold Memory.get ; unfold Memory.get in IHM ; simpl in *|-*.
    apply IHM ; auto ~.
    omega.
  Qed.

  (** ** Trichotomy *)
  Lemma sprogresses_not_svalue:
    forall (M1:Memory.t) (e:expr) (n:nat),
    sprogresses n (M1,e) -> ~ svalue n e.
  Proof.
    induction e ; unfold sprogresses, not in *|-* ; simpl ; intros ;
    try(destruct H ; inversion H ; fail) ;

    (* Case EAbs, EFix *)
    try(destruct H ; inversion H ; subst ;
    specialize (IHe (S n0)) ;
    inversion H0 ; subst ;
    apply IHe in H3 ; auto ~ ;
    exists (N,e2) ; auto ~ ; fail) ;

    (* Case EApp, EAssign *)
    try(inversion H0 ; subst ;
    destruct H ;
    inversion H ; subst ; [
    apply IHe1 in H4 ; auto ~ ;
    exists (N,e4) ; auto ~ |
    apply IHe2 in H5 ; auto ~ ;
    exists (N,e3) ; auto ~] ; fail) ;

    (* Case ERef, EDeref, ERun, ELift *)
    try(inversion H0 ; subst ;
    destruct H ; inversion H ; subst ;
    apply IHe in H3 ; auto ~ ;
    exists (N, e2) ; auto ~ ; fail).
  Qed.

  Lemma svalue_not_sprogresses:
    forall (n:nat) (M:Memory.t) (v:expr),
    svalue n v -> not_sprogresses n (M,v).
  Proof.
    unfold not_sprogresses ;
    induction 1 ; red ; intros ;
    try(inversion H ; fail) ;
    try(inversion H0 ; subst ;
      try(apply IHsvalue in H5) ;
      try(apply IHsvalue in H6) ;
      try(apply IHsvalue in H7) ; contradiction) ;
    try(inversion H1 ; subst ;
      [apply IHsvalue1 in H7 | apply IHsvalue2 in H8] ;
      contradiction).
  Qed.

  (** ** Partial Functions *)

  Lemma sstep_partial_function:
    forall (n:nat), partial_function (sstep n).
  Proof.
    unfold partial_function ; intros.
    generalize dependent y2.
    induction H ; intros ;

    (* App L, Assign L *)
    try(inversion H0 ; subst ;
    try(
      specialize (IHsstep (N0, e5) H6) ;
      inversion IHsstep ; subst ; reflexivity
    ) ;
    apply svalue_not_sprogresses in H ; try(contradiction) ;
    try(trivial) ; constructor ; fail) ;

    (* App R, Assign R *)
    try(inversion H1 ; subst ;
    try(
      specialize (IHsstep (N0, e3) H8) ;
      inversion IHsstep ; subst ; reflexivity
    ) ;
    try(apply svalue_not_sprogresses in H0) ;
    try(apply svalue_not_sprogresses in H7) ;
    try(contradiction) ; try(trivial) ; fail) ;

    (* App Abs, App Fix *)
    try(inversion H0 ; subst ; try(reflexivity) ;
    try(apply svalue_not_sprogresses in H6) ;
    try(apply svalue_not_sprogresses in H7) ;
    try(contradiction) ; try(trivial) ; constructor ; fail) ;

    (* Ref, Deref, Box, Unbox, Run *)
    try(inversion H0 ; subst ; try(
    specialize (IHsstep (N0, e3) H5) ;
    inversion IHsstep ; subst ; reflexivity ) ;
    apply svalue_not_sprogresses in H ; try(contradiction) ;
    try(constructor) ; trivial ; fail) ;

    (* Unbox 0, Box 0 , Ref 0, Deref 0 *)
    try(inversion H0 ; subst ; try(reflexivity) ;
    try(apply svalue_not_sprogresses in H5) ;
    try(apply svalue_not_sprogresses in H4) ; try(contradiction) ;
    try(constructor) ; trivial ; fail) ;

    (* Abs, Fix *)
    try(inversion H0 ; subst ;
    try(specialize (IHsstep (N0, e3) H6)) ;
    try(specialize (IHsstep (N0, e3) H7)) ;
    inversion IHsstep ; subst ; reflexivity) ;

    (* Assign 0 *)
    try(inversion H1 ; subst ; try(reflexivity) ;
    try(apply svalue_not_sprogresses in H7) ;
    try(apply svalue_not_sprogresses in H8) ;
    try(contradiction) ; try(trivial) ; constructor ; fail).
  Qed.

  (** ** Depth *)

  Lemma depth_svalue:
    forall (e:expr) (n:nat),
    depth e < (S n) <-> svalue (S n) e.
  Proof.
    induction e ; split ; intros ; simpl in *|-* ;
    try(constructor ; fail) ;
    try(omega) ;
    try(
      apply IHe in H ;
      constructor ; assumption
    ) ;
    try(
      inversion H ; subst ;
      apply IHe ; assumption
    ) ;
    try(
      constructor ;
      [apply IHe1 | apply IHe2] ;
      apply Nat.max_lub_lt_iff in H ;
      destruct H ; assumption
    ) ;
    try(
      inversion H ; subst ;
      apply Nat.max_lub_lt ;
      [apply IHe1 | apply IHe2] ;
      assumption
   ).

   constructor ; apply IHe ;
   omega.

   inversion H ; subst ;
   apply IHe in H2 ; omega.

   destruct n ;
   [exfalso | constructor ; apply IHe] ;
   omega.

   inversion H ; subst.
   apply IHe in H2 ; omega.
  Qed.

  Lemma svalue_ssubst:
    forall (e v:expr) (m n:nat) (x:var) (ss:StageSet.t),
    depth v = 0 -> svalue 0 v ->
    (svalue n (ssubst m ss x e v) <-> svalue n e).
  Proof.
    induction e ; simpl ; intros ; split ; intros ;
    try(constructor ; auto ~ ; fail) ;
    try(inversion H1 ; subst ; constructor ;
    apply IHe in H4 ; auto ~ ; fail) ;
    try(inversion H1 ; constructor ; apply IHe ; auto ~ ; fail).

    (* Case EVar *)
    destruct (beq_nat x v && BindingSet.rho m ss) ; auto ~.
    inversion H0 ; subst ; try(constructor) ; auto ~.

    (* Case EAbs *)
    destruct n ; [constructor|].
    apply depth_svalue ; auto ~ ; omega.
    destruct n ; [constructor|].
    apply depth_svalue ; auto ~ ; omega.
    simpl in H.
    apply svalue_le with (n:=0) ; auto ~ ; omega.

    (* Case EApp *)
    inversion H1 ; subst.
    apply IHe1 in H5 ; auto ~ ; apply IHe2 in H6 ; auto ~.
    constructor ; auto ~.
    inversion H1 ; subst.
    constructor ; [apply IHe1 | apply IHe2] ; auto ~.

    (* Case EAssign *)
    inversion H1 ; subst.
    apply IHe1 in H5 ; auto ~ ; apply IHe2 in H6 ; auto ~.
    constructor ; auto ~.
    inversion H1 ; subst.
    constructor ; [apply IHe1 | apply IHe2] ; auto ~.
  Qed.

  Lemma depth_ssubst:
    forall (e1 e2:expr) (ss:StageSet.t) (x:var) (n:nat),
    depth (ssubst n ss x e1 e2) <= depth e1 + depth e2.
  Proof.
    induction e1 ; intros ; simpl in *|-* ;

    (* Case EConst, ELoc *)
    try(omega) ;

    (* Case ERef, EDeref, ELift, ERun *)
    try(specialize (IHe1 e2 ss x n) ; assumption) ;

    (* Case EApp, EAssign *)
    try(specialize (max_spec (depth (ssubst n ss x e1_1 e2))
     (depth (ssubst n ss x e1_2 e2))) ; intros ;
    destruct H ; destruct H ; rewrite H0 in *|-* ;
    [specialize (IHe1_2 e2 ss x n) ;
    apply le_trans with (m := depth e1_2 + depth e2) ; auto ~ ;
    apply plus_le_compat_r ;
    apply le_max_r |
    specialize (IHe1_1 e2 ss x n) ;
    apply le_trans with (m := depth e1_1 + depth e2) ; auto ~ ;
    apply plus_le_compat_r ;
    apply le_max_l]).

    (* Case EVar *)
    destruct (beq_nat x v && BindingSet.rho n ss) ; simpl ; omega.

    (* Case EAbs *)
    destruct (beq_nat x v).
    specialize (IHe1 e2 (StageSet.add n ss) x n) ; assumption.
    specialize (IHe1 e2 ss x n) ; assumption.

    (* Case EFix *)
    destruct (beq_nat x v || beq_nat x v0).
    specialize (IHe1 e2 (StageSet.add n ss) x n) ; assumption.
    specialize (IHe1 e2 ss x n) ; assumption.

    (* Case EBox *)
    specialize (IHe1 e2 ss x (S n)).
    destruct (depth e1) ; simpl in *|-*.
    omega.
    destruct (depth (ssubst (S n) ss x e1 e2)) ;
    simpl in *|-* ; omega.

    (* Case EUnbox *)
    specialize (IHe1 e2 (StageSet.remove n ss) x (pred n)).
    apply le_n_S.
    assumption.
  Qed.

  Lemma memory_depth_get:
    forall (l:location) (M:Memory.t),
    depth (Memory.get l M) <= memory_depth M.
  Proof.
    unfold Memory.get.
    induction l ; simpl ; intros.
    destruct M ; simpl.
    omega.
    assert(depth = CRaw.depth).
    reflexivity.
    rewrite H in *|-*.
    apply le_max_l.
    destruct M ; simpl ; auto ~.
    apply le_trans with (m:=memory_depth M).
    apply IHl.
    apply le_max_r.
  Qed.

  Lemma memory_depth_set:
    forall (e:expr) (M:Memory.t) (l:location) ,
    memory_depth (Memory.set l e M) <= max (depth e) (memory_depth M).
  Proof.
    induction M ; simpl ; intros.
    induction l ; simpl.
    auto ~.
    assumption.
    assert(CRaw.depth = depth).
    reflexivity.
    destruct l ; simpl ;
    rewrite H in *|-*.
    apply Nat.max_le_compat_l.
    apply le_max_r.
    rewrite max_comm.
    rewrite max_comm with (n := (depth a)).
    rewrite max_assoc.
    apply Nat.max_le_compat_r.
    apply IHM.
  Qed.

  Lemma memory_depth_fresh:
    forall (e:expr) (M:Memory.t),
    memory_depth (Memory.set (Memory.fresh M) e M) =
    max (depth e) (memory_depth M).
  Proof.
    intros ; induction M ; simpl.
    reflexivity.
    rewrite IHM.
    rewrite max_comm.
    rewrite max_comm with (n := (depth a)).
    rewrite max_assoc.
    reflexivity.
  Qed.

  Lemma depth_sstep_lt:
    forall (M1:Memory.t) (e1:expr)
    (M2:Memory.t) (e2:expr) (n:nat),
    depth e1 < n -> ~ (M1, e1) ⊨ n ⇒ (M2, e2).
  Proof.
    induction e1 ; simpl ; unfold not ; intros ;
    try(inversion H0 ; fail) ;
    try(destruct n ; [omega|] ;
      inversion H0 ; subst ;
      apply IHe1 in H3 ; auto ~ ; omega ; fail) ;
    try(destruct n ; [omega|] ;
      apply le_S_n in H ;
      apply Nat.max_lub_iff in H ;
      destruct H ;
      inversion H0 ; subst ; [
      apply IHe1_1 in H4 | apply IHe1_2 in H9] ;
      auto ~ ; omega ; fail).
    destruct n ; [omega|].
    destruct n ; [omega|].
    inversion H0 ; subst.
    apply IHe1 in H3 ; auto ~ ; omega.
  Qed.

  Lemma depth_sstep_eq:
    forall (M1:Memory.t) (e1:expr)
    (M2:Memory.t) (e2:expr),
    memory_depth M1 = 0 ->
    (M1, e1) ⊨ (depth e1) ⇒ (M2, e2) ->
    depth e2 <= depth e1 /\ memory_depth M2 = 0.
  Proof.
    intros.
    generalize dependent e2.
    generalize dependent M2.
    generalize dependent e1.
    induction e1 ; simpl ; intros ; inversion H0 ;
    subst ; simpl in *|-* ;

    (* Case EAbs, EFix *)
    try(rewrite H1 in *|-* ;
    specialize (IHe1 M2 e3 H3) ;
    assumption) ;

    (* Case ERef, EDeref, ERun, ELift, n > 0 *)
    try(specialize (IHe1 M2 e3 H3) ; assumption) ;

    try(omega) ;

    (* Case EApp|EAssign e1 e2,  e1 -> e1' *)
    try(specialize (max_spec (depth e1_1) (depth e1_2)) ; intros ;
    destruct H1 ; destruct H1 ;
    rewrite H2 in *|-* ;
    [ apply depth_sstep_lt in H3 ; [destruct H3 ; subst ;
    rewrite max_r ; auto ~ ; apply lt_le_weak |] ; assumption |
    specialize (IHe1_1 M2 e3 H3) ;
    destruct IHe1_1 ; split ;
    [apply max_lub |] ; assumption]) ;

    (* Case EApp|EAssign e1 e2,  e2 -> e2' *)
    try(specialize (max_spec (depth e1_2) (depth e1_1)) ; intros ;
    destruct H1 ; destruct H1 ;
    rewrite max_comm in H2 ; rewrite H2 in *|-* ;
    [ destruct (depth e1_1) ;
    [apply lt_n_O in H1 ; contradiction|
    apply depth_svalue in H4 ;
    apply depth_sstep_lt in H8 ; [destruct H8; subst ;
    rewrite max_l ; auto ~ ; apply lt_le_weak |] ; assumption ] |
    specialize (IHe1_2 M2 e0 H8) ;
    destruct IHe1_2 ; split ;
    [apply max_lub |] ; assumption]).

    (* Case EApp (EAbs), n=0 *)
    symmetry in H1 ; apply max_0 in H1.
    destruct H1.
    specialize (depth_ssubst e e1_2 StageSet.empty x 0) ; intros.
    rewrite H1 in *|-*.
    rewrite H2 in *|-*.
    simpl in *|-* ; split ; assumption.

    (* Case EApp (EFix), n=0 *)
    symmetry in H1 ; apply max_0 in H1.
    destruct H1.
    specialize (depth_ssubst (CRaw.ssubst 0 StageSet.empty x e e1_2)
      (EFix f x e) StageSet.empty f 0) ; intros.
    simpl in *|-*.
    specialize (depth_ssubst e e1_2 StageSet.empty x 0) ; intros.
    rewrite H1 in *|-*.
    rewrite H2 in *|-*.
    simpl in *|-*.
    assert(CRaw.ssubst = ssubst).
    reflexivity.
    rewrite H6 in *|-*.
    apply le_n_0_eq in H5.
    rewrite <- H5 in *|-*.
    simpl in *|-* ; split ; assumption.

    (* Case ERef, n=0 *)
    split.
    omega.
    specialize (memory_depth_fresh e1 M1) ; intros.
    rewrite <- H1 in H2.
    rewrite H in H2.
    simpl in H2 ; assumption.

    (* Case EDeref, n=0 *)
    specialize (memory_depth_get l M2) ; intros.
    rewrite H in *|-*.
    split ; auto ~.

    (* Case EAssign, n=0 *)
    specialize (memory_depth_set e2 M1 l) ; intros.
    rewrite <- H1 in *|-*.
    rewrite H in *|-*.
    simpl in H2 ; apply le_n_0_eq in H2 ; split ; auto ~.

    (* Case EBox *)
    specialize (depth_sstep_lt M1 e1 M2 e3 1) ; intros.
    assert(depth e1 = depth ((fun x => x) e1)).
    reflexivity.
    destruct (depth e1) ; simpl in *|-*.
    assert(0 < 1).
    auto ~.
    specialize (H1 H4 H3).
    contradiction.
    specialize (IHe1 M2 e3 H3).
    destruct IHe1 ; split ; auto ~.
    assert(n = pred (S n)).
    reflexivity.
    rewrite H6.
    apply le_pred ; assumption.

    (* Case EUnbox -> EUnbox *)
    specialize (IHe1 M2 e3 H3).
    destruct IHe1 ; split ; auto ~.
    apply le_n_S ; assumption.

    (* Case EUnbox (Box) *)
    split ; auto ~.
    apply depth_svalue in H3.
    apply le_S_n.
    assumption.
  Qed.

  (** ** Fresh **)
  Lemma fresh_bv:
    forall (x:var) (e:expr) (n:nat),
    VarSet.mem x (bv n e) = true -> x < fresh e.
  Proof.
    induction e ; intros ; simpl in *|-* ;

    (* Case EVar, ELoc, EConst *)
    try(inversion H ; fail) ;

    (* Case ERef, EDeref *)
    try(specialize (IHe n) ; tauto ; fail) ;

    (* Case EApp, EAssign *)
    try(
      rewrite VarSetProperties.union_mem in H ;
      apply orb_prop in H ;
      specialize (IHe1 n) ;
      specialize (IHe2 n) ;
      apply Nat.max_lt_iff ;
      tauto ; fail).

    (* Case EAbs *)
    rewrite VarSetProperties.union_mem in H ;
    apply orb_prop in H ;
    destruct H ; [
    unfold BindingSet.bindSet in H ;
    destruct (Repl.rho n) ; [
    apply VarSetProperties.singleton_mem in H ;
    subst ;
    destruct (fresh e) ; [auto ~ |] ;
    apply le_trans with (m:= S x) ;
    [auto ~ | apply le_n_S ; apply le_max_l]
    | ] ; inversion H |
    apply IHe in H ;
    destruct (fresh e) ; [
    inversion H |
    apply le_trans with (m:= S v0) ;
    [auto ~ | apply le_n_S ; apply le_max_r]]].

    (* Case EFix *)
    rewrite VarSetProperties.union_mem in H.
    apply orb_prop in H.
    destruct H.

    unfold BindingSet.bindSet in H ;
    destruct (Repl.rho n) ; [
    apply VarSetProperties.singleton_mem in H ;
    subst ;
    destruct (fresh e) ; [auto ~ |] ;
    apply le_trans with (m:= S x) ; auto ~ ;
    apply le_n_S ; apply le_max_l |
    inversion H ].

    rewrite VarSetProperties.union_mem in H ;
    apply orb_prop in H ;
    destruct H.

    unfold BindingSet.bindSet in H ;
    destruct (Repl.rho n) ; [
    apply VarSetProperties.singleton_mem in H ;
    subst ;
    destruct (fresh e) ; [auto ~ |] ;
    apply le_trans with (m:= S x) ; auto ~ ;
    [apply le_n_S ; apply Nat.le_max_r |
    apply le_trans with (m:= S (max x v0)) ; auto ~ ;
    [apply le_n_S ; apply Nat.le_max_l |
    apply le_n_S ; apply Nat.le_max_r ]] | inversion H].

    apply IHe in H ;
    destruct (fresh e) ; [
    inversion H |
    apply le_trans with (m:= S v1)] ; auto ~ ;
    apply le_n_S ; apply le_trans with (m:= (max v0 v1)) ; auto ~ ;
    apply le_max_r.

    (* Case EBox *)
    specialize (IHe (S n)).
    tauto.

    (* Case EUnbox *)
    specialize (IHe (pred n)).
    tauto.
  Qed.

End CalculusProperties.

Module ReplacementProperties (Repl:Replacement).

  Module Calculus := Calculus Repl.

  Include (CalculusProperties Repl Calculus).

End ReplacementProperties.

(** * Lisp-Like Calculus Properties *)
Module LispLikeCalculusProperties.

  Module BindingSetProperties :=
    BindingSetProperties LispLikeReplacement
    LispLikeCalculus.CRaw.BindingSet.
  Import LispLikeCalculus.
  Import LispLikeCalculus.CRaw.
  Import LispLikeReplacement.

  (** ** Explicit Lisp-Like Substitution Function *)
  Fixpoint ll_subst (n:nat) (x:var) (e v:expr) :=
    match e with
    | EConst _ => e
    | EVar y =>
        if andb (beq_nat x y) (beq_nat n 0) then v else e
    | EAbs y e => EAbs y
        (if andb (beq_nat x y) (beq_nat n 0)
        then e else ll_subst n x e v)
    | EFix f y e => EFix f y
        (if andb (orb (beq_nat x f) (beq_nat x y)) (beq_nat n 0)
        then e else ll_subst n x e v)
    | EApp e1 e2 => EApp (ll_subst n x e1 v) (ll_subst n x e2 v)
    | ELoc l => ELoc l
    | ERef e => ERef (ll_subst n x e v)
    | EDeref e => EDeref (ll_subst n x e v)
    | EAssign e1 e2 => EAssign (ll_subst n x e1 v) (ll_subst n x e2 v)
    | EBox e => EBox (ll_subst (S n) x e v)
    | EUnbox e => EUnbox (ll_subst (pred n) x e v)
    | ERun e => ERun (ll_subst n x e v)
    | ELift e => ELift (ll_subst n x e v)
    end.

  Lemma ssubst_ll_rho_O:
    forall (e v:expr) (St:StageSet.t) (n:nat) (x:var),
    StageSet.mem 0 St = true ->
    depth e <= n ->
    ssubst n St x e v = e.
  Proof.
    induction e ; simpl ; intros ;
    try(rewrite IHe) ;
    try(rewrite IHe1, IHe2) ;
    try(omega) ;
    try(apply max_lub_r in H0 ; assumption) ;
    try(apply max_lub_l in H0 ; assumption) ;
    try(reflexivity) ;
    try(assumption).

    (* Var *)
    assert(BindingSet.rho n St = false).
    apply BindingSetProperties.rho_le_O ; trivial.
    rewrite H1, andb_false_r ; reflexivity.

    (* Abs *)
    destruct (beq_nat x v).
    apply StageSetProperties.add_mem_2 ; assumption.
    assumption.
    (* Fix *)
    destruct (beq_nat x v || beq_nat x v0).
    apply StageSetProperties.add_mem_2 ; assumption.
    assumption.
    destruct n.
    exfalso ; omega.
    rewrite StageSetProperties.remove_mem_1.
    assumption.
    omega.
  Qed.

  Lemma ssubst_ll_subst:
    forall (e v:expr) (St:StageSet.t) (n:nat) (x:var),
    StageSet.ub n St = true ->
    StageSet.mem 0 St = false ->
    depth e <= n ->
    ssubst n St x e v = ll_subst n x e v.
  Proof.
    induction e ; simpl ; intros ;
    try(rewrite IHe1, IHe2) ;
    try(omega) ;
    try(apply max_lub_r in H1 ; assumption) ;
    try(apply max_lub_l in H1 ; assumption) ;
    try(reflexivity) ;
    try(assumption) ;
    try(rewrite IHe ;
    try(assumption) ; try(reflexivity) ; fail).

    (* Var *)
    destruct n.
    rewrite <- beq_nat_refl.
    assert(BindingSet.rho 0 St = true).
    apply BindingSetProperties.rho_O_true ; trivial.
    rewrite H2, andb_true_r ; reflexivity.
    assert(beq_nat (S n) 0 = false).
    apply beq_nat_false_iff ; omega.
    rewrite H2, andb_false_r.
    assert(BindingSet.rho (S n) St = false).
    apply BindingSetProperties.rho_false.
    reflexivity.
    rewrite H3, andb_false_r ; reflexivity.

    (* Abs *)
    destruct n.
    rewrite <- beq_nat_refl, andb_true_r.
    destruct (beq_nat x v).
    rewrite ssubst_ll_rho_O ; try(trivial).
    apply StageSetProperties.add_mem_3.
    rewrite IHe ; try(reflexivity) ; assumption.
    assert(beq_nat (S n) 0 = false).
    apply beq_nat_false_iff ; omega.
    rewrite H2, andb_false_r.
    destruct (beq_nat x v) ; rewrite IHe ;
    try(assumption) ; try(reflexivity).
    rewrite <- StageSetProperties.ub_le_1 ; auto ~.
    rewrite StageSetProperties.add_mem_4.
    assumption.
    auto ~.

    (* Fix *)
    destruct n.
    rewrite <- beq_nat_refl, andb_true_r.
    destruct (beq_nat x v).
    rewrite ssubst_ll_rho_O ; trivial.
    rewrite orb_true_l.
    apply StageSetProperties.add_mem_3.
    rewrite orb_false_l.
    destruct (beq_nat x v0).
    rewrite ssubst_ll_rho_O ; trivial.
    apply StageSetProperties.add_mem_3.
    rewrite IHe ; try(reflexivity) ; assumption.
    assert(beq_nat (S n) 0 = false).
    apply beq_nat_false_iff ; omega.
    rewrite H2, andb_false_r.
    destruct (beq_nat x v) ; rewrite IHe ;
    try(assumption) ; try(reflexivity).
    rewrite orb_true_l.
    rewrite <- StageSetProperties.ub_le_1 ; auto ~.
    rewrite orb_true_l.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite orb_false_l.
    destruct (beq_nat x v0).
    rewrite <- StageSetProperties.ub_le_1 ; auto ~.
    assumption.
    rewrite orb_false_l.
    destruct (beq_nat x v0).
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    assumption.

    (* Box *)
    rewrite IHe ; try(reflexivity) ; try(assumption).
    apply StageSetProperties.ub_le_2 with (m:=n) ; auto ~.
    omega.

    (* Unbox *)
    destruct n ; [exfalso ; omega|].
    simpl ; rewrite IHe ; try(reflexivity) ; try(assumption).
    rewrite <- StageSetProperties.ub_S ; auto ~.
    rewrite StageSetProperties.remove_mem_1 ; auto ~.
    omega.
  Qed.

  Lemma ssubst_ll_subst_O:
    forall (e v:expr) (x:var),
    depth e = 0 ->
    ssubst 0 StageSet.empty x e v = ll_subst 0 x e v.
  Proof.
    intros ; rewrite ssubst_ll_subst ;
    auto ~ ; omega.
  Qed.

  (** ** Explicit Lisp-Like Free Variables Function *)
  Fixpoint ll_fv (n:nat) (e:expr) : VarSet.t :=
    match e with
    | EConst _ => VarSet.empty
    | EVar x => match n with
        | 0 => VarSet.singleton x
        | S _ => VarSet.empty
        end
    | EAbs x e => match n with
        | 0 => VarSet.remove x (ll_fv n e)
        | S _ => ll_fv n e
        end
    | EFix f x e => match n with
        | 0 => VarSet.remove x (VarSet.remove f (ll_fv n e))
        | S _ => ll_fv n e
        end
    | EApp e1 e2 => VarSet.union (ll_fv n e1) (ll_fv n e2)
    | ELoc _ => VarSet.empty
    | ERef e => ll_fv n e
    | EDeref e => ll_fv n e
    | EAssign e1 e2 => VarSet.union (ll_fv n e1) (ll_fv n e2)
    | EBox e => ll_fv (S n) e
    | EUnbox e => ll_fv (pred n) e
    | ERun e => ll_fv n e
    | ELift e => ll_fv n e
    end.

  Lemma fv_ll_rho_O:
    forall (e:expr) (B:BindingSet.t) (n:nat) (x:var),
    StageSet.mem 0 (BindingSet.get x B) = true ->
    depth e <= n ->
    VarSet.mem x (fv n B e) = false.
  Proof.
    induction e ; simpl ; intros ;

    try(rewrite IHe with (n:=n) ; trivial ; fail) ;
    try(
      rewrite VarSetProperties.union_mem, orb_false_iff ;
      rewrite Nat.max_lub_iff in H0 ; destruct H0 ; split ;
      [rewrite IHe1 with (n:=n) | rewrite IHe2 with (n:=n)] ;
      trivial ; fail) ;
    try(destruct x ; reflexivity ; fail).

    (* Var *)
    unfold BindingSet.varSet, rho.
    case_beq_nat n 0 ; simpl.
    case_beq_nat v x.
    rewrite BindingSetProperties.rho_le_O ; trivial.
    destruct (BindingSet.rho 0 (BindingSet.get v B)) ; trivial.
    rewrite VarSetProperties.singleton_equal_add.
    apply VarSetProperties.add_mem_4 ; auto ~.
    destruct n ; [exfalso ; auto ~|].
    rewrite BindingSetProperties.rho_false ; trivial.

    (* Abs *)
    rewrite IHe with (n:=n) ; trivial.
    case_beq_nat v x.
    rewrite BindingSetProperties.add_get_1.
    case_beq_nat n 0.
    apply StageSetProperties.add_mem_3.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    (* Fix *)
    rewrite IHe with (n:=n) ; trivial.
    assert(Sets.NatSet.MSetIntern.mem 0
      (BindingSetProperties.BindingSet.get x
      (BindingSet.add v0 n B)) = true).
    case_beq_nat v0 x.
    rewrite BindingSetProperties.add_get_1.
    case_beq_nat n 0.
    apply StageSetProperties.add_mem_3.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    case_beq_nat v x.
    rewrite BindingSetProperties.add_get_1.
    case_beq_nat n 0.
    apply StageSetProperties.add_mem_3.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    (* Box *)
    apply IHe ; auto ~ ; omega.

    (* Unbox *)
    destruct n.
    inversion H0.
    apply le_S_n in H0.
    apply IHe ; auto ~.
    rewrite BindingSetProperties.remove_get.
    rewrite StageSetProperties.remove_mem_1 ; auto ~.
  Qed.

  Lemma fv_ll_fv:
    forall (e:expr) (B:BindingSet.t) (x:var) (n:nat),
    BindingSet.ub n B = true ->
    StageSet.mem 0 (BindingSet.get x B) = false ->
    depth e <= n ->
    StageSet.mem x (fv n B e) = StageSet.mem x (ll_fv n e).
  Proof.
    induction e ; simpl ; intros ;
    (* Const, Loc *)
    try(reflexivity) ;
    (* Ref, Deref, Lift, Run *)
    try(apply IHe ; trivial ; fail) ;
    (* App, Assign *)
    try(repeat (rewrite VarSetProperties.union_mem) ;
    rewrite IHe1, IHe2 ; trivial ;
    [apply max_lub_r in H1 | apply max_lub_l in H1 ];
    trivial ; fail).

    (* Var *)
    destruct n ;
    unfold BindingSet.varSet, rho.
    case_beq_nat v x.
    rewrite BindingSetProperties.rho_O_true ; trivial.
    apply BindingSetProperties.ub_get ; trivial.
    destruct (BindingSet.rho 0 (BindingSet.get v B)).
    reflexivity.
    rewrite VarSetProperties.singleton_equal_add.
    rewrite VarSetProperties.add_mem_4 ; trivial.
    rewrite BindingSetProperties.rho_false ; trivial.

    (* Abs *)
    destruct n.
    case_beq_nat v x.
    rewrite VarSetProperties.remove_mem_2.
    apply fv_ll_rho_O ; trivial.
    rewrite BindingSetProperties.add_get_1.
    apply StageSetProperties.add_mem_3.
    rewrite StageSetProperties.remove_mem_1 ; trivial.
    rewrite IHe ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    rewrite IHe ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    case_beq_nat v x.
    rewrite BindingSetProperties.add_get_1.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    (* Fix *)
    destruct n.
    case_beq_nat v0 x.
    rewrite VarSetProperties.remove_mem_2.
    apply fv_ll_rho_O ; trivial.
    case_beq_nat x v.
    rewrite BindingSetProperties.add_get_1.
    apply StageSetProperties.add_mem_3.
    rewrite BindingSetProperties.add_get_2 ; trivial.
    rewrite BindingSetProperties.add_get_1.
    apply StageSetProperties.add_mem_3 ; auto ~.

    rewrite StageSetProperties.remove_mem_1 ; trivial.
    case_beq_nat v x.
    rewrite VarSetProperties.remove_mem_2.
    apply fv_ll_rho_O ; trivial.
    rewrite BindingSetProperties.add_get_1.
     apply StageSetProperties.add_mem_3.
    rewrite StageSetProperties.remove_mem_1 ; trivial.
    rewrite IHe ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    rewrite BindingSetProperties.add_get_2 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    rewrite IHe ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    rewrite BindingSetProperties.ub_le_1 ; trivial.
    case_beq_nat v x.
    rewrite BindingSetProperties.add_get_1.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    case_beq_nat v0 x.
    rewrite BindingSetProperties.add_get_1.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.
    case_beq_nat v0 x.
    rewrite BindingSetProperties.add_get_1.
    rewrite StageSetProperties.add_mem_4 ; auto ~.
    rewrite BindingSetProperties.add_get_2 ; auto ~.

    (* Box *)
    apply IHe ; trivial.
    apply BindingSetProperties.ub_le_2 with (m:=n) ; auto ~.
    omega.

    (* Unbox *)
    apply IHe ; trivial.
    destruct n ; simpl.
    inversion H1.
    rewrite BindingSetProperties.ub_S ; assumption.
    rewrite BindingSetProperties.remove_get.
    apply StageSetProperties.remove_mem_3 ; assumption.
    omega.
  Qed.

  Lemma fv_ll_fv_O:
    forall (e:expr) (n:nat),
    depth e = 0 ->
    fv 0 BindingSet.empty e = ll_fv 0 e.
  Proof.
    intros.
    apply StageSetProperties.equal_mem_1 ; intros.
    apply fv_ll_fv ; auto ~.
    destruct m ; simpl ; reflexivity.
    omega.
  Qed.

  (** ** Explicit Lisp-Like Bounded Variables Function *)
  Fixpoint ll_bv (n:nat) (e:expr) : VarSet.t :=
    match e with
    | EConst _ => VarSet.empty
    | EVar x => VarSet.empty
    | EAbs x e => match n with
        | 0 => VarSet.add x (ll_bv n e)
        | S _ => ll_bv n e
        end
    | EFix f x e => match n with
        | 0 => VarSet.add f (VarSet.add x (ll_bv n e))
        | S _ => ll_bv n e
        end
    | EApp e1 e2 => VarSet.union (ll_bv n e1) (ll_bv n e2)
    | ELoc _ => VarSet.empty
    | ERef e => ll_bv n e
    | EDeref e => ll_bv n e
    | EAssign e1 e2 => VarSet.union (ll_bv n e1) (ll_bv n e2)
    | EBox e => ll_bv (S n) e
    | EUnbox e => ll_bv (pred n) e
    | ERun e => ll_bv n e
    | ELift e => ll_bv n e
    end.

  Lemma bv_ll_bv:
    forall (e:expr) (n:nat),
    depth e <= n ->
    bv n e = ll_bv n e.
  Proof.
    induction e ; simpl ; intros ;
    (* Const, Var, Loc *)
    try(reflexivity) ;
    (* App, Assign *)
    try(rewrite IHe1, IHe2 ; auto ~ ;
    [apply max_lub_r in H | apply max_lub_l in H ];
    trivial ; fail) ;
    (* Ref, Deref, Run, Lift *)
    try(apply IHe ; auto ~ ; fail).

    (* Abs *)
    destruct n ; simpl ;
    unfold BindingSet.bindSet, rho.
    rewrite <- beq_nat_refl.
    rewrite StageSetProperties.singleton_union_1.
    rewrite IHe ; auto ~.
    assert(beq_nat (S n) 0 = false).
    apply beq_nat_false_iff ; auto ~.
    rewrite H0.
    rewrite VarSetProperties.empty_union_1.
    apply IHe ; auto ~.

    (* Fix *)
    destruct n ; simpl ;
    unfold BindingSet.bindSet, rho.
    rewrite <- beq_nat_refl.
    repeat(rewrite StageSetProperties.singleton_union_1).
    rewrite IHe ; auto ~.
    assert(beq_nat (S n) 0 = false).
    apply beq_nat_false_iff ; auto ~.
    rewrite H0.
    repeat(rewrite VarSetProperties.empty_union_1).
    apply IHe ; auto ~.

    (* Box *)
    apply IHe ; auto ~.
    omega.

    (* Unbox *)
    destruct n ; simpl.
    inversion H.
    apply le_S_n in H.
    apply IHe ; assumption.
  Qed.

  Lemma bv_ll_bv_O:
    forall (e:expr) (n:nat),
    depth e = 0 ->
    bv 0 e = ll_bv 0 e.
  Proof.
    intros ; apply bv_ll_bv ;
    auto ~ ; omega.
  Qed.

End LispLikeCalculusProperties.


From mathcomp Require Import all_ssreflect.
Require Import Util LambdaLet.
Require Heaps.

Inductive heap :=
  | Empty
  | Cons of heap & term & heap
  | Mut of seq term & heap.

Definition clos := (heap * term)%type.

Fixpoint hget h n : option clos :=
  match h with
  | Empty => None
  | Cons h t h' => (if n is n.+1 then hget h' n else Some (h, t))
  | Mut ts h => nth (hget h (n - size ts)) (map (@Some _ \o pair (Mut ts h)) ts) n
  end.

Inductive eval_name : heap -> term -> clos -> Prop :=
  | eval_name_var H H' t x v :
      hget H x = Some (H', t) ->
      eval_name H' t v ->
      eval_name H (Var x) v
  | eval_name_app H H' t0 t1 t2 v :
      eval_name H t1 (H', Abs t0) ->
      eval_name (Cons H t2 H') t0 v ->
      eval_name H (App t1 t2) v
  | eval_name_abs H t0 :
      eval_name H (Abs t0) (H, Abs t0)
  | eval_name_let H ts t v :
      eval_name (Mut ts H) t v ->
      eval_name H (Let ts t) v.

CoInductive diverge_name : heap -> term -> Prop :=
  | diverge_name_var H H' t x :
      hget H x = Some (H', t) ->
      diverge_name H' t ->
      diverge_name H (Var x)
  | diverge_name_appL H t1 t2 :
      diverge_name H t1 ->
      diverge_name H (App t1 t2)
  | diverge_name_appabs H H' t0 t1 t2 :
      eval_name H t1 (H', Abs t0) ->
      diverge_name (Cons H t2 H') t0 ->
      diverge_name H (App t1 t2)
  | diverge_name_let H ts t :
      diverge_name (Mut ts H) t ->
      diverge_name H (Let ts t).

Inductive corr_term (R : nat -> nat -> Prop) : nat -> term -> term -> Prop :=
  | corr_term_loc n l x :
      n <= x ->
      R l (x - n) ->
      corr_term R n (Loc l) (Var x)
  | corr_term_var n x :
      x < n ->
      corr_term R n (Var x) (Var x)
  | corr_term_abs n t t' :
      corr_term R n.+1 t t' ->
      corr_term R n (Abs t) (Abs t')
  | corr_term_app n t1 t1' t2 t2' :
      corr_term R n t1 t1' ->
      corr_term R n t2 t2' ->
      corr_term R n (App t1 t2) (App t1' t2')
  | corr_term_let n ts ts' t t' :
      size ts = size ts' ->
      ( forall x, x < size ts -> forall d,
        corr_term R (size ts + n)
          (nth d ts x) (nth d ts' x) ) ->
      corr_term R (size ts + n) t t' ->
      corr_term R n (Let ts t) (Let ts' t').

CoInductive corr_heap H1 : (nat -> nat -> Prop) -> heap -> Prop :=
  | corr_heap_fold (R : nat -> nat -> Prop) H2 :
      ( forall l x, R l x ->
        exists t1, nth None H1 l = Some t1 /\
        exists H2' t2, hget H2 x = Some (H2', t2) /\
        exists R', corr_heap H1 R' H2' /\ corr_term R' 0 t1 t2 ) ->
      corr_heap H1 R H2.

Lemma corr_heap_unfold R H1 H2 :
  corr_heap H1 R H2 ->
  ( forall l x, R l x ->
    exists t1, nth None H1 l = Some t1 /\
    exists H2' t2, hget H2 x = Some (H2', t2) /\
    exists R', corr_heap H1 R' H2' /\ corr_term R' 0 t1 t2 ).
Proof. by inversion 1. Qed.

Hint Constructors eval_name diverge_name corr_term corr_heap.

Lemma corr_term_impl R n t t' :
  corr_term R n t t' ->
  forall (R' : nat -> nat -> Prop),
  (forall l x, R l x -> R' l x) ->
  corr_term R' n t t'.
Proof. induction 1 => ? Himpl; eauto. Qed.

Lemma corr_term_subst :
  forall R n t t', corr_term R n t t' ->
  forall (R' : nat -> nat -> Prop) s m,
  m <= n ->
  (forall x, x < m -> s x = Var x) ->
  (forall x, m <= x -> x < n -> exists l, s x = Loc l) ->
  (forall l x, n <= x -> R l (x - n) -> R' l (x - m)) ->
  (forall l x, s x = Loc l -> R' l (x - m)) ->
  corr_term R' m (subst s t) t'.
Proof.
  have Hs_impl : forall n s m,
    (forall x, x < m -> s x = Var x) ->
    (forall x : nat, x < n + m -> upn s n x = Var x).
  { move => n ? ? Hs x ?.
    rewrite (eq_upn _ Var) => [ | ? ].
    - exact: upn_Var.
    - apply: Hs.
      by rewrite -(ltn_add2l n) subnKC. }
  have Hs'_impl: forall ts s m n,
    (forall x, m <= x -> x < n -> exists l, s x = Loc l) ->
    (forall x, ts + m <= x -> x < ts + n -> exists l, upn s ts x = Loc l).
  { move => ts ? m ? Hs' x ? ?.
    rewrite upn_unfold.
    have Hleq := leq_trans (leq_addr m _).
    rewrite ltnNge Hleq => //=.
    case (Hs' (x - ts)) => [ | | ? -> /= ];
    [ rewrite -(leq_add2l ts) subnKC
    | rewrite -(ltn_add2l ts) subnKC | ]; eauto. }
  have HR_impl: forall ts (R R' : nat -> _) m n,
    (forall l x, n <= x -> R l (x - n) -> R' l (x - m)) ->
    (forall l x, ts + n <= x -> R l (x - (ts + n)) -> R' l (x - (ts + m))).
  { move => ts ? ? ? n HR ? ? ?.
    rewrite !subnDA. apply: HR.
    rewrite -(leq_add2l ts) subnKC => //.
    exact: (leq_trans (leq_addr n _)). }
  have Hloc_impl : forall ts (R' : nat -> _) s m,
    (forall l x, s x = Loc l -> R' l (x - m)) ->
    (forall l x, upn s ts x = Loc l -> R' l (x - (ts + m))).
  { move => ts ? s m Hloc ? x.
    rewrite upn_unfold.
    move: (leqP ts x) subnDA (Hloc^~ (x - ts)) => [ ? -> | // ].
    case: (s (x - ts)); inversion 2; subst; eauto. }
  induction 1 => ? ? m Hleq Hs Hs' ? ? /=; eauto using leq_trans.
  - case (leqP m x) => Hlt.
    + case: (Hs' _ Hlt H) => ? Heq.
      rewrite Heq. eauto.
    + rewrite Hs; eauto.
  - constructor.
    apply: IHcorr_term.
    + exact Hleq.
    + exact: (Hs_impl 1).
    + exact: (Hs'_impl 1).
    + exact: (HR_impl 1).
    + exact: (Hloc_impl 1).
  - ( constructor; rewrite size_map ) => // [ x ? d | ];
    [ rewrite (nth_map d) => //; apply: H1 => // | apply: IHcorr_term ];
    solve [ by rewrite leq_add2l | exact: Hs_impl | exact: Hs'_impl | exact: HR_impl | exact: Hloc_impl ].
Qed.

Lemma corr_heap_dom R H1 H2 :
  corr_heap H1 R H2 ->
  forall (R' : nat -> nat -> Prop),
  (forall l x, R' l x -> R l x) ->
  corr_heap H1 R' H2.
Proof.
  inversion 1 => ? Hdom. subst.
  constructor => ? ? /Hdom. eauto.
Qed.

Lemma corr_heap_ext H1 H1'
  (Hext : forall l t, nth None H1 l = Some t -> nth None H1' l = Some t) :
  forall R H2,
  corr_heap H1 R H2 ->
  corr_heap H1' R H2.
Proof.
  cofix corr_heap_ext.
  inversion 1. subst.
  constructor => ? ? /H3 [ ? [ /Hext -> [ ? [ ? [ -> [ ? [ ? ? ] ] ] ] ] ] ].
  repeat (eexists; eauto).
Qed.

Corollary corr_heap_cat R H1 H2 Hd :
  corr_heap H1 R H2 ->
  corr_heap (H1 ++ Hd) R H2.
Proof.
  move => /corr_heap_ext.
  apply => l ?.
  by move: nth_cat (leqP (size H1) l) => -> [ /(nth_default _) -> | ].
Qed.

Corollary corr_heap_rcons R H1 H2 o :
  corr_heap H1 R H2 ->
  corr_heap (rcons H1 o) R H2.
Proof. by rewrite -cats1 => /corr_heap_cat. Qed.

Lemma corr_heap_union R R' H1 H2 :
  corr_heap H1 R H2 ->
  corr_heap H1 R' H2 ->
  corr_heap H1 (fun l x => R l x \/ R' l x) H2.
Proof.
  inversion 1. subst.
  inversion 1. subst.
  constructor => ? ? [ /H3 | /H5 ]; eauto.
Qed.

Lemma corr_heap_cons R H1 H2 H t :
  corr_heap H1 R H2 ->
  corr_heap H1 (fun l x => 0 < x /\ R l x.-1) (Cons H t H2).
Proof.
  inversion 1. subst.
  constructor => ? [ | ? ] [ ] //= ?.
  exact: H4.
Qed.

Lemma corr_heap_mut R H1 H2 cs :
  corr_heap H1 R H2 ->
  corr_heap H1 (fun l x => size cs <= x /\ R l (x - size cs)) (Mut cs H2).
Proof.
  inversion 1. subst.
  constructor => ? ? [ ? ] /= /H3 [ ? [ -> [ ? [ ? [ -> [ ? [ ? ? ] ] ] ] ] ] ].
  rewrite nth_default ?size_map => //.
  repeat (eexists; eauto).
Qed.

Theorem eval_name_sound H1 H1' t1 v1 :
  Heaps.eval_name H1 t1 H1' v1 ->
  forall R H2 t2,
  corr_heap H1 R H2 ->
  corr_term R 0 t1 t2 ->
  exists R' H2' v2,
  eval_name H2 t2 (H2', v2) /\
  corr_heap H1' R' H2' /\
  corr_term R' 0 v1 v2.
Proof.
  induction 1; inversion 1; inversion 1; subst.
  - move: subn0 H12 => -> /H5 [ ? [ ] ].
    rewrite H0. inversion 1.
    subst => [ [ ? [ ? [ ? [ ? [ Hheap Hterm ] ] ] ] ] ].
    move: (IHeval_name _ _ _ Hheap Hterm) =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
  - move: (IHeval_name1 _ _ _ H3 H12) =>
      [ R' [ H2' [ ? [ ? [ ] ] ] ] ].
    inversion 2. subst.
    have Hterm' : corr_term
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H' /\ x = 0) 0
      (subst (scons (Loc (size H')) Var) t0) t'.
    { (apply: corr_term_subst; eauto) => [ | | ? | ? ];
      move => [ | ? ] //=; eauto.
      - rewrite subn1 subn0. eauto.
      - inversion 1. eauto. }
    have Hheap' : corr_heap (rcons H' (Some t2))
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H' /\ x = 0)
      (Cons H2 t2' H2').
    { apply: corr_heap_union.
      - apply: corr_heap_cons.
        exact: corr_heap_rcons.
      - constructor => ? ? [ -> -> ] /=.
        rewrite nth_rcons ltnn eqxx.
        do 7 eexists; eauto.
        apply: corr_heap_rcons.
        refine (corr_heap_ext _ _ (Heaps.eval_name_heap _ _ _ _ _) _ _ _); eauto. }
    move: (IHeval_name2 _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
  - repeat (eexists; eauto).
  - have Hterm' : corr_term (fun l x =>
      size ts <= x /\ R l (x - size ts) \/
      x < size ts /\ l = size H + x) 0
      (subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var) t) t'.
    { (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? x ];
      rewrite ?nth_scat ?addn0 ?subn0; eauto.
      - move => /(nth_mkseq _) => -> /=. eauto.
      - case (leqP (size ts) x) => ?.
        + by rewrite nth_default ?size_mkseq.
        + rewrite nth_mkseq => //=.
          inversion 1. eauto. }
    have Hheap' : corr_heap
      (H ++ map (@Some _ \o
        subst (scat (mkseq (Loc \o addn (size H)) (size ts)) Var)) ts)
      (fun l x =>
        size ts <= x /\ R l (x - size ts) \/
        x < size ts /\ l = size H + x)
      (Mut ts' H2).
    { cofix Hheap'.
      constructor => ? x [ [ ? ? ] | [ ? -> ] /= ].
      - apply: corr_heap_unfold.
        + apply: corr_heap_mut.
          apply: corr_heap_cat. eauto.
        + move: H10 => /= <-. eauto.
      - rewrite nth_cat ltnNge leq_addr addKn !(nth_map (Var 0)) => /=; try congruence.
        do 7 eexists => /=; eauto.
        (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? y ];
        rewrite ?nth_scat ?addn0 ?subn0; eauto.
        - move => /(nth_mkseq _) => -> /=. eauto.
        - case (leqP (size ts) y) => ?.
          * by rewrite nth_default ?size_mkseq.
          * rewrite nth_mkseq => //=.
            inversion 1. eauto. }
    move: (IHeval_name _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
Qed.

Theorem diverge_name_sound :
  forall H1 t1,
  Heaps.diverge_name H1 t1 ->
  forall R H2 t2,
  corr_heap H1 R H2 ->
  corr_term R 0 t1 t2 ->
  diverge_name H2 t2.
Proof.
  cofix diverge_name_sound.
  inversion 1; inversion 1; subst; inversion 1; subst.
  - move: subn0 H10 => -> /H9 [ ? [ ] ].
    rewrite H2. inversion 1. subst => [ [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ] ].
    apply: diverge_name_var; eauto.
  - apply: diverge_name_appL. eauto.
  - move: (eval_name_sound _ _ _ _ H2 _ _ _ H7 H10) =>
      [ R' [ H2' [ ? [ ? [ ] ] ] ] ].
    inversion 2. subst.
    have Hterm' : corr_term
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H' /\ x = 0) 0
      (subst (scons (Loc (size H')) Var) t0) t'.
    { (apply: corr_term_subst; eauto) => [ | | ? | ? ];
      move => [ | ? ] //=; eauto.
      - rewrite subn1 subn0. eauto.
      - inversion 1. eauto. }
    have Hheap' : corr_heap (rcons H' (Some t3))
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H' /\ x = 0)
      (Cons H6 t2' H2').
    { apply: corr_heap_union.
      - apply: corr_heap_cons.
        exact: corr_heap_rcons.
      - constructor => ? ? [ -> -> ] /=.
        rewrite nth_rcons ltnn eqxx.
        do 7 eexists; eauto.
        apply: corr_heap_rcons.
        refine (corr_heap_ext _ _ (Heaps.eval_name_heap _ _ _ _ _) _ _ _); eauto. }
    apply: diverge_name_appabs; eauto.
  - have Hterm' : corr_term (fun l x =>
      size ts <= x /\ R l (x - size ts) \/
      x < size ts /\ l = size H1 + x) 0
      (subst (scat (mkseq (Loc \o addn (size H1)) (size ts)) Var) t) t'.
    { (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? x ];
      rewrite ?nth_scat ?addn0 ?subn0; eauto.
      - move => /(nth_mkseq _) => -> /=. eauto.
      - case (leqP (size ts) x) => ?.
        + by rewrite nth_default ?size_mkseq.
        + rewrite nth_mkseq => //=.
          inversion 1. eauto. }
    have Hheap' : corr_heap
      (H1 ++ map (@Some _ \o
        subst (scat (mkseq (Loc \o addn (size H1)) (size ts)) Var)) ts)
      (fun l x =>
        size ts <= x /\ R l (x - size ts) \/
        x < size ts /\ l = size H1 + x)
      (Mut ts' H5).
    { cofix Hheap'.
      constructor => ? x [ [ ? ? ] | [ ? -> ] /= ].
      - apply: corr_heap_unfold.
        + apply: corr_heap_mut.
          apply: corr_heap_cat. eauto.
        + move: H7 => /= <-. eauto.
      - rewrite nth_cat ltnNge leq_addr addKn !(nth_map (Var 0)) => /=; try congruence.
        do 7 eexists => /=; eauto.
        (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? y ];
        rewrite ?nth_scat ?addn0 ?subn0; eauto.
        + move => /(nth_mkseq _) => -> /=. eauto.
        + case (leqP (size ts) y) => ?.
          * by rewrite nth_default ?size_mkseq.
          * rewrite nth_mkseq => //=.
            inversion 1. eauto. }
    apply: diverge_name_let. eauto.
Qed.

Theorem eval_name_complete H2 t2 c :
  eval_name H2 t2 c ->
  forall R H1 t1,
  corr_heap H1 R H2 ->
  corr_term R 0 t1 t2 ->
  exists R' H1' v1,
  Heaps.eval_name H1 t1 H1' v1 /\
  corr_heap H1' R' c.1 /\
  corr_term R' 0 v1 c.2.
Proof.
  induction 1; inversion 1; inversion 1; subst.
  - move: subn0 H13 => -> /H5 [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    rewrite H0. inversion 1.
    subst => [ [ ? [ Hheap Hterm ] ] ].
    move: (IHeval_name _ _ _ Hheap Hterm) =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
  - inversion H12.
  - move: (IHeval_name1 _ _ _ H3 H13) =>
      [ R' [ H2' [ ? [ ? [ ] ] ] ] ].
    inversion 2. subst.
    have Hterm' : corr_term
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H2' /\ x = 0) 0
      (subst (scons (Loc (size H2')) Var) t) t0.
    { (apply: corr_term_subst; eauto) => [ | | ? | ? ];
      move => [ | ? ] //=; eauto.
      - rewrite subn1 subn0. eauto.
      - inversion 1. eauto. }
    have Hheap' : corr_heap (rcons H2' (Some t5))
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H2' /\ x = 0)
      (Cons H t2 H').
    { apply: corr_heap_union.
      - apply: corr_heap_cons.
        exact: corr_heap_rcons.
      - constructor => ? ? [ -> -> ] /=.
        rewrite nth_rcons ltnn eqxx.
        do 7 eexists; eauto.
        apply: corr_heap_rcons.
        refine (corr_heap_ext _ _ (Heaps.eval_name_heap _ _ _ _ _) _ _ _); eauto. }
    move: (IHeval_name2 _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
  - repeat (eexists; eauto).
  - have Hterm' : corr_term (fun l x =>
      size ts0 <= x /\ R l (x - size ts0) \/
      x < size ts0 /\ l = size H1 + x) 0
      (subst (scat (mkseq (Loc \o addn (size H1)) (size ts0)) Var) t0) t.
    { (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? x ];
      rewrite ?nth_scat ?addn0 ?subn0; eauto.
      - move => /(nth_mkseq _) => -> /=. eauto.
      - case (leqP (size ts0) x) => ?.
        + by rewrite nth_default ?size_mkseq.
        + rewrite nth_mkseq => //=.
          inversion 1. eauto. }
    have Hheap' : corr_heap
      (H1 ++ map (@Some _ \o
        subst (scat (mkseq (Loc \o addn (size H1)) (size ts0)) Var)) ts0)
      (fun l x =>
        size ts0 <= x /\ R l (x - size ts0) \/
        x < size ts0 /\ l = size H1 + x)
      (Mut ts H).
    { cofix Hheap'.
      constructor => ? x [ [ ? ? ] | [ ? -> ] /= ].
      - apply: corr_heap_unfold.
        + apply: corr_heap_mut.
          apply: corr_heap_cat. eauto.
        + move: H10 => /= <-. eauto.
      - rewrite nth_cat ltnNge leq_addr addKn !(nth_map (Var 0)) => /=; try congruence.
        do 7 eexists => /=; eauto.
        (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? y ];
        rewrite ?nth_scat ?addn0 ?subn0; eauto.
        + move => /(nth_mkseq _) => -> /=. eauto.
        + case (leqP (size ts0) y) => ?.
          * by rewrite nth_default ?size_mkseq.
          * rewrite nth_mkseq => //=.
            inversion 1. eauto. }
    move: (IHeval_name _ _ _ Hheap' Hterm') =>
      [ ? [ ? [ ? [ ? [ ? ? ] ] ] ] ].
    repeat (eexists; eauto).
Qed.

Theorem diverge_name_complete :
  forall H2 t2,
  diverge_name H2 t2 ->
  forall R H1 t1,
  corr_heap H1 R H2 ->
  corr_term R 0 t1 t2 ->
  Heaps.diverge_name H1 t1.
Proof.
  cofix diverge_name_complete.
  inversion 1; inversion 1; subst; inversion 1; subst.
  - move: subn0 H11 => -> /H9 [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    rewrite H1. inversion 1. subst => [ [ ? [ ? ? ] ] ].
    apply: Heaps.diverge_name_loc; eauto.
  - inversion H10.
  - apply: Heaps.diverge_name_appL; eauto.
  - move: (eval_name_complete _ _ _ H1 _ _ _ H7 H11) =>
      [ R' [ H2' [ ? [ ? [ ] ] ] ] ].
    inversion 2. subst.
    have Hterm' : corr_term
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H2' /\ x = 0) 0
      (subst (scons (Loc (size H2')) Var) t) t0.
    { (apply: corr_term_subst; eauto) => [ | | ? | ? ];
      move => [ | ? ] //=; eauto.
      - rewrite subn1 subn0. eauto.
      - inversion 1. eauto. }
    have Hheap' : corr_heap (rcons H2' (Some t5))
      (fun l x => 0 < x /\ R' l x.-1 \/ l = size H2' /\ x = 0)
      (Cons H2 t3 H').
    { apply: corr_heap_union.
      - apply: corr_heap_cons.
        exact: corr_heap_rcons.
      - constructor => ? ? [ -> -> ] /=.
        rewrite nth_rcons ltnn eqxx.
        do 7 eexists; eauto.
        apply: corr_heap_rcons.
        refine (corr_heap_ext _ _ (Heaps.eval_name_heap _ _ _ _ _) _ _ _); eauto. }
    apply: Heaps.diverge_name_appabs; eauto.
  - have Hterm' : corr_term (fun l x =>
      size ts0 <= x /\ R l (x - size ts0) \/
      x < size ts0 /\ l = size H5 + x) 0
      (subst (scat (mkseq (Loc \o addn (size H5)) (size ts0)) Var) t0) t.
    { (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? x ];
      rewrite ?nth_scat ?addn0 ?subn0; eauto.
      - move => /(nth_mkseq _) => -> /=. eauto.
      - case (leqP (size ts0) x) => ?.
        + by rewrite nth_default ?size_mkseq.
        + rewrite nth_mkseq => //=.
          inversion 1. eauto. }
    have Hheap' : corr_heap
      (H5 ++ map (@Some _ \o
        subst (scat (mkseq (Loc \o addn (size H5)) (size ts0)) Var)) ts0)
      (fun l x =>
        size ts0 <= x /\ R l (x - size ts0) \/
        x < size ts0 /\ l = size H5 + x)
      (Mut ts H2).
    { cofix Hheap'.
      constructor => ? x [ [ ? ? ] | [ ? -> ] /= ].
      - apply: corr_heap_unfold.
        + apply: corr_heap_mut.
          apply: corr_heap_cat. eauto.
        + move: H7 => /= <-. eauto.
      - rewrite nth_cat ltnNge leq_addr addKn !(nth_map (Var 0)) => /=; try congruence.
        do 7 eexists => /=; eauto.
        (apply: corr_term_subst; eauto) => [ // | ? ? | ? ? | ? y ];
        rewrite ?nth_scat ?addn0 ?subn0; eauto.
        + move => /(nth_mkseq _) => -> /=. eauto.
        + case (leqP (size ts0) y) => ?.
          * by rewrite nth_default ?size_mkseq.
          * rewrite nth_mkseq => //=.
            inversion 1. eauto. }
    apply: Heaps.diverge_name_let. eauto.
Qed.