(***************************************************************************
* Safety for Lambda Mu Mutilde (CBV) - Infrastructure                      *
* Étienne Miquey, June 2015                                                *
***************************************************************************)

(* Penser à renommer bien ! *)

Set Implicit Arguments.
Require Import LibLN.
Require Import L_Core_Definitions.

(*********************************************************************** *)
(** ** Additional Definitions used in the Proofs *)

Fixpoint size_prf (p:prf) {struct p} : nat :=
  match p with
    | prf_bvar i    => 1
    | prf_fvar a    => 1
    | prf_abs p1    => 1+(size_prf p1)
    | prf_mu c => 1+(size_clos c)
  end
with size_cont (e : cont) {struct e} : nat :=
  match e with
    | co_bvar i    => 1
    | co_fvar a    => 1
    | co_stack p f    => (size_prf p) + (size_cont f)
    | co_mut c => 1+(size_clos c)
  end
with size_clos (c:clos) {struct c} : nat :=
  match c with
    | cl p e =>  (size_prf p) + (size_cont e)
  end.

Inductive size_prf_prop : prf -> nat -> Prop :=
| size_prf_bvar : forall n, size_prf_prop (prf_bvar n) 1
| size_prf_fvar : forall a, size_prf_prop (prf_fvar a) 1
| size_abs : forall p n,  size_prf_prop p n -> size_prf_prop (prf_abs p) (S n)
| size_mu : forall c n, size_clos_prop c n -> size_prf_prop (prf_mu c) (S n)
with size_cont_prop : cont -> nat -> Prop :=
     | size_co_bvar : forall n, size_cont_prop (co_bvar n) 1
     | size_co_fvar : forall a, size_cont_prop (co_fvar a) 1
     | size_mut : forall c n, size_clos_prop c n -> size_cont_prop (co_mut c) (S n)
     | size_stack : forall q e n m, size_prf_prop q n -> size_cont_prop e m -> size_cont_prop (co_stack q e ) (n+m)
with size_clos_prop : clos -> nat ->Prop :=
  | size_closure : forall p e n m, size_prf_prop p n -> size_cont_prop e m -> size_clos_prop (cl p e ) (n+m).

Fixpoint size_prf_ok p {struct p}: size_prf_prop p (size_prf p)
with size_cont_ok e {struct e}: size_cont_prop e (size_cont e)
with size_clos_ok c {struct c}: size_clos_prop c (size_clos c).
Proof.
  - induction p; simpl in *.
    + apply size_prf_bvar.
    + apply size_prf_fvar.
    + apply* size_abs.
    + apply* size_mu.
  - induction e.
    + apply size_co_bvar.
    + apply size_co_fvar.
    + apply* size_stack.
    + apply* size_mut.
  - induction c.
    apply* size_closure.
Qed.

Lemma size_prf_ge_1: forall p, 1 <= size_prf p.
Proof.
  intro p.
  destruct p;simpl;intuition.
Qed.

Lemma size_cont_ge_1: forall e, 1 <= size_cont e.
Proof.
  intro e.
  destruct e;simpl;intuition.
  assert (ok:=size_prf_ge_1 p).
  intuition.
Qed.

Lemma size_clos_le_1: forall c, 2 <= size_clos c.
Proof.
  intro c.
  destruct c as (p,e);simpl.
  assert (ok:=size_prf_ge_1 p).
  assert (ok':=size_cont_ge_1 e).
  intuition.
Qed.

(* Scheme size_prf_ind := Induction for size_prf_prop Sort Prop
  with size_cont_ind := Induction for size_cont_prop Sort Prop
  with size_clos_ind := Induction for size_clos_prop Sort Prop.
Combined Scheme size_ind from size_prf_ind, size_cont_ind, size_clos_ind.
Print size_ind.
*)
Lemma induction_size :
  forall (Pp:prf-> Prop) (Pe:cont-> Prop) (Pc:clos -> Prop),
    (forall (n:nat), (forall p, size_prf p<=n -> Pp p)
                     -> (forall e, size_cont e<=n -> Pe e)
                     -> (forall c, size_clos c<=n -> Pc c)
                     -> (forall p, size_prf p = S n -> Pp p)
                        /\ (forall e, size_cont e = S n -> Pe e)
                        /\ (forall c, size_clos c = S n -> Pc c))
    -> forall n,(forall p, size_prf p<=n-> Pp p) /\ (forall e, size_cont e<=n -> Pe e)
                /\ (forall c, size_clos c<=n ->Pc c).
Proof.
  intros.
  assert (forall p : prf, size_prf p <= 0 -> Pp p) as Hp0.
  intros p H0.
  destruct p; simpl in H0;intuition.
  assert (forall e : cont, size_cont e <= 0 -> Pe e) as He0.
  intros e H0.
  destruct e; simpl in H0;intuition.
  destruct p; simpl in H0;intuition.
  assert (forall c : clos, size_clos c <= 0 -> Pc c) as Hc0.
  intros c H0.
  destruct c;destruct p; simpl in H0;intuition.
  induction n.
  - split.
  + intros p Hp.
    apply Hp0; intuition.
  + split.
    * intros e He.
      now apply He0.
    * intros c Hc.
      now apply Hc0.
  - repeat split.
    + intros p Hp.
      destruct (Compare_dec.le_lt_eq_dec _ _ Hp).
      * apply Lt.lt_n_Sm_le in l.
      destruct IHn as (IHp, _).
      apply (IHp p l).
      * destruct IHn as (IHp,(IHe,IHc)).
        destruct* (H n IHp IHe IHc) as (Ok,_).
    + intros e He.
      destruct (Compare_dec.le_lt_eq_dec _ _ He).
      * apply Lt.lt_n_Sm_le in l.
      destruct* IHn as (_,(IHe, _)).
      * destruct IHn as (IHp,(IHe,IHc)).
        destruct* (H n IHp IHe IHc) as (_,(Ok,_)).
    + intros c Hc.
      destruct (Compare_dec.le_lt_eq_dec _ _ Hc).
      * apply Lt.lt_n_Sm_le in l.
      destruct* IHn as (_,(_, IHc)).
      * destruct IHn as (IHp,(IHe,IHc)).
        destruct* (H n IHp IHe IHc) as (_,(_,Ok)).
Qed.

Lemma generalize_size_ind:
  forall (Pp:prf-> Prop) (Pe:cont-> Prop) (Pc:clos -> Prop),
  (forall n,(forall p, size_prf p<=n-> Pp p) /\ (forall e, size_cont e<=n -> Pe e)
           /\ (forall c, size_clos c<=n ->Pc c))
           -> (forall p, Pp p) /\ (forall e, Pe e)/\ (forall c, Pc c).
Proof.
  intros.
  repeat split;intros.
  - destruct (H (size_prf p)) as (Hp,_).
    apply* Hp.
  - destruct (H (size_cont e)) as (_,(He,_)).
    apply* He.
  - destruct (H (size_clos c)) as (_,(_,Hc)).
    apply* Hc.
Qed.

Lemma size_ind :
  forall (Pp:prf-> Prop) (Pe:cont-> Prop) (Pc:clos -> Prop),
    (forall (n:nat), (forall p, size_prf p<=n -> Pp p)
                     -> (forall e, size_cont e<=n -> Pe e)
                     -> (forall c, size_clos c<=n -> Pc c)
                     -> (forall p, size_prf p = S n -> Pp p)
                        /\ (forall e, size_cont e = S n -> Pe e)
                        /\ (forall c, size_clos c = S n -> Pc c))
    -> (forall p, Pp p) /\ (forall e, Pe e)/\ (forall c, Pc c).
Proof.
intros.
apply generalize_size_ind.
apply* induction_size.
Qed.
    (* raffinable avec size_*_ok pour faire disparaître la taille de la conclusion ? *)

(** Computing free variables of a term. *)

Fixpoint fv_prf (p : prf) {struct p} : vars :=
  match p with
  | prf_bvar i    => \{}
  | prf_fvar a    => \{a}
  | prf_abs p1    => (fv_prf p1)
  | prf_mu c => (fv_clos c)
  end
with fv_cont (e : cont) {struct e} : vars :=
  match e with
  | co_bvar i    => \{}
  | co_fvar a    => \{a}
  | co_stack p f    => (fv_prf p) \u (fv_cont f)
  | co_mut c => (fv_clos c)
  end
with fv_clos (c:clos) {struct c} : vars :=
       match c with
         | cl p e =>  (fv_prf p) \u (fv_cont e)
       end.

(** Substitution for names *)

(* substitute z in p by q *)

Fixpoint subst_prf_prf (z : var) (p: prf) (q : prf) {struct p} : prf :=
  match p with
  | prf_bvar i    => prf_bvar i
  | prf_fvar x    => If x = z then q else (prf_fvar x)
  | prf_abs p1    => prf_abs (subst_prf_prf z p1 q)
  | prf_mu c => prf_mu (subst_clos_prf z c q)
end
with subst_cont_prf (z : var) (e:cont) (q:prf) {struct e}:cont :=
  match e with
    | co_bvar i => co_bvar i
    | co_fvar x => co_fvar x
    | co_stack p f => co_stack (subst_prf_prf z p q) (subst_cont_prf z f q)
    | co_mut c => co_mut (subst_clos_prf z c q)
  end
with subst_clos_prf (z:var) (c:clos) (q:prf) {struct c} : clos :=
       match c with
         | cl p e =>  cl (subst_prf_prf z p q)  (subst_cont_prf z e q)
       end.

Fixpoint subst_prf_cont (z : var) (p: prf) (f : cont) {struct p} : prf :=
  match p with
  | prf_bvar i    => prf_bvar i
  | prf_fvar x    => (prf_fvar x)
  | prf_abs p1    => prf_abs (subst_prf_cont z p1 f)
  | prf_mu c => prf_mu (subst_clos_cont z c f)
end
with subst_cont_cont (z : var) (e:cont) (f:cont) {struct e}:cont :=
  match e with
    | co_bvar i => co_bvar i
    | co_fvar x => If x=z then f else co_fvar x
    | co_stack p e1 => co_stack (subst_prf_cont z p f) (subst_cont_cont z e1 f)
    | co_mut c => co_mut (subst_clos_cont z c f)
  end
with subst_clos_cont (z:var) (c:clos) (f:cont) {struct c} : clos :=
       match c with
         | cl p e =>  cl (subst_prf_cont z p f)  (subst_cont_cont z e f)
       end.

(* UNIFORMISABLE AVEC TYPE CLASS ? *)

Notation "[ z ~+> q ]+ p" := (subst_prf_prf z p q) (at level 68).
Notation "[ z ~+> q ]- e" := (subst_cont_prf z e q) (at level 68).
Notation "[ z ~+> q ]* c" := (subst_clos_prf z c q) (at level 68).
Notation "[ z ~-> f ]+ p" := (subst_prf_cont z p f) (at level 68).
Notation "[ z ~-> f ]- e" := (subst_cont_cont z e f) (at level 68).
Notation "[ z ~-> f ]* c" := (subst_clos_cont z c f) (at level 68).
(** Definition of the body of an abstraction *)

Definition body_prf_prf p :=
  exists L, forall x, x \notin L -> proof (p +^+ x).
Definition body_prf_cont p :=
  exists L, forall x, x \notin L -> proof (p+^-x).
Definition body_cont_prf e :=
  exists L, forall x, x \notin L -> context (e -^+ x).
Definition body_cont_cont e :=
  exists L, forall x, x \notin L -> context (e -^- x).
Definition body_clos_prf e :=
  exists L, forall x, x \notin L -> closure (e *^+ x).
Definition body_clos_cont e :=
  exists L, forall x, x \notin L -> closure (e *^- x).

(* ********************************************************************** *)
(** ** Instanciation of tactics *)

(** Tactic [gather_vars] returns a set of variables occurring in
    the context of proofs, including domain of environments and
    free variables in terms mentionned in the context. *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars => x) in
  let B := gather_vars_with (fun x : var => \{x}) in
  let C := gather_vars_with (fun x : env => dom x) in
  let D := gather_vars_with (fun x : prf => fv_prf x) in
  let E := gather_vars_with (fun x : cont => fv_cont x) in
  let F := gather_vars_with (fun x : clos => fv_clos x) in
  constr:(A \u B \u C \u D \u E \u F).

(** Tactic [pick_fresh x] adds to the context a new variable x
    and a proof that it is fresh from all of the other variables
    gathered by tactic [gather_vars]. *)

Ltac pick_fresh Y :=
  let L := gather_vars in (pick_fresh_gen L Y).

(** Tactic [apply_fresh T as y] takes a lemma T of the form
    [forall L ..., (forall x, x \notin L, P x) -> ... -> Q.]
    instanciate L to be the set of variables occuring in the
    context (by [gather_vars]), then introduces for the premise
    with the cofinite quantification the name x as "y" (the second
    parameter of the tactic), and the proof that x is not in L. *)

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.
Tactic Notation "apply_fresh" "*" constr(T) "as" ident(x) :=
  apply_fresh T as x; auto_star.
Tactic Notation "apply_fresh" constr(T) :=
  apply_fresh_base T gather_vars ltac_no_arg.
Tactic Notation "apply_fresh" "*" constr(T) :=
  apply_fresh T; auto_star.

Hint Constructors proof context closure value red.

(* ********************************************************************** *)
(** ** Properties of substitution *)

(** Substitution on indices is identity on well-formed terms. *)

Fixpoint open_rec_prf_prf_id_core p j q i r {struct p}: i <> j ->
                    {j ~+> q}+ p = {i ~+> r}+ ({j ~+> q}+ p) -> p = {i ~+> r}+ p
with open_rec_cont_prf_id_core e j q i r {struct e}: i <> j ->
                    {j ~+> q}- e = {i ~+> r}- ({j ~+> q}- e) -> e = {i ~+> r}- e
with open_rec_clos_prf_id_core c j q i r {struct c}: i <> j ->
                    {j ~+> q}* c = {i ~+> r}* ({j ~+> q}* c) -> c = {i ~+> r}* c
.
Proof.
  - revert j q i r.
    induction p; simpls;introv Neq Equ; inversion Equ;try tauto.
    + case_nat.
      * rewrite If_r;trivial.
      * exact Equ.
    + rewrite (IHp (S j) q (S i) r) at 1;
      [reflexivity | intuition | assumption].
    + now rewrite (open_rec_clos_prf_id_core c j q i r) at 1.
  - revert j q i r.
    induction e; simpls;introv Neq Equ; inversion Equ;try tauto.
    + now rewrite (open_rec_prf_prf_id_core p j q i r), (open_rec_cont_prf_id_core e j q i r) at 1.
    + rewrite (open_rec_clos_prf_id_core c (S j) q (S i) r) at 1;
      [reflexivity | intuition | assumption].
  - destruct c as [p e];simpls;introv Neq Equ;inversion Equ.
    rewrite (open_rec_prf_prf_id_core p j q i r), (open_rec_cont_prf_id_core e j q i r) at 1;
      [reflexivity |intuition | assumption |intuition |assumption ].
Qed.

Fixpoint open_rec_prf_cont_id_core p j q i r {struct p}: i <> j ->
                    {j ~-> q}+ p = {i ~-> r}+ ({j ~-> q}+ p) -> p = {i ~-> r}+ p
with open_rec_cont_cont_id_core e j q i r {struct e}: i <> j ->
                    {j ~-> q}- e = {i ~-> r}- ({j ~-> q}- e) -> e = {i ~-> r}- e
with open_rec_clos_cont_id_core c j q i r {struct c}: i <> j ->
                    {j ~-> q}* c = {i ~-> r}* ({j ~-> q}* c) -> c = {i ~-> r}* c
.
Proof.
  - revert j q i r.
    induction p; simpls;introv Neq Equ; inversion Equ;try tauto.
    + fequals*.
    + fequals*.
  - revert j q i r.
    induction e; simpls;introv Neq Equ; inversion Equ;try tauto.
    + case_nat*. rewrite* If_r.
    + now rewrite (open_rec_prf_cont_id_core p j q i r), (open_rec_cont_cont_id_core e j q i r) at 1.
    + rewrite (open_rec_clos_cont_id_core c (j) q (i) r) at 1;
      [reflexivity | intuition | assumption].

  - destruct c as [p e];simpls;introv Neq Equ;inversion Equ.
    rewrite (open_rec_prf_cont_id_core p j q i r), (open_rec_cont_cont_id_core e j q i r) at 1;
      [reflexivity |intuition | assumption |intuition |assumption ].
Qed.

Fixpoint open_rec_prf_prf_id_core_1 p j q i r {struct p}:
                    {j ~-> q}+ p = {i ~+> r}+ ({j ~-> q}+ p) -> p = {i ~+> r}+ p
with open_rec_cont_prf_id_core_1 e j q i r {struct e}:
                    {j ~-> q}- e = {i ~+> r}- ({j ~-> q}- e) -> e = {i ~+> r}- e
with open_rec_clos_prf_id_core_1 c j q i r {struct c}:
                    {j ~-> q}* c = {i ~+> r}* ({j ~-> q}* c) -> c = {i ~+> r}* c
.
Proof.
  - revert j q i r;induction p; simpls;intros j q i r Equ;inversion Equ;fequals*.
  - revert j q i r;induction e; simpls;intros j q i r Equ;inversion Equ;fequals*.
  - destruct c as [p e];simpls;introv Equ;inversion Equ;fequals*.
Qed.

Fixpoint open_rec_prf_cont_id_core_1 p j q i r {struct p}:
                    {j ~+> q}+ p = {i ~-> r}+ ({j ~+> q}+ p) -> p = {i ~-> r}+ p
with open_rec_cont_cont_id_core_1 e j q i r {struct e}:
                    {j ~+> q}- e = {i ~-> r}- ({j ~+> q}- e) -> e = {i ~-> r}- e
with open_rec_clos_cont_id_core_1 c j q i r {struct c}:
                    {j ~+> q}* c = {i ~-> r}* ({j ~+> q}* c) -> c = {i ~-> r}* c
.
Proof.
  - revert j q i r;induction p; simpls;intros j q i r Equ;inversion Equ;fequals*.
  - revert j q i r;induction e; simpls;intros j q i r Equ;inversion Equ;fequals*.
  - destruct c as [p e];simpls;introv Equ;inversion Equ;fequals*.
Qed.

Fixpoint open_rec_prf_prf_id (p:prf) q (H:proof p) {struct H}:
   forall k, p = {k ~+> q}+ p
with open_rec_cont_prf_id e q (H:context e) {struct H}:
   forall k, e = {k ~+> q}- e
with open_rec_clos_prf_id c q (H:closure c) {struct H}:
   forall k, c = {k ~+> q}* c.
Proof.
  - destruct H; intro k; simpl;fequal.
    + unfolds open_prf_prf.
      pick_fresh x.
      apply (@open_rec_prf_prf_id_core p 0 (prf_fvar x) (S k) q).
      * discriminate.
      * apply open_rec_prf_prf_id.
        apply* H.
    + unfolds open_clos_cont.
      pick_fresh x.
      apply (@open_rec_clos_prf_id_core_1 c 0 (co_fvar x) k ).
      apply open_rec_clos_prf_id.
      apply* H.
  -destruct H;intros;simpl;fequal.
   + apply open_rec_prf_prf_id.
     apply H.
   + apply open_rec_cont_prf_id.
     apply H0.
   + unfolds open_clos_prf.
     pick_fresh x.
     apply (@open_rec_clos_prf_id_core c 0 (prf_fvar x) (S k) ).
     * discriminate.
     * apply (open_rec_clos_prf_id).
       apply* H.

  - destruct H as [p  e Hp He];intro k;simpl;fequal;[apply open_rec_prf_prf_id|apply open_rec_cont_prf_id];assumption.
Qed.

Fixpoint open_rec_prf_cont_id (p:prf) (f:cont) (H:proof p) {struct H}:
   forall k, p = {k ~-> f}+ p
with open_rec_cont_cont_id e f (H:context e) {struct H}:
   forall k, e = {k ~-> f}- e
with open_rec_clos_cont_id c f (H:closure c) {struct H}:
   forall k, c = {k ~-> f}* c.
Proof.
  - destruct H; intro k; simpl;fequal.
    + unfolds open_prf_prf.
      pick_fresh x.
      apply (@open_rec_prf_cont_id_core_1 p 0 (prf_fvar x) (k) f).
      apply open_rec_prf_cont_id.
      apply* H.
    + unfolds open_clos_cont.
      pick_fresh x.
      apply (@open_rec_clos_cont_id_core c 0 (co_fvar x) (S k) ).
      * discriminate.
      * apply open_rec_clos_cont_id.
        apply* H.
   -destruct H;intros;simpl;fequal.
   + apply open_rec_prf_cont_id.
     apply H.
   + apply open_rec_cont_cont_id.
     apply H0.
   + unfolds open_clos_cont.
     pick_fresh x.
     apply (@open_rec_clos_cont_id_core_1 c 0 (prf_fvar x) (k) ).
     apply (open_rec_clos_cont_id).
     apply* H.
  - destruct H as [p  e Hp He];intro k;simpl;fequal;[apply open_rec_prf_cont_id|apply open_rec_cont_cont_id];assumption.
Qed.

(** Substitution for a fresh name is identity. *)

Fixpoint subst_prf_fresh x p q f{struct p}:
  x \notin fv_prf p ->  [x ~+> q]+ p = p /\ [x ~->f]+ p = p
with subst_cont_fresh x e q f{struct e}:
       x \notin fv_cont e ->  [x ~+> q]- e = e  /\ [x ~->f]- e = e
with subst_clos_fresh x c q f{struct c}:
       x \notin fv_clos c ->  [x ~+> q]* c = c  /\ [x ~->f]* c = c.
Proof.
  - intro Hx;destruct p; simpls.
    + split;reflexivity.
    + case_var*.
    + destruct (subst_prf_fresh x p q f Hx) as [IHx IHf];split;fequals*.
    + destruct (subst_clos_fresh x c q f Hx) as [IHx IHf];split;fequals*.
  - intro Hx;destruct e;simpls;fequals*.
    + case_var*.
    + destruct (notin_union_r Hx) as [Hpx Hex].
      destruct (subst_prf_fresh x p q f Hpx) as [IHpx IHpf] .
      destruct (subst_cont_fresh x e q f Hex) as [IHex IHef] .
      split;fequals*.
    + destruct (subst_clos_fresh x c q f Hx) as [IHcx IHcf];split;fequals*.
  - intro Hx;destruct c as [p e];simpls;fequals*.
    destruct (notin_union_r Hx) as [Hpx Hex].
    destruct (subst_prf_fresh x p q f Hpx) as [IHpx IHpf] .
    destruct (subst_cont_fresh x e q f Hex) as [IHex IHef] .
    split;fequals*.
Qed.

(* Note that [x ~-> f] could be ill-defined when x is refering to a proof-free-variable *)

(** Substitution distributes on the open operation. *)

Fixpoint subst_open_prf_prf_core x q p1 n p2  (H:proof q) :
  [x ~+> q]+ {n ~+> p2}+ p1  = {n~+>([x ~+> q]+ p2)}+ ([x ~+> q]+ p1)
with subst_open_cont_prf_core x q e n p2 (H:proof q) :
       [x ~+> q]- {n ~+> p2}- e  = {n~+>([x ~+> q]+ p2)}- ([x ~+> q]- e)
with subst_open_clos_prf_core x q c n p2  (H:proof q) :
  [x ~+> q]* {n ~+> p2}* c  = {n~+>([x ~+> q]+ p2)}* ([x ~+> q]* c)
.
Proof.
 - generalize n.
    destruct p1; intros;simpls.
    + case_nat*.
    + case_var*.
      apply* open_rec_prf_prf_id.
    + fequals*.
    + fequals*.
 - destruct e;intros;simpls.
   + reflexivity.
   + reflexivity.
   + fequals*.
   + fequals*.
 - destruct c;intros;simpl;fequals*.
Qed.

Lemma subst_open_prf_prf:
 forall x q p1 p2, proof q -> [x ~+> q]+ p1 +^^+p2  = ([x ~+> q]+ p1) +^^+ ([x ~+> q]+ p2).
Proof.
  intros x q p1 p2 H;exact (@subst_open_prf_prf_core x q p1 0 p2 H).
Qed.

Lemma subst_open_cont_prf:
 forall x q e p2, proof q -> [x ~+> q]- e -^^+p2  = ([x ~+> q]- e) -^^+ ([x ~+> q]+ p2).
Proof.
  intros x q e p2 H;exact (@subst_open_cont_prf_core x q e 0 p2 H).
Qed.

Lemma subst_open_clos_prf:
 forall x q c p2, proof q -> [x ~+> q]* c *^^+p2  = ([x ~+> q]* c) *^^+ ([x ~+> q]+ p2).
Proof.
  intros x q c p2 H;exact (@subst_open_clos_prf_core x q c 0 p2 H).
Qed.

Fixpoint subst_open_prf_cont_core x (f:cont) p n e2 (H:context f) :
  [x ~-> f]+ {n ~-> e2}+ p  = {n~->([x ~-> f]- e2)}+ ([x ~-> f]+ p)
with subst_open_cont_cont_core x f e n e2 (H:context f) :
       [x ~-> f]- {n ~-> e2}- e  = {n~->([x ~-> f]- e2)}- ([x ~-> f]- e)
with subst_open_clos_cont_core x f c n e2 (H:context f) :
  [x ~-> f]* {n ~-> e2}* c  = {n~->([x ~-> f]- e2)}* ([x ~-> f]* c)
.
Proof.
  - generalize n.
    destruct p; intros;simpls.
    + reflexivity.
    + reflexivity.
    + fequals*.
    + fequals*.
  - destruct e;intros;simpls.
    + case_nat*.
    + case_var*.
      apply* open_rec_cont_cont_id.
    + fequals*.
    + fequals*.
  - destruct c;intros;simpl;fequals*.
Qed.

Lemma subst_open_prf_cont:
 forall x f p1 e2, context f -> [x ~-> f]+ p1 +^^-e2  = ([x ~-> f]+ p1) +^^- ([x ~-> f]- e2).
Proof.
  intros x f p1 e2 H;exact (@subst_open_prf_cont_core x f p1 0 e2 H).
Qed.

Lemma subst_open_cont_cont:
 forall x f e1 e2, context f -> [x ~-> f]- e1 -^^-e2  = ([x ~-> f]- e1) -^^- ([x ~-> f]- e2).
Proof.
  intros x f e1 e2 H;exact (@subst_open_cont_cont_core x f e1 0 e2 H).
Qed.

Lemma subst_open_clos_cont:
 forall x f c e2, context f -> [x ~-> f]* c *^^-e2  = ([x ~-> f]* c) *^^- ([x ~-> f]- e2).
Proof.
  intros x f c e2 H;exact (@subst_open_clos_cont_core x f c 0 e2 H).
Qed.

(* Same thing, mixing positive & negatives substitutions *)

Fixpoint subst_open_prf_prf_core1 x q p1 n e2  (H:proof q) :
  [x ~+> q]+ {n ~-> e2}+ p1  = {n~->([x ~+> q]- e2)}+ ([x ~+> q]+ p1)
with subst_open_cont_prf_core1 x q e n e2 (H:proof q) :
       [x ~+> q]- {n ~-> e2}- e  = {n~->([x ~+> q]- e2)}- ([x ~+> q]- e)
with subst_open_clos_prf_core1 x q c n e2  (H:proof q) :
  [x ~+> q]* {n ~-> e2}* c  = {n~->([x ~+> q]- e2)}* ([x ~+> q]* c)
.
Proof.
 - generalize n.
    destruct p1; intros;simpls.
    + reflexivity.
    + case_var*.
      apply* open_rec_prf_cont_id.
    + fequals*.
    + fequals*.
 - destruct e;intros;simpls.
   + case_nat*.
   + reflexivity.
   + fequals*.
   + fequals*.
 - destruct c;intros;simpl;fequals*.
Qed.

Lemma subst_open_prf_prf1:
 forall x q p1 e2, proof q -> [x ~+> q]+ p1 +^^-e2  = ([x ~+> q]+ p1) +^^- ([x ~+> q]- e2).
Proof.
  intros x q p1 e2 H;exact (@subst_open_prf_prf_core1 x q p1 0 e2 H).
Qed.

Lemma subst_open_cont_prf1:
 forall x q e e2, proof q -> [x ~+> q]- e -^^-e2  = ([x ~+> q]- e) -^^- ([x ~+> q]- e2).
Proof.
  intros x q e e2 H;exact (@subst_open_cont_prf_core1 x q e 0 e2 H).
Qed.

Lemma subst_open_clos_prf1:
 forall x q c e2, proof q -> [x ~+> q]* c *^^-e2  = ([x ~+> q]* c) *^^- ([x ~+> q]- e2).
Proof.
  intros x q c e2 H;exact (@subst_open_clos_prf_core1 x q c 0 e2 H).
Qed.

Fixpoint subst_open_prf_cont_core1 x (f:cont) p n q (H:context f) :
  [x ~-> f]+ {n ~+> q}+ p  = {n~+>([x ~-> f]+ q)}+ ([x ~-> f]+ p)
with subst_open_cont_cont_core1 x f e n q (H:context f) :
       [x ~-> f]- {n ~+> q}- e  = {n~+>([x ~-> f]+ q)}- ([x ~-> f]- e)
with subst_open_clos_cont_core1 x f c n q (H:context f) :
  [x ~-> f]* {n ~+> q}* c  = {n~+>([x ~-> f]+ q)}* ([x ~-> f]* c)
.
Proof.
  - generalize n.
    destruct p; intros;simpls.
    + case_nat*.
    + reflexivity.
    + fequals*.
    + fequals*.
  - destruct e;intros;simpls.
    + reflexivity.
    + case_var*.
      apply* open_rec_cont_prf_id.
    + fequals*.
    + fequals*.
  - destruct c;intros;simpl;fequals*.
Qed.

Lemma subst_open_prf_cont1:
 forall x f p1 q, context f -> [x ~-> f]+ p1 +^^+q  = ([x ~-> f]+ p1) +^^+ ([x ~-> f]+ q).
Proof.
  intros x f p1 q H;exact (@subst_open_prf_cont_core1 x f p1 0 q H).
Qed.

Lemma subst_open_cont_cont1:
 forall x f e1 q, context f -> [x ~-> f]- e1 -^^+q  = ([x ~-> f]- e1) -^^+ ([x ~-> f]+ q).
Proof.
  intros x f e1 q H;exact (@subst_open_cont_cont_core1 x f e1 0 q H).
Qed.

Lemma subst_open_clos_cont1:
 forall x f c q, context f -> [x ~-> f]* c *^^+q  = ([x ~-> f]* c) *^^+ ([x ~-> f]+ q).
Proof.
  intros x f c q H;exact (@subst_open_clos_cont_core1 x f c 0 q H).
Qed.

(** Substitution and open_var for distinct names commute. *)

Fixpoint subst_open_prf_prf_var x y p q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
  ([x ~+> q]+ p) +^+ y = [x ~+> q]+ (p +^+ y)
with subst_open_cont_prf_var x y e q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
       ([x ~+> q]- e) -^+ y = [x ~+> q]- (e -^+ y)
with subst_open_clos_prf_var x y c q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
  ([x ~+> q]* c) *^+ y = [x ~+> q]* (c *^+ y).
Proof.
  unfolds open_prf_prf_var.
  rewrite* subst_open_prf_prf.
  simpl. case_var*.
  unfolds open_cont_prf_var.
  rewrite* subst_open_cont_prf.
  simpl. case_var*.
    unfolds open_clos_prf_var.
  rewrite* subst_open_clos_prf.
  simpl. case_var*.
Qed.

Fixpoint subst_open_prf_cont_var x y p f (Hxy: y <> x) (Hf:context f) {struct Hf}:
  ([x ~-> f]+ p) +^- y = [x ~-> f]+ (p +^- y)
with subst_open_cont_cont_var x y e f (Hxy: y <> x) (Hf:context f) {struct Hf}:
       ([x ~-> f]- e) -^- y = [x ~-> f]- (e -^- y)
with subst_open_clos_cont_var x y c f (Hxy: y <> x) (Hf:context f) {struct Hf}:
  ([x ~-> f]* c) *^- y = [x ~-> f]* (c *^- y).
Proof.
  unfolds open_prf_prf_var.
  rewrite* subst_open_prf_cont.
  simpl. case_var*.
  rewrite* subst_open_cont_cont.
  simpl. case_var*.
  rewrite* subst_open_clos_cont.
  simpl. case_var*.
Qed.

Fixpoint subst_open_prf_prf_var1 x y p q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
  ([x ~+> q]+ p) +^- y = [x ~+> q]+ (p +^- y)
with subst_open_cont_prf_var1 x y e q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
       ([x ~+> q]- e) -^- y = [x ~+> q]- (e -^- y)
with subst_open_clos_prf_var1 x y c q (Hxy: y <> x) (Hq:proof q) {struct Hq}:
  ([x ~+> q]* c) *^- y = [x ~+> q]* (c *^- y).
Proof.
  rewrite* subst_open_prf_prf1.
  rewrite* subst_open_cont_prf1.
  rewrite* subst_open_clos_prf1.
Qed.

Fixpoint subst_open_prf_cont_var1 x y p f (Hxy: y <> x) (Hf:context f) {struct Hf}:
  ([x ~-> f]+ p) +^+ y = [x ~-> f]+ (p +^+ y)
with subst_open_cont_cont_var1 x y e f (Hxy: y <> x) (Hf:context f) {struct Hf}:
       ([x ~-> f]- e) -^+ y = [x ~-> f]- (e -^+ y)
with subst_open_clos_cont_var1 x y c f (Hxy: y <> x) (Hf:context f) {struct Hf}:
  ([x ~-> f]* c) *^+ y = [x ~-> f]* (c *^+ y).
Proof.
  rewrite* subst_open_prf_cont1.
  rewrite* subst_open_cont_cont1.
  rewrite* subst_open_clos_cont1.
Qed.

(** Opening up an abstraction of body t with a term u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Fixpoint subst_intro_prf_prf  x p q:
  x \notin (fv_prf p) -> proof q -> p +^^+ q = [x ~+> q]+ (p +^+ x)
with subst_intro_cont_prf  x e q:
  x \notin (fv_cont e) -> proof q -> e -^^+ q = [x ~+> q]- (e -^+ x)
with subst_intro_clos_prf  x c q:
  x \notin (fv_clos c) -> proof q -> c *^^+ q = [x ~+> q]* (c *^+ x)
.
Proof.
  - intros Fr Wu.
    rewrite* subst_open_prf_prf.
    destruct (@subst_prf_fresh x p q  (co_bvar 0) Fr) as [H _].
    rewrite* H.
    simpl. case_var*.
  - intros Fr Wu.
    rewrite* subst_open_cont_prf.
    destruct (@subst_cont_fresh x e q  (co_bvar 0) Fr) as [H _].
    rewrite* H.
    simpl. case_var*.
  - intros Fr Wu.
    rewrite* subst_open_clos_prf.
    destruct (@subst_clos_fresh x c q  (co_bvar 0) Fr) as [H _].
    rewrite* H.
    simpl. case_var*.
Qed.

Fixpoint subst_intro_prf_cont  x p f:
  x \notin (fv_prf p) -> context f -> p +^^- f = [x ~-> f]+ (p +^- x)
with subst_intro_cont_cont  x e f:
  x \notin (fv_cont e) -> context f -> e -^^- f = [x ~-> f]- (e -^- x)
with subst_intro_clos_cont  x c f:
  x \notin (fv_clos c) -> context f-> c *^^- f = [x ~-> f]* (c *^- x)
.
Proof.
  - intros Fr Wu.
    rewrite* subst_open_prf_cont.
    destruct (@subst_prf_fresh x p (prf_bvar 0) f Fr) as  [_ H].
    rewrite* H.
    simpl. case_var*.
  - intros Fr Wu.
    rewrite* subst_open_cont_cont.
    destruct (@subst_cont_fresh x e (prf_bvar 0) f Fr) as [_ H].
    rewrite* H.
    simpl. case_var*.
  - intros Fr Wu.
    rewrite* subst_open_clos_cont.
    destruct (@subst_clos_fresh x c (prf_bvar 0) f Fr) as [_ H].
    rewrite* H.
    simpl. case_var*.
Qed.

(* ********************************************************************** *)
(** ** Terms are stable through substitutions *)

(** Terms are stable by substitution *)

Fixpoint proof_subst_prf_prf x p q (Hp:proof p) (Hq:proof q) {struct Hp}:
  proof ([x ~+> q]+ p)
with context_subst_cont_prf x e q (He:context e) (Hq:proof q) {struct He}:
  context ([x ~+> q]- e)
with closure_subst_clos_prf x c q (Hc:closure c) (Hq:proof q) {struct Hc}:
  closure ([x ~+> q]* c).
Proof.
  - induction Hp; simpls.
    + case_var*.
    + apply_fresh (proof_abs).
      intros.
      rewrite* subst_open_prf_prf_var.
    + apply_fresh proof_mu.
      rewrite* subst_open_clos_prf_var1.
  - induction He;simpls.
    + apply context_var.
    + apply* context_stack.
    + apply_fresh (context_mut).
      rewrite* subst_open_clos_prf_var.
  - induction Hc;simpls.
    apply* closure_cl.
Qed.

Fixpoint proof_subst_prf_cont x p f (Hp:proof p) (Hf:context f) {struct Hp}:
  proof ([x ~-> f]+ p)
with context_subst_cont_cont x e f (He:context e) (Hf:context f) {struct He}:
  context ([x ~-> f]- e)
with closure_subst_clos_cont x c f (Hc:closure c) (Hf:context f) {struct Hc}:
  closure ([x ~-> f]* c).
Proof.
  - induction Hp; simpls.
    + apply proof_var.
    + apply_fresh (proof_abs).
      rewrite* subst_open_prf_cont_var1.
    + apply_fresh proof_mu.
      rewrite* subst_open_clos_cont_var.
  - induction He;simpls.
    + case_var*.
    + apply* context_stack.
    + apply_fresh (context_mut).
      rewrite* subst_open_clos_cont_var1.
  - induction Hc;simpls.
    apply* closure_cl.
Qed.

Hint Resolve proof_subst_prf_prf context_subst_cont_prf closure_subst_clos_prf.
Hint Resolve proof_subst_prf_cont context_subst_cont_cont closure_subst_clos_cont.

(* ********************************************************************** *)
(** ** Proofs/contexts are stable through open *)

(** Conversion from locally closed abstractions and bodies *)

Lemma prf_abs_to_body : forall p,
  proof (prf_abs p) -> body_prf_prf p.
Proof. intros. unfold body_prf_prf. inversion* H. Qed.

Lemma body_to_prf_abs : forall p,
  body_prf_prf p -> proof (prf_abs p).
Proof. intros. inversion* H. Qed.

Lemma prf_mu_to_body : forall c,
  proof (prf_mu c) -> body_clos_cont c.
Proof. intros. unfold body_clos_cont. inversion* H. Qed.
Lemma body_to_prf_mu : forall c,
 body_clos_cont c ->  proof (prf_mu c).
Proof. intros. inversion* H. Qed.

Lemma cont_mut_to_body : forall c,
  context (co_mut c) -> body_clos_prf c.
Proof. intros. unfold body_clos_prf. inversion* H. Qed.
Lemma body_to_cont_mut : forall c,
 body_clos_prf c ->  context (co_mut c).
Proof. intros. inversion* H. Qed.

Hint Resolve prf_abs_to_body body_to_prf_abs.
Hint Resolve prf_mu_to_body body_to_prf_mu.
Hint Resolve cont_mut_to_body body_to_cont_mut.

(** ** Opening a body with a term gives a term *)

Lemma open_prf_prf : forall p q,
  body_prf_prf p -> proof q -> proof (p +^^+ q).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_prf_prf y).
Qed.
Lemma open_prf_cont : forall p e,
  body_prf_cont p -> context e -> proof (p +^^- e).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_prf_cont y).
Qed.

Lemma open_cont_prf : forall e q,
  body_cont_prf e -> proof q -> context (e -^^+ q).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_cont_prf y).
Qed.
Lemma open_cont_cont : forall e f,
  body_cont_cont e -> context f -> context (e -^^- f).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_cont_cont y).
Qed.

Lemma open_clos_prf : forall c q,
  body_clos_prf c -> proof q -> closure (c *^^+ q).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_clos_prf y).
Qed.
Lemma open_clos_cont : forall c e,
  body_clos_cont c -> context e -> closure (c *^^- e).
Proof.
  intros. destruct H. pick_fresh y. rewrite* (@subst_intro_clos_cont y).
Qed.

Hint Resolve open_prf_prf open_prf_cont.
Hint Resolve open_cont_prf open_cont_cont.
Hint Resolve open_clos_prf open_clos_cont.

(* ********************************************************************** *)
(** ** Regularity of relations *)

(** A typing relation holds only if the environment has no
   duplicated keys and the pre-term is locally-closed. *)

(*
Lemma typing_regular:
  (forall E p T (Hp :typing_prf E p T),
  ok E /\ proof p)
/\ (forall E e T (He:typing_cont E e T),
   ok E /\ context e)
/\ (forall E c (Hc:typing_clos E c ),
   ok E /\ closure c).
Proof.
  apply typing_mut_ind.
  - intros e a T Ok Binds.
    auto.
  - intros L E U T p Hp IH.
    split.
    + pick_fresh x.
      forwards~ : (IH x).
      destruct* H.
    + apply (@proof_abs L).
      intros a Ha; destruct* (IH a Ha).
  - intros L E T c q Ha Hc (IH,IHc).
    split.
    + inversion* IH.
    + apply_fresh (proof_mu).
      intros.

      * destruct* (typing_regular_clos (E & a ~ neg T) (c*^-a) ).
   + inductions Hp.
     * apply proof_var.
     * apply (proof_abs p1 H0).
     * apply (@proof_mu L c).
       destruct* (typing_regular_prf E p T Hp).
   Guarded.
   + apply_fresh (proof_mu).
    rewrite open_clos_cont_def.
     destruct* (typing_regular_clos (E & y~ neg T) (c*^-y)).
     (* rewrite* <- (@open_rec_clos_cont_id c (co_fvar y) H1 0). *)
  -split; induction* He.
    + pick_fresh a.
     destruct* (typing_regular_clos (E & a ~ pos T) (c*^+a) ).
    + apply_fresh context_mut.
      rewrite open_clos_prf_def.
     destruct* (typing_regular_clos (E & y~ pos T) (c*^+y)).
     (* rewrite* <- (@open_rec_clos_prf_id c (prf_fvar y) H1 0). *)
    + apply* context_stack.
      destruct* (typing_regular_prf E q T H).
  -induction Hc.
   destruct (typing_regular_prf E p T H);destruct* (typing_regular_cont E e (neg T) H0).
Qed

  *)
 Fixpoint typing_regular_prf E p T (Hp:typing_prf E p T):
  ok E /\ proof p
with typing_regular_cont E e T (He:typing_cont E e T):
   ok E /\ context e
with typing_regular_clos E c (Hc:typing_clos E c ):
   ok E /\ closure c.
Proof.
  -split; induction* Hp.
   + pick_fresh y. forwards~ : (H0 y).
   + pick_fresh y. destruct* (typing_regular_clos (E & y ~ neg T) (c*^-y) ).
   + apply_fresh (proof_mu).
     destruct* (typing_regular_clos (E & y~ neg T) (c*^-y)).
     (* rewrite* <- (@open_rec_clos_cont_id c (co_fvar y) H1 0). *)
  -split; induction* He.
    + pick_fresh a.
     destruct* (typing_regular_clos (E & a ~ pos T) (c*^+a) ).
    + apply_fresh context_mut.
      rewrite open_clos_prf_def.
     destruct* (typing_regular_clos (E & y~ pos T) (c*^+y)).
    + apply* context_stack.
      destruct* (typing_regular_prf E q T H).
  -induction Hc.
   destruct (typing_regular_prf E p T H);destruct* (typing_regular_cont E e ( T) H0).
Qed.

(** The value predicate only holds on locally-closed terms. *)

Lemma value_regular p (Hp:value p): proof p.
Proof.
  inversion* Hp.
Qed.

(** A reduction relation only holds on pairs of locally-closed terms. *)

Fixpoint open_rec_prf_mix_comm p q e i j {struct p}:
  proof(q) -> context(e) -> ({i ~+> q}+ ({j ~-> e }+ p)) = ({j ~-> e }+ ({i ~+> q}+ p))
with open_rec_cont_mix_comm f q e i j {struct f}:
       proof(q) -> context(e) -> ({i ~+> q}- ({j ~-> e }- f)) = ({j ~-> e }- ({i ~+> q}- f))
with open_rec_clos_mix_comm c q e i j {struct c}:
       proof(q) -> context(e) -> ({i ~+> q}* ({j ~-> e }* c)) = ({j ~-> e }* ({i ~+> q}* c)).
Proof.
- induction p;simpl;intros.
  + case_nat.
    * apply* open_rec_prf_cont_id.
    * unfold open_rec_prf_cont. reflexivity.
  + reflexivity.
  + assert ({S i ~+> q }+ ({j ~-> e }+ p) ={j ~-> e }+ ({S i ~+> q }+ p)) as Heq.
    * apply* open_rec_prf_mix_comm.
    * now rewrite Heq.
  + assert ({i ~+> q }* ({S j ~-> e }* c) ={S j ~-> e }* ({i ~+> q }* c)) as Heq.
    * apply* open_rec_clos_mix_comm.
    * now rewrite Heq.
- induction f;simpl;intros.
  +  case_nat.
    * now rewrite <- (open_rec_cont_prf_id q H0 i).
    * unfold open_rec_cont_prf. reflexivity.
  + reflexivity.
  + rewrite (open_rec_prf_mix_comm p q e i j H H0).
    now rewrite (open_rec_cont_mix_comm f q e i j H H0).
  + now (rewrite (open_rec_clos_mix_comm c q e (S i) j H H0)).
- induction c as (p,f);simpl;intros.
  rewrite (open_rec_prf_mix_comm p q e i j H H0).
  now rewrite (open_rec_cont_mix_comm f q e i j H H0).
Qed.

Fixpoint open_rec_prf_cont_comm p e f i j {struct p}:
  i<> j -> context(e) -> context(f) -> ({i ~-> e}+ ({j ~-> f }+ p)) = ({j ~-> f }+ ({i ~-> e}+ p))
with open_rec_cont_cont_comm e f g i j {struct e}:
  i<> j -> context(f) -> context(g) -> ({i ~-> f}- ({j ~-> g }- e)) = ({j ~-> g }- ({i ~-> f}- e))
with open_rec_clos_cont_comm c e f i j {struct c}:
  i<> j -> context(e) -> context(f) -> ({i ~-> e}* ({j ~-> f }* c)) = ({j ~-> f }* ({i ~-> e}* c)).
Proof.
- destruct p;simpl;intros;try tauto.
  + now rewrite (open_rec_prf_cont_comm p e f i j H H0 H1).
  + apply not_eq_S in H.
    now rewrite (open_rec_clos_cont_comm c e f (S i) (S j) H H0 H1).
- destruct e;simpl;intros;try tauto.
  + case_nat;simpl.
    * rewrite* If_r.
      simpl.
      rewrite* If_l.
      rewrite* <- (open_rec_cont_cont_id f H1 i).
    * case_nat;simpl.
      rewrite* <- (open_rec_cont_cont_id g H0 j).
      rewrite* If_r.
  + rewrite (open_rec_prf_cont_comm p f g i j H H0 H1).
    now rewrite (open_rec_cont_cont_comm e f g i j H H0 H1).
  + now rewrite (open_rec_clos_cont_comm c f g  i j H H0 H1).
- destruct c as (p,g);simpl;intros.
  rewrite (open_rec_prf_cont_comm p e f i j H H0 H1).
  now rewrite (open_rec_cont_cont_comm g e f i j H H0 H1).
Qed.

Fixpoint size_prf_subst_var p k y {struct p} :
  size_prf ({k ~+> prf_fvar y }+ p) = size_prf p
with size_cont_subst_var e k y {struct e} :
       size_cont ({k ~+> prf_fvar y }- e) = size_cont e
with size_clos_subst_var c k y {struct c} :
       size_clos ({k ~+> prf_fvar y }* c) = size_clos c.
Proof.
- revert k y; induction p;simpl;intros.
  + case_nat*.
  + reflexivity.
  + now rewrite (IHp (S k) y).
  + now rewrite (size_clos_subst_var c k y).
- revert k y; induction e;simpl;intros;try tauto.
  + rewrite (IHe (k) y).
    now rewrite (size_prf_subst_var p k y).
  + now rewrite (size_clos_subst_var c (S k) y).
- destruct c as (p,e);simpl.
  rewrite (size_prf_subst_var p k y).
  now rewrite (size_cont_subst_var e k y).
Qed.

Fixpoint size_prf_subst_covar p k y {struct p} :
  size_prf ({k ~-> co_fvar y }+ p) = size_prf p
with size_cont_subst_covar e k y {struct e} :
       size_cont ({k ~-> co_fvar y }- e) = size_cont e
with size_clos_subst_covar c k y {struct c} :
       size_clos ({k ~-> co_fvar y }* c) = size_clos c.
Proof.
- revert k y; induction p;simpl;intros;try tauto.
  + now rewrite (IHp k y).
  + now rewrite (size_clos_subst_covar c (S k) y).
- revert k y; induction e;simpl;intros;try tauto.
  + case_nat*.
  + rewrite (IHe (k) y).
    now rewrite (size_prf_subst_covar p k y).
  + now rewrite (size_clos_subst_covar c k y).
- destruct c as (p,e);simpl.
  rewrite (size_prf_subst_covar p k y).
  now rewrite (size_cont_subst_covar e k y).
Qed.

Lemma subst_context: (forall p e f k,
  (context (e) -> context(f) -> proof ({k ~-> e}+ p) ->  proof ({k ~-> f}+ p)))
/\(forall f e e' k,
       context (e) -> context(e') -> context ({k ~-> e}- f) ->  context ({k ~-> e'}- f))
/\(forall c e f k,
 context (e) -> context(f) -> closure ({k ~-> e}*c) ->  closure ({k ~-> f}*c)).
Proof.
  apply size_ind.
  intros n Hp He Hc.
  repeat split;intros.
  - destruct p;simpl in *.
    + assumption.
    + assumption.
    + inversion H2.
      apply_fresh proof_abs.
      apply eq_add_S in H.
      assert (y \notin L) as Ly by intuition.
      specialize (H4 y Ly).
      rewrite open_prf_prf_var_def in *.
      rewrite* (@open_rec_prf_mix_comm p (prf_fvar y) f 0 k).
      rewrite* (@open_rec_prf_mix_comm p (prf_fvar y) e 0 k) in H4.
      assert (size_prf ({0 ~+> prf_fvar y }+ p) <= n) as Size.
      rewrite size_prf_subst_var.
      intuition.
      apply (Hp (({0 ~+> prf_fvar y }+ p)) Size e f k H0 H1 H4).
    + inversion H2.
      apply_fresh proof_mu.
      assert (y \notin L) as Ly by intuition.
      specialize (H4 y Ly).
      rewrite open_clos_cont_var_def in *.
      rewrite* open_rec_clos_cont_comm.
      rewrite* open_rec_clos_cont_comm in H4.
      apply eq_add_S in H.
      assert (size_clos ({0 ~-> co_fvar y }* c) <= n) as Size.
      rewrite size_clos_subst_covar.
      intuition.
      apply (Hc _ Size e f (S k) H0 H1 H4).
  - destruct e; simpl in *.
    + case_nat*.
    + assumption.
    + inversion H2.
      assert (Sp1:=size_prf_ge_1 p).
      assert (Se1:=size_cont_ge_1 e).
      assert (size_prf p <= n) as Sp by intuition.
      assert (size_cont e <= n) as Se  by intuition.
      apply context_stack.
      * apply (Hp p Sp _ _ _ H0 H1 H5).
      * apply (He e Se _ _ _ H0 H1 H6).
    + inversion H2.
      apply_fresh context_mut.
      assert (y \notin L) as Ly by intuition.
      specialize (H4 y Ly).
      rewrite open_clos_prf_var_def in *.
      rewrite* (@open_rec_clos_mix_comm c (prf_fvar y) e' 0 (k)).
      rewrite* (@open_rec_clos_mix_comm c (prf_fvar y) e0 0 (k)) in H4.
      assert (size_clos ({0 ~+> prf_fvar y }* c) <= n) as Size.
      rewrite size_clos_subst_var.
      apply eq_add_S in H.
      intuition.
      apply* (Hc _  Size e0 e').
  - destruct c as (p,g);simpl in *.
    inversion H2.
    assert (Sp1:=size_prf_ge_1 p).
    assert (Se1:=size_cont_ge_1 g).
    assert (size_prf p <= n) as Sp by intuition.
    assert (size_cont g <= n) as Se  by intuition.
    apply closure_cl.
    + apply* (Hp _ Sp e f).
    + apply* (He _ Se e f).
Qed.

(* Lemma subst_context: (forall p q r e f k, *)
(*                         (context (e) -> context(f) -> proof ({k ~-> e}+ p) ->  proof ({k ~-> f}+ p)) *)
(*                        /\ (proof (q) -> proof(r) -> proof ({k ~+> q}+ p) ->  proof ({k ~+> r}+ p))) *)
(* /\(forall f e e' k, *)
(*        context (e) -> context(f) -> context ({k ~-> e}- f) ->  context ({k ~-> e'}- f)) *)
(* /\(forall c e f k, *)
(*  context (e) -> context(f) -> closure ({k ~-> e}*c) ->  closure ({k ~-> e}*c)). *)
(* Proof. *)
(*   apply size_ind. *)
(*   intros n Hp He Hc. *)
(*   repeat split;intros. *)
(*   - induction p;simpl in *. *)
(*     + assumption. *)
(*     + assumption. *)
(*     + (* Check open_prf_prf. *) *)
(* (*       Check prf_abs_to_body. *) *)
(* (*       assert (body:=prf_abs_to_body H2). *) *)
(* (*       unfold body_prf_prf in body. *) *)
(*       inversion H2. *)
(*       apply_fresh proof_abs. *)
(*       apply eq_add_S in H. *)
(*       assert (y \notin L) as Ly by intuition. *)
(*       specialize (H4 y Ly). *)
(*       rewrite open_prf_prf_var_def in *. *)

(*       rewrite open_prf_prf_var_def in H4. *)
(*       destruct* (Hp ({k ~-> f }+ p) _ ). *)

(* Lemma subst_context :  p e f k (H: proof ({k ~-> e}+ p)): *)
(*   context (e) -> context(f) ->  proof ({k ~-> f}+ p) *)
(* with context_subst_context  f e e' k (H:context ({k ~-> e}- f)){struct H}: *)
(*   context (e) -> context(f) ->   context ({k ~-> e'}- f) *)
(* with closure_subst_context c e f k (H:closure ({k ~-> e}*c)) {struct H}: *)
(*  context (e) -> context(f) ->  closure ({k ~-> f}*c). *)
(* Proof. *)
(*   inductions H;intros. *)
(*   - destruct p;simpl in*;intuition; try (discriminate x). *)
(*   - pick_fresh a. *)
(*     assert (a\notin L) by intuition. *)
(*     destruct p;simpl in*;intuition;try (discriminate x). *)
(*     apply (H0 a H3 (p+^+a)) . *)

(* Fixpoint proof_subst_context p e f k {struct p}: *)
(*   context (e) -> context(f) -> proof ({k ~-> e}+ p) ->  proof ({k ~-> f}+ p) *)
(* with context_subst_context  f e e' k {struct e}: *)
(*        context (e) -> context(f) -> context ({k ~-> e}- f) ->  context ({k ~-> e'}- f) *)
(* with closure_subst_context c e f k {struct c}: *)
(*  context (e) -> context(f) -> closure ({k ~-> e}*c) ->  closure ({k ~-> e}*c). *)
(* Proof. *)
(* - intros He Hf Hp. *)
(*   induction p;simpl in *. *)
(*   + assumption. *)
(*   + assumption. *)
(*   + inversion Hp. *)

Lemma red_regular : forall c c',
  red c c' -> closure c /\ closure c'.
Proof.
  intros.
  induction H.
  - split.
    + apply closure_cl.
      apply (value_regular H0).
      exact H.
    + apply open_clos_prf.
      unfold body_clos_prf.
      inversion H.
      exists L.
      exact H2.
      exact (value_regular H0).
  - split.
    + apply* closure_cl.
    + apply* closure_cl.
      inversion H.
      apply_fresh context_mut.
      rewrite open_clos_prf_def.
      simpls.
      apply closure_cl.
      * apply* H3.
      * rewrite<- (@open_rec_cont_prf_id  e (prf_fvar y) H1 0).
        exact H1.
  - split.
    + apply* closure_cl.
    + rewrite open_clos_cont_def.
      inversion H.
      pick_fresh a.
      assert (a\notin L) by intuition.
      specialize (H2 a H3).
      rewrite open_clos_cont_var_def in H2.
      destruct subst_context as (_,(_,Hs)).
      apply* (Hs c (co_fvar a) e).
Qed.

(** Automation for reasoning on well-formedness. *)

Hint Extern 1 (ok ?E) =>
  match goal with
    | H: typing_prf E _ _ |- _ => apply (proj1 (typing_regular_prf H))
    | H: typing_cont E _ _ |- _ => apply (proj1 (typing_regular_cont H))
    | H: typing_clos E _  |- _ => apply (proj1 (typing_regular_clos H))
  end.

Hint Extern 1 (proof ?p) =>
  match goal with
  | H: typing_prf _ p _ |- _ => apply (proj2 (typing_regular_prf H))
   | H: value p |- _ => apply (value_regular H)
  end.

Hint Extern 1 (context ?e) =>
  match goal with
  | H: typing_cont _ e _ |- _ => apply (proj2 (typing_regular_cont H))
  end.

Hint Extern 1 (closure ?c) =>
  match goal with
  | H: typing_clos _ c _ |- _ => apply (proj2 (typing_regular_clos H))
  | H: red c _ |- _ => apply (proj1 (red_regular H))
  | H: red _ c |- _ => apply (proj2 (red_regular H))
  end.


Require Import SQIR.DensitySem.
Require Import RzQGateSet.

Import Qreals. (* Coq version < 8.13.0 has Q2R defined in Qreals *)

Module RzQProps := NUListProofs RzQGateSet.
Export RzQProps.

Local Open Scope com_scope.

(* This optimization removes z-rotations (RzQ gates) that occur immediately before measurement. *)

(** Basic equivalences. **)

Lemma skip_id_r : forall dim (c : base_com dim),
  c; skip ≡ c.
Proof.
  intros.
  unfold c_equiv; simpl.
  unfold compose_super; reflexivity.
Qed.

Lemma Rz_mif : forall dim θ n (c1 c2 : base_com dim),
  SQIR.Rz θ n ; mif n then c1 else c2 ≡ mif n then c1 else c2.
Proof.
  intros.
  unfold c_equiv; simpl.
  intros.
  unfold compose_super, Splus, super.
  unfold proj. simpl.
  autorewrite with eval_db.
  repad. subst. clear.
  Msimpl.
  repeat rewrite Mmult_assoc.
  Msimpl.
  repeat (restore_dims; rewrite <- Mmult_assoc).
  Qsimpl.
  replace (phase_shift (- θ) × ∣0⟩) with ∣0⟩ by solve_matrix.
  replace (phase_shift (- θ) × ∣1⟩) with (Cexp (- θ) .* ∣1⟩) by solve_matrix.
  repeat (restore_dims; rewrite Mmult_assoc).
  replace (⟨0∣ × phase_shift θ) with ⟨0∣ by solve_matrix.
  replace (⟨1∣ × phase_shift θ) with (Cexp θ .* ⟨1∣) by solve_matrix.
  apply f_equal2; trivial.
  distribute_scale.
  rewrite Cexp_mul_neg_r.
  rewrite Mscale_1_l.
  reflexivity.
Qed.

(* list version of the equivalence above *)
Lemma RzQ_Meas : forall {dim} i n (l1 l2 : RzQ_com_l dim),
  (UC [Rzq i n]) :: [Meas n l1 l2] =l= [Meas n l1 l2].
Proof.
  intros.
  unfold c_equiv_l; simpl.
  rewrite instr_to_com_UC, instr_to_com_Meas.
  simpl.
  rewrite skip_id_r.
  rewrite <- Rz_mif with (θ:=(Q2R i * PI)%R) at 2.
  apply seq_congruence; try reflexivity.
  unfold c_equiv; simpl.
  intros.
  unfold super.
  autorewrite with eval_db; try assumption.
  bdestruct (n + 1 <=? dim); Msimpl; reflexivity.
Qed.

(* Not currently used, but could be useful for non-unitary X propagation. *)
Lemma X_mif : forall dim n (c1 c2 : base_com dim),
  SQIR.X n ; mif n then c1 else c2 ≡
    mif n then (SQIR.X n ; c2) else (SQIR.X n ; c1).
Proof.
  intros.
  unfold c_equiv; simpl.
  intros.
  unfold compose_super, Splus, super.
  unfold proj. simpl.
  autorewrite with eval_db.
  repad. subst. clear.
  Msimpl.
  repeat rewrite Mmult_assoc.
  Msimpl.
  repeat (restore_dims; rewrite <- Mmult_assoc).
  Qsimpl.
  rewrite Mplus_comm; reflexivity.
  rewrite Mplus_comm; reflexivity.
Qed.

(** Remove phase shifts before measurement. **)

(* Note that this will only remove one Rz gate per UC block. To remove multiple
   Rz gates per UC block, the function below could be modified - or just run multiple times. *)

(* Get the next rotation gate on any qubit. *)
Fixpoint next_Rz_gate {dim} (l : RzQ_ucom_l dim)
             : option (RzQ_ucom_l dim * Q * nat * RzQ_ucom_l dim) :=
  match l with
  | [] => None
  | (App1 (URzQ_Rz i) n) :: t => Some ([], i, n, t)
  | g :: t => match (next_Rz_gate t) with
            | None => None
            | Some (l1, i, n, l2) => Some (g :: l1, i, n, l2)
            end
  end.

(* Perform the optimization. *)
Fixpoint remove_Rz_before_meas' {dim} (l : RzQ_com_l dim) n :=
  match n with
  | O => l
  | S n' =>
      match l with
      | [] => []
      | UC u :: t =>
          match next_Rz_gate u with
          | None => UC u :: remove_Rz_before_meas' t n'
          | Some (l1, _, n, l2) =>
              match next_measurement (UC l2 :: t) n with
              | Some _ => UC (l1 ++ l2) :: remove_Rz_before_meas' t n'
              | None => UC u :: remove_Rz_before_meas' t n'
              end
          end
      | Meas n l1 l2 :: t =>
          let l1' := remove_Rz_before_meas' l1 n' in
          let l2' := remove_Rz_before_meas' l2 n' in
          Meas n l1' l2' :: remove_Rz_before_meas' t n'
      end
  end.
Definition remove_Rz_before_meas {dim} (l : RzQ_com_l dim) :=
  remove_Rz_before_meas' l (count_ops l).

(** Examples **)

Definition test1 : RzQ_com_l 3 := UC (X 2 :: RzQGateSet.Z 0 :: CNOT 1 2 :: []) :: Meas 0 [] [] :: [].
Compute (count_ops test1).
Compute (remove_Rz_before_meas test1).
Definition test2 : RzQ_com_l 3 := UC (X 2 :: RzQGateSet.Z 0 :: CNOT 1 2 :: []) :: Meas 0 (UC [P 1] :: Meas 1 [] [] :: []) [] :: [].
Compute (count_ops test2).
Compute (remove_Rz_before_meas test2).
Definition test3 : RzQ_com_l 3 := UC (X 2 :: RzQGateSet.Z 0 :: CNOT 1 2 :: []) :: UC (H 2 :: []) :: Meas 2 [] [UC [H 1]] :: Meas 0 (UC [P 1] :: Meas 0 [] [] :: Meas 1 [] [] :: []) [UC (X 2 :: CNOT 1 2 :: [])] :: [].
Compute (count_ops test3).
Compute (remove_Rz_before_meas test3).

(** Proofs **)

Lemma next_Rz_gate_preserves_structure : forall dim (l : RzQ_ucom_l dim) l1 i n l2,
  next_Rz_gate l = Some (l1, i, n, l2) ->
  l = l1 ++ [Rzq i n] ++ l2.
Proof.
  intros.
  generalize dependent l1.
  induction l; intros l1 H.
  - inversion H.
  - simpl in H.
    destruct a as [u | u | u]; dependent destruction u.
    all: try (destruct (next_Rz_gate l) eqn:Hnext;
              try discriminate;
              do 3 destruct p;
              inversion H; subst;
              rewrite IHl with (l1:=r0);
              reflexivity).
    inversion H; subst. reflexivity.
Qed.

Lemma remove_Rz_before_meas_sound : forall dim (l : RzQ_com_l dim),
  remove_Rz_before_meas l =l= l.
Proof.
  intros.
  unfold remove_Rz_before_meas.
  remember (count_ops l) as n; clear Heqn.
  generalize dependent l.
  induction n; try reflexivity.
  intros; simpl.
  destruct l; try reflexivity.
  destruct i; simpl.
  - destruct (next_Rz_gate g) eqn:ng.
    do 3 destruct p.
    destruct (does_not_reference r n0) eqn:dnr.
    destruct (next_measurement l n0) eqn:nm.
    repeat destruct p.
    all: try (rewrite IHn; reflexivity).
    apply next_Rz_gate_preserves_structure in ng.
    specialize (next_measurement_l1_does_not_reference _ _ _ _ _ _ nm) as dnr_c.
    apply next_measurement_preserves_structure in nm.
    rewrite IHn.
    rewrite cons_to_app.
    rewrite (cons_to_app _ l).
    rewrite c_app_congruence.
    2: apply UC_append.
    2: reflexivity.
    rewrite (c_app_congruence [UC g]).
    2: { rewrite ng.
         rewrite UC_append.
         rewrite c_app_congruence.
         2: reflexivity.
         2: apply uc_equiv_l_implies_c_equiv_l;
            apply does_not_reference_commutes_app1;
            assumption.
         rewrite c_app_congruence.
         2: reflexivity.
         2: apply UC_append.
         reflexivity. }
    2: reflexivity.
    rewrite nm.
    repeat rewrite <- app_assoc.
    do 2 (apply c_app_congruence; try reflexivity).
    repeat rewrite app_assoc.
    apply c_app_congruence; try reflexivity.
    rewrite (c_app_congruence ([UC [Rzq q n0]] ++ l2)).
    2: apply does_not_reference_c_commutes_app1; assumption.
    2: reflexivity.
    rewrite <- app_assoc.
    apply c_app_congruence; try reflexivity.
    simpl.
    symmetry. apply RzQ_Meas.
  - rewrite IHn with (l:=l).
    unfold c_equiv_l, c_equiv; intros.
    apply Meas_cons_congruence; unfold c_eval_l, project_onto; simpl.
    1,2: intros; apply IHn.
    all: auto with wf_db.
    reflexivity.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** A heap data structure. *)

(** The implementation uses splay heaps, following C. Okasaki,
    "Purely functional data structures", section 5.4.
    One difference: we eliminate duplicate elements.
    (If an element is already in a heap, inserting it again does nothing.)
*)

Require Import Coqlib.
Require Import FSets.
Require Import Ordered.

Module SplayHeapSet(E: OrderedType).

(** "Raw" implementation.  The "is a binary search tree" invariant
    is proved separately. *)

Module R.

Inductive heap: Type :=
  | Empty
  | Node (l: heap) (x: E.t) (r: heap).

Function partition (pivot: E.t) (h: heap) { struct h } : heap * heap :=
  match h with
  | Empty => (Empty, Empty)
  | Node a x b =>
      match E.compare x pivot with
      | EQ _ => (a, b)
      | LT _ =>
        match b with
        | Empty => (h, Empty)
        | Node b1 y b2 =>
            match E.compare y pivot with
            | EQ _ => (Node a x b1, b2)
            | LT _ =>
              let (small, big) := partition pivot b2
              in (Node (Node a x b1) y small, big)
            | GT _ =>
              let (small, big) := partition pivot b1
              in (Node a x small, Node big y b2)
            end
        end
     | GT _ =>
        match a with
        | Empty => (Empty, h)
        | Node a1 y a2 =>
            match E.compare y pivot with
            | EQ _ => (a1, Node a2 x b)
            | LT _ =>
              let (small, big) := partition pivot a2
              in (Node a1 y small, Node big x b)
            | GT _ =>
              let (small, big) := partition pivot a1
              in (small, Node big y (Node a2 x b))
            end
        end
    end
  end.

Definition insert (x: E.t) (h: heap) : heap :=
  let (a, b) := partition x h in Node a x b.

Fixpoint findMin (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node Empty x b => Some x
  | Node a x b => findMin a
  end.

Function deleteMin (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node Empty x b => b
  | Node (Node Empty x b) y c => Node b y c
  | Node (Node a x b) y c => Node (deleteMin a) x (Node b y c)
  end.

Fixpoint findMax (h: heap) : option E.t :=
  match h with
  | Empty => None
  | Node a x Empty => Some x
  | Node a x b => findMax b
  end.

Function deleteMax (h: heap) : heap :=
  match h with
  | Empty => Empty
  | Node b x Empty => b
  | Node b x (Node c y Empty) => Node b x c
  | Node a x (Node b y c) => Node (Node a x b) y (deleteMax c)
  end.

(** Specification *)

Fixpoint In (x: E.t) (h: heap) : Prop :=
  match h with
  | Empty => False
  | Node a y b => In x a \/ E.eq x y \/ In x b
  end.

(** Invariants *)

Fixpoint lt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => lt_heap a x /\ E.lt y x /\ lt_heap b x
  end.

Fixpoint gt_heap (h: heap) (x: E.t) : Prop :=
  match h with
  | Empty => True
  | Node a y b => gt_heap a x /\ E.lt x y /\ gt_heap b x
  end.

Fixpoint bst (h: heap) : Prop :=
  match h with
  | Empty => True
  | Node a x b => bst a /\ bst b /\ lt_heap a x /\ gt_heap b x
  end.

Definition le (x y: E.t) := E.eq x y \/ E.lt x y.

Lemma le_lt_trans:
  forall x1 x2 x3, le x1 x2 -> E.lt x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x2 x3). auto. apply E.eq_trans with x1. apply E.eq_sym; auto. auto.
    elim (@E.lt_not_eq x2 x1). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma lt_le_trans:
  forall x1 x2 x3, E.lt x1 x2 -> le x2 x3 -> E.lt x1 x3.
Proof.
  unfold le; intros; intuition.
  destruct (E.compare x1 x3).
    auto.
    elim (@E.lt_not_eq x1 x2). auto. apply E.eq_trans with x3. auto. apply E.eq_sym; auto.
    elim (@E.lt_not_eq x3 x2). eapply E.lt_trans; eauto. apply E.eq_sym; auto.
    eapply E.lt_trans; eauto.
Qed.

Lemma le_trans:
  forall x1 x2 x3, le x1 x2 -> le x2 x3 -> le x1 x3.
Proof.
  intros. destruct H. destruct H0. red; left; eapply E.eq_trans; eauto.
  red. right. eapply le_lt_trans; eauto. red; auto.
  red. right. eapply lt_le_trans; eauto.
Qed.

Lemma lt_heap_trans:
  forall x y, le x y ->
  forall h, lt_heap h x -> lt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply lt_le_trans; eauto.
Qed.

Lemma gt_heap_trans:
  forall x y, le y x ->
  forall h, gt_heap h x -> gt_heap h y.
Proof.
  induction h; simpl; intros.
  auto.
  intuition. eapply le_lt_trans; eauto.
Qed.

(** Properties of [partition] *)

Lemma In_partition:
  forall x pivot, ~E.eq x pivot ->
  forall h, bst h -> (In x h <-> In x (fst (partition pivot h)) \/ In x (snd (partition pivot h))).
Proof.
  intros x pivot NEQ h0. functional induction (partition pivot h0); simpl; intros.
  tauto.
  intuition. elim NEQ. eapply E.eq_trans; eauto.
  intuition.
  intuition. elim NEQ. eapply E.eq_trans; eauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
  rewrite e3 in IHp; simpl in IHp. intuition.
  intuition.
  intuition. elim NEQ. eapply E.eq_trans; eauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
  rewrite e3 in IHp; simpl in IHp. intuition.
Qed.

Lemma partition_lt:
  forall x pivot h,
  lt_heap h x -> lt_heap (fst (partition pivot h)) x /\ lt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl.
  tauto.
  tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
Qed.

Lemma partition_gt:
  forall x pivot h,
  gt_heap h x -> gt_heap (fst (partition pivot h)) x /\ gt_heap (snd (partition pivot h)) x.
Proof.
  intros x pivot h0. functional induction (partition pivot h0); simpl.
  tauto.
  tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
  rewrite e3 in IHp; simpl in IHp. tauto.
Qed.

Lemma partition_split:
  forall pivot h,
  bst h -> lt_heap (fst (partition pivot h)) pivot /\ gt_heap (snd (partition pivot h)) pivot.
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl.
  tauto.
  intuition. eapply lt_heap_trans; eauto. red; auto. eapply gt_heap_trans; eauto. red; left; apply E.eq_sym; auto.
  intuition. eapply lt_heap_trans; eauto. red; auto.
  intuition. eapply lt_heap_trans; eauto. red; auto.
    eapply lt_heap_trans; eauto. red; auto.
    apply gt_heap_trans with y; auto. red. left; apply E.eq_sym; auto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    eapply lt_heap_trans; eauto. red; auto.
    eapply lt_heap_trans; eauto. red; auto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    eapply lt_heap_trans; eauto. red; auto.
    apply gt_heap_trans with y; eauto. red; auto.
  intuition. eapply gt_heap_trans; eauto. red; auto.
  intuition. apply lt_heap_trans with y; eauto. red; auto.
    eapply gt_heap_trans; eauto. red; left; apply E.eq_sym; auto.
    eapply gt_heap_trans; eauto. red; auto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    apply lt_heap_trans with y; eauto. red; auto.
    eapply gt_heap_trans; eauto. red; auto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    apply gt_heap_trans with y; eauto. red; auto.
    apply gt_heap_trans with x; eauto. red; auto.
Qed.

Lemma partition_bst:
  forall pivot h,
  bst h ->
  bst (fst (partition pivot h)) /\ bst (snd (partition pivot h)).
Proof.
  intros pivot h0. functional induction (partition pivot h0); simpl.
  tauto.
  tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    apply lt_heap_trans with x; auto. red; auto.
    generalize (partition_gt y pivot b2 H7). rewrite e3; simpl. tauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    generalize (partition_gt x pivot b1 H3). rewrite e3; simpl. tauto.
    generalize (partition_lt y pivot b1 H4). rewrite e3; simpl. tauto.
  tauto.
  tauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    generalize (partition_gt y pivot a2 H6). rewrite e3; simpl. tauto.
    generalize (partition_lt x pivot a2 H8). rewrite e3; simpl. tauto.
  rewrite e3 in IHp; simpl in IHp. intuition.
    generalize (partition_lt y pivot a1 H3). rewrite e3; simpl. tauto.
    apply gt_heap_trans with x; auto. red. auto.
Qed.

(** Properties of [insert] *)

Lemma insert_bst:
  forall x h, bst h -> bst (insert x h).
Proof.
  intros.
  unfold insert. case_eq (partition x h). intros a b EQ; simpl.
  generalize (partition_bst x h H).
  generalize (partition_split x h H).
  rewrite EQ; simpl. tauto.
Qed.

Lemma In_insert:
  forall x h y, bst h -> (In y (insert x h) <-> E.eq y x \/ In y h).
Proof.
  intros. unfold insert.
  case_eq (partition x h). intros a b EQ; simpl.
  assert (E.eq y x \/ ~E.eq y x).
    destruct (E.compare y x); auto.
    right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
  destruct H0.
  tauto.
  generalize (In_partition y x H0 h H). rewrite EQ; simpl. tauto.
Qed.

(** Properties of [findMin] and [deleteMin] *)

Lemma deleteMin_lt:
  forall x h, lt_heap h x -> lt_heap (deleteMin h) x.
Proof.
  intros x h0. functional induction (deleteMin h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
Qed.

Lemma deleteMin_bst:
  forall h, bst h -> bst (deleteMin h).
Proof.
  intros h0. functional induction (deleteMin h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
    apply deleteMin_lt; auto.
    apply gt_heap_trans with y; auto. red; auto.
Qed.

Lemma In_deleteMin:
  forall y x h,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
  intros y x h0. functional induction (deleteMin h0); simpl; intros.
  congruence.
  inv H. tauto.
  inv H. tauto.
  destruct a. contradiction. tauto.
Qed.

Lemma gt_heap_In:
  forall x y h, gt_heap h x -> In y h -> E.lt x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply lt_le_trans with x0; auto. red. left. apply E.eq_sym; auto.
Qed.

Lemma findMin_min:
  forall x h, findMin h = Some x -> bst h -> forall y, In y h -> le x y.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h1.
  inv H. simpl in *. intuition.
  red; left; apply E.eq_sym; auto.
  red; right. eapply gt_heap_In; eauto.
  assert (le x x1).
    apply IHh1; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1. auto.  apply le_trans with x0. simpl in H4. red; tauto.
  red; left; apply E.eq_sym; auto.
  apply le_trans with x1. auto. apply le_trans with x0. simpl in H4. red; tauto.
  red; right. eapply gt_heap_In; eauto.
Qed.

Lemma findMin_empty:
  forall h, h <> Empty -> findMin h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h1. congruence. apply IHh1. congruence.
Qed.

(** Properties of [findMax] and [deleteMax]. *)

Lemma deleteMax_gt:
  forall x h, gt_heap h x -> gt_heap (deleteMax h) x.
Proof.
  intros x h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
Qed.

Lemma deleteMax_bst:
  forall h, bst h -> bst (deleteMax h).
Proof.
  intros h0. functional induction (deleteMax h0); simpl; intros.
  auto.
  tauto.
  tauto.
  intuition.
    apply lt_heap_trans with x; auto. red; auto.
    apply deleteMax_gt; auto.
Qed.

Lemma In_deleteMax:
  forall y x h,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
  intros y x h0. functional induction (deleteMax h0); simpl; intros.
  congruence.
  inv H. tauto.
  inv H. tauto.
  destruct c. contradiction. tauto.
Qed.

Lemma lt_heap_In:
  forall x y h, lt_heap h x -> In y h -> E.lt y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  intuition. apply le_lt_trans with x0; auto. red. left. apply E.eq_sym; auto.
Qed.

Lemma findMax_max:
  forall x h, findMax h = Some x -> bst h -> forall y, In y h -> le y x.
Proof.
  induction h; simpl; intros.
  contradiction.
  destruct h2.
  inv H. simpl in *. intuition.
  red; right. eapply lt_heap_In; eauto.
  red; left. auto.
  assert (le x1 x).
    apply IHh2; auto. tauto. simpl. right; left; apply E.eq_refl.
  intuition.
  apply le_trans with x1; auto.  apply le_trans with x0.
  red; right. eapply lt_heap_In; eauto.
  simpl in H6. red; tauto.
  apply le_trans with x1; auto. apply le_trans with x0.
  red; auto.
  simpl in H6. red; tauto.
Qed.

Lemma findMax_empty:
  forall h, h <> Empty -> findMax h <> None.
Proof.
  induction h; simpl; intros.
  congruence.
  destruct h2. congruence. apply IHh2. congruence.
Qed.

End R.

(** Wrapping in a dependent type *)

Definition t := { h: R.heap | R.bst h }.

(** Operations *)

Program Definition empty : t := R.Empty.

Program Definition insert (x: E.t) (h: t) : t := R.insert x h.
Next Obligation. apply R.insert_bst. apply proj2_sig. Qed.

Program Definition findMin (h: t) : option E.t := R.findMin h.

Program Definition deleteMin (h: t) : t := R.deleteMin h.
Next Obligation. apply R.deleteMin_bst. apply proj2_sig. Qed.

Program Definition findMax (h: t) : option E.t := R.findMax h.

Program Definition deleteMax (h: t) : t := R.deleteMax h.
Next Obligation. apply R.deleteMax_bst. apply proj2_sig. Qed.

(** Membership (for specification) *)

Program Definition In (x: E.t) (h: t) : Prop := R.In x h.

(** Properties of [empty] *)

Lemma In_empty: forall x, ~In x empty.
Proof.
  intros; red; intros.
  red in H. simpl in H. tauto.
Qed.

(** Properties of [insert] *)

Lemma In_insert:
  forall x h y,
  In y (insert x h) <-> E.eq y x \/ In y h.
Proof.
  intros. unfold In, insert; simpl. apply R.In_insert. apply proj2_sig.
Qed.

(** Properties of [findMin] *)

Lemma findMin_empty:
  forall h y, findMin h = None -> ~In y h.
Proof.
  unfold findMin, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMin_empty; eauto. congruence.
Qed.

Lemma findMin_min:
  forall h x y, findMin h = Some x -> In y h -> E.eq x y \/ E.lt x y.
Proof.
  unfold findMin, In; simpl. intros.
  change (R.le x y). eapply R.findMin_min; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMin]. *)

Lemma In_deleteMin:
  forall h x y,
  findMin h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMin h)).
Proof.
  unfold findMin, In; simpl; intros.
  apply R.In_deleteMin. auto.
Qed.

(** Properties of [findMax] *)

Lemma findMax_empty:
  forall h y, findMax h = None -> ~In y h.
Proof.
  unfold findMax, In; intros; simpl.
  destruct (proj1_sig h).
  simpl. tauto.
  exploit R.findMax_empty; eauto. congruence.
Qed.

Lemma findMax_max:
  forall h x y, findMax h = Some x -> In y h -> E.eq y x \/ E.lt y x.
Proof.
  unfold findMax, In; simpl. intros.
  change (R.le y x). eapply R.findMax_max; eauto. apply proj2_sig.
Qed.

(** Properties of [deleteMax]. *)

Lemma In_deleteMax:
  forall h x y,
  findMax h = Some x ->
  (In y h <-> E.eq y x \/ In y (deleteMax h)).
Proof.
  unfold findMax, In; simpl; intros.
  apply R.In_deleteMax. auto.
Qed.

End SplayHeapSet.

(** Instantiation over type [positive] *)

Module PHeap := SplayHeapSet(OrderedPositive).


From Equations Require Import Equations.
Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.

Require Import MirrorSolve.FirstOrder.
Require Import MirrorSolve.HLists.

Import ListNotations.
Import HListNotations.

Set Universe Polymorphism.

Section Sum.
  Variable (t_l : Type).
  Variable (t_r : Type).

  Inductive t := | Inl : t_l -> t | Inr : t_r -> t.

  Variable (l_eqdec : EquivDec.EqDec t_l eq).
  Variable (r_eqdec : EquivDec.EqDec t_r eq).

  Definition t_eqdec : EquivDec.EqDec t eq.
    unfold EquivDec.EqDec, Equivalence.equiv, RelationClasses.complement in *.
    intros.
    destruct x; destruct y.
    - destruct (l_eqdec t0 t1).
      + left; f_equal; trivial.
      + right; intros.
        inversion H.
        intuition eauto.
    - right; intros; inversion H.
    - right; intros; inversion H.
    - destruct (r_eqdec t0 t1).
      + left; f_equal; trivial.
      + right; intros; inversion H; intuition eauto.
  Defined.

End Sum.

Arguments Inl {_ _} _.
Arguments Inr {_ _} _.

Arguments t_eqdec {_ _} _ _.

Section SumTheory.

  Variable (l: signature).
  Variable (r: signature).

  Variable (ls_eq_dec : EquivDec.EqDec l.(sig_sorts) eq).
  Variable (rs_eq_dec : EquivDec.EqDec r.(sig_sorts) eq).

  Definition sorts := Sum.t l.(sig_sorts) r.(sig_sorts).

  Definition sorts_eq_dec : EquivDec.EqDec sorts eq := Sum.t_eqdec ls_eq_dec rs_eq_dec.

  Inductive funs : arity sorts -> sorts -> Type :=
  | LFun : forall {lsa lsr},
    l.(sig_funs) lsa lsr ->
    funs (map Inl lsa) (Inl lsr)
  | RFun : forall {rsa rsr},
    r.(sig_funs) rsa rsr ->
    funs (map Inr rsa) (Inr rsr).

  Inductive rels: arity sorts -> Type :=
  | LRel : forall {lsa},
    l.(sig_rels) lsa ->
    rels (map Inl lsa)
  | RRel : forall {rsa},
    r.(sig_rels) rsa ->
    rels (map Inr rsa).

  Definition sig: signature :=
    {| sig_sorts := sorts;
      sig_funs := funs;
      sig_rels := rels |}.

  Definition fm ctx := FirstOrder.fm sig ctx.
  Definition tm ctx := FirstOrder.tm sig ctx.

  Variable (mod_l : model l).
  Variable (mod_r : model r).

  Definition mod_sorts (s: sig_sorts sig) : Type :=
    match s with
    | Inl sl => mod_l.(mod_sorts _) sl
    | Inr sr => mod_r.(mod_sorts _) sr
    end.

  Equations strip_hl_inl {L R} {f: (Sum.t L R) -> Type} (x: list L) (args: HList.t f (map Inl x)) : HList.t (fun x => f (Inl x)) x :=
  {
    strip_hl_inl nil hnil := hnil;
    strip_hl_inl (x :: xs) (v ::: vs) := v ::: strip_hl_inl xs vs;
  }.

  Equations strip_hl_inr {L R} {f: (Sum.t L R) -> Type} (x: list R) (args: HList.t f (map Inr x)) : HList.t (fun x => f (Inr x)) x :=
  {
    strip_hl_inr nil hnil := hnil;
    strip_hl_inr (x :: xs) (v ::: vs) := v ::: strip_hl_inr xs vs;
  }.

  Arguments strip_hl_inl {_ _ _ _} _.
  Arguments strip_hl_inr {_ _ _ _} _.

  Definition mod_fns params ret (f: sig_funs sig params ret) (args: HList.t mod_sorts params) :=
    match f in funs a s return HList.t mod_sorts a -> mod_sorts s with
    | LFun f' => fun args' => mod_fns _ _ _ _ f' (strip_hl_inl args')
    | RFun f' => fun args' => mod_fns _ _ _ _ f' (strip_hl_inr args')
    end args.

  Definition mod_rels params (f: sig_rels sig params) (args: HList.t mod_sorts params) : Prop :=
    match f in rels a return HList.t mod_sorts a -> Prop with
    | LRel f' => fun args' => mod_rels _ _ _ f' (strip_hl_inl args')
    | RRel f' => fun args' => mod_rels _ _ _ f' (strip_hl_inr args')
    end args.

  Definition fm_model : model sig := {|
    FirstOrder.mod_sorts := mod_sorts;
    FirstOrder.mod_fns := mod_fns;
    FirstOrder.mod_rels := mod_rels;
  |}.

End SumTheory.


(** Points-to analysis *)

Require Import Arith List.
Require Import Machine Maps.

Set Implicit Arguments.

(** * The instruction language *)

Definition var := nat.

Inductive instruction : Set :=
  | Allocate : var -> instruction
  | Copy : var -> var -> instruction
  | Read : var -> var -> instruction
  | Write : var -> var -> instruction
  | Goto : nat -> instruction.

(** * Machine states *)

Module NatEq <: EQ.
  Definition dom := nat.
  Definition dom_eq_dec := eq_nat_dec.
End NatEq.
Module NatMap := FuncMap(NatEq).

Module VarMap : MAP with Definition dom := var := NatMap.

Record state : Set := {
  pc : nat;
  vars : VarMap.map nat;
  heap : NatMap.map nat;
  limit : nat
}.

Definition initState :=
  Build_state
  0
  (VarMap.init 0)
  (NatMap.init 0)
  0.

(** * Dynamic semantics *)

Definition exec (i : instruction) (s : state) : state :=
  match i with
    | Allocate dst =>
      Build_state
      (S (pc s))
      (VarMap.upd (vars s) dst (S (limit s)))
      (heap s)
      (S (limit s))
    | Copy dst src =>
      Build_state
      (S (pc s))
      (VarMap.upd (vars s) dst (VarMap.sel (vars s) src))
      (heap s)
      (limit s)
    | Read dst src =>
      match NatMap.sel (heap s) (VarMap.sel (vars s) src) with
	| O => s
	| addr =>
	  Build_state
	  (S (pc s))
	  (VarMap.upd (vars s) dst addr)
	  (heap s)
	  (limit s)
      end
    | Write dst src =>
      match VarMap.sel (vars s) dst with
	| O => s
	| addr =>
	  Build_state
	  (S (pc s))
	  (vars s)
	  (NatMap.upd (heap s) addr (VarMap.sel (vars s) src))
	  (limit s)
      end
    | Goto n =>
      Build_state
      n
      (vars s)
      (heap s)
      (limit s)
  end.

(** * Must-not-alias relation *)

Section mustNotAlias.
  Variable program : list instruction.
  Variables v1 v2 : var.

  Definition mustNotAlias :=
    forall s, reachable program pc exec initState s
      -> VarMap.sel (vars s) v1 = VarMap.sel (vars s) v2
      -> VarMap.sel (vars s) v1 = 0.

  Inductive mustNotAlias_answer : Set :=
    | Unknown : mustNotAlias_answer
    | NotAliased : mustNotAlias -> mustNotAlias_answer.
End mustNotAlias.

Definition mustNotAlias_procedure := forall program v1 v2,
  mustNotAlias_answer program v1 v2.


Require Import EnvLibA.
Require Import PRelLibA.
Require Import IdModTypeA.

Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Arith.EqNat.

Open Scope nat_scope.

Module ModNEnv <: IdModType.

  Definition Id := nat.

  Definition IdEqDec := eq_nat_dec.

  Instance IdEq2 : DEq Id :=
  {
  dEq := IdEqDec
  }.

  Definition IdEq := IdEq2.

  Definition W := list (Id * nat).

  Definition Loc_PI := valTyp_irrelevance.

  Definition BInit := @nil (Id * nat).

  Instance WP2 : PState W :=
  {
  loc_pi := Loc_PI;

  b_init := BInit
  }.

  Definition WP := WP2.

End ModNEnv.