Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metalib.Metatheory.
Require Export Metalib.LibLNgen.

Require Export Stlc.

(** NOTE: Auxiliary theorems are hidden in generated documentation.
    In general, there is a [_rec] version of every lemma involving
    [open] and [close]. *)

(* *********************************************************************** *)
(** * Induction principles for nonterminals *)

Scheme typ_ind' := Induction for typ Sort Prop.

Definition typ_mutind :=
  fun H1 H2 H3 =>
  typ_ind' H1 H2 H3.

Scheme typ_rec' := Induction for typ Sort Set.

Definition typ_mutrec :=
  fun H1 H2 H3 =>
  typ_rec' H1 H2 H3.

Scheme exp_ind' := Induction for exp Sort Prop.

Definition exp_mutind :=
  fun H1 H2 H3 H4 H5 =>
  exp_ind' H1 H2 H3 H4 H5.

Scheme exp_rec' := Induction for exp Sort Set.

Definition exp_mutrec :=
  fun H1 H2 H3 H4 H5 =>
  exp_rec' H1 H2 H3 H4 H5.

(* *********************************************************************** *)
(** * Close *)

Fixpoint close_exp_wrt_exp_rec (n1 : nat) (x1 : var) (e1 : exp) {struct e1} : exp :=
  match e1 with
    | var_f x2 => if (x1 == x2) then (var_b n1) else (var_f x2)
    | var_b n2 => if (lt_ge_dec n2 n1) then (var_b n2) else (var_b (S n2))
    | abs e2 => abs (close_exp_wrt_exp_rec (S n1) x1 e2)
    | app e2 e3 => app (close_exp_wrt_exp_rec n1 x1 e2) (close_exp_wrt_exp_rec n1 x1 e3)
  end.

Definition close_exp_wrt_exp x1 e1 := close_exp_wrt_exp_rec 0 x1 e1.

(* *********************************************************************** *)
(** * Size *)

Fixpoint size_typ (T1 : typ) {struct T1} : nat :=
  match T1 with
    | typ_base => 1
    | typ_arrow T2 T3 => 1 + (size_typ T2) + (size_typ T3)
  end.

Fixpoint size_exp (e1 : exp) {struct e1} : nat :=
  match e1 with
    | var_f x1 => 1
    | var_b n1 => 1
    | abs e2 => 1 + (size_exp e2)
    | app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
  end.

(* *********************************************************************** *)
(** * Degree *)

(** These define only an upper bound, not a strict upper bound. *)

Inductive degree_exp_wrt_exp : nat -> exp -> Prop :=
  | degree_wrt_exp_var_f : forall n1 x1,
    degree_exp_wrt_exp n1 (var_f x1)
  | degree_wrt_exp_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_exp_wrt_exp n1 (var_b n2)
  | degree_wrt_exp_abs : forall n1 e1,
    degree_exp_wrt_exp (S n1) e1 ->
    degree_exp_wrt_exp n1 (abs e1)
  | degree_wrt_exp_app : forall n1 e1 e2,
    degree_exp_wrt_exp n1 e1 ->
    degree_exp_wrt_exp n1 e2 ->
    degree_exp_wrt_exp n1 (app e1 e2).

Scheme degree_exp_wrt_exp_ind' := Induction for degree_exp_wrt_exp Sort Prop.

Definition degree_exp_wrt_exp_mutind :=
  fun H1 H2 H3 H4 H5 =>
  degree_exp_wrt_exp_ind' H1 H2 H3 H4 H5.

#[export] Hint Constructors degree_exp_wrt_exp : core lngen.

(* *********************************************************************** *)
(** * Local closure (version in [Set], induction principles) *)

Inductive lc_set_exp : exp -> Set :=
  | lc_set_var_f : forall x1,
    lc_set_exp (var_f x1)
  | lc_set_abs : forall e1,
    (forall x1 : var, lc_set_exp (open_exp_wrt_exp e1 (var_f x1))) ->
    lc_set_exp (abs e1)
  | lc_set_app : forall e1 e2,
    lc_set_exp e1 ->
    lc_set_exp e2 ->
    lc_set_exp (app e1 e2).

Scheme lc_exp_ind' := Induction for lc_exp Sort Prop.

Definition lc_exp_mutind :=
  fun H1 H2 H3 H4 =>
  lc_exp_ind' H1 H2 H3 H4.

Scheme lc_set_exp_ind' := Induction for lc_set_exp Sort Prop.

Definition lc_set_exp_mutind :=
  fun H1 H2 H3 H4 =>
  lc_set_exp_ind' H1 H2 H3 H4.

Scheme lc_set_exp_rec' := Induction for lc_set_exp Sort Set.

Definition lc_set_exp_mutrec :=
  fun H1 H2 H3 H4 =>
  lc_set_exp_rec' H1 H2 H3 H4.

#[export] Hint Constructors lc_exp : core lngen.

#[export] Hint Constructors lc_set_exp : core lngen.

(* *********************************************************************** *)
(** * Body *)

Definition body_exp_wrt_exp e1 := forall x1, lc_exp (open_exp_wrt_exp e1 (var_f x1)).

#[export] Hint Unfold body_exp_wrt_exp : core.

(* *********************************************************************** *)
(** * Tactic support *)

(** Additional hint declarations. *)

#[export] Hint Resolve plus_le_compat : lngen.

(** Redefine some tactics. *)

Ltac default_case_split ::=
  first
    [ progress destruct_notin
    | progress destruct_sum
    | progress safe_f_equal
    ].

(* *********************************************************************** *)
(** * Theorems about [size] *)

Ltac default_auto ::= auto with arith lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma size_typ_min_mutual :
(forall T1, 1 <= size_typ T1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_typ_min :
forall T1, 1 <= size_typ T1.
Proof.
pose proof size_typ_min_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve size_typ_min : lngen.

(* begin hide *)

Lemma size_exp_min_mutual :
(forall e1, 1 <= size_exp e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma size_exp_min :
forall e1, 1 <= size_exp e1.
Proof.
pose proof size_exp_min_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve size_exp_min : lngen.

(* begin hide *)

Lemma size_exp_close_exp_wrt_exp_rec_mutual :
(forall e1 x1 n1,
  size_exp (close_exp_wrt_exp_rec n1 x1 e1) = size_exp e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_exp_close_exp_wrt_exp_rec :
forall e1 x1 n1,
  size_exp (close_exp_wrt_exp_rec n1 x1 e1) = size_exp e1.
Proof.
pose proof size_exp_close_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve size_exp_close_exp_wrt_exp_rec : lngen.
#[export] Hint Rewrite size_exp_close_exp_wrt_exp_rec using solve [auto] : lngen.

(* end hide *)

Lemma size_exp_close_exp_wrt_exp :
forall e1 x1,
  size_exp (close_exp_wrt_exp x1 e1) = size_exp e1.
Proof.
unfold close_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve size_exp_close_exp_wrt_exp : lngen.
#[export] Hint Rewrite size_exp_close_exp_wrt_exp using solve [auto] : lngen.

(* begin hide *)

Lemma size_exp_open_exp_wrt_exp_rec_mutual :
(forall e1 e2 n1,
  size_exp e1 <= size_exp (open_exp_wrt_exp_rec n1 e2 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_exp_open_exp_wrt_exp_rec :
forall e1 e2 n1,
  size_exp e1 <= size_exp (open_exp_wrt_exp_rec n1 e2 e1).
Proof.
pose proof size_exp_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve size_exp_open_exp_wrt_exp_rec : lngen.

(* end hide *)

Lemma size_exp_open_exp_wrt_exp :
forall e1 e2,
  size_exp e1 <= size_exp (open_exp_wrt_exp e1 e2).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve size_exp_open_exp_wrt_exp : lngen.

(* begin hide *)

Lemma size_exp_open_exp_wrt_exp_rec_var_mutual :
(forall e1 x1 n1,
  size_exp (open_exp_wrt_exp_rec n1 (var_f x1) e1) = size_exp e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma size_exp_open_exp_wrt_exp_rec_var :
forall e1 x1 n1,
  size_exp (open_exp_wrt_exp_rec n1 (var_f x1) e1) = size_exp e1.
Proof.
pose proof size_exp_open_exp_wrt_exp_rec_var_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve size_exp_open_exp_wrt_exp_rec_var : lngen.
#[export] Hint Rewrite size_exp_open_exp_wrt_exp_rec_var using solve [auto] : lngen.

(* end hide *)

Lemma size_exp_open_exp_wrt_exp_var :
forall e1 x1,
  size_exp (open_exp_wrt_exp e1 (var_f x1)) = size_exp e1.
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve size_exp_open_exp_wrt_exp_var : lngen.
#[export] Hint Rewrite size_exp_open_exp_wrt_exp_var using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [degree] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma degree_exp_wrt_exp_S_mutual :
(forall n1 e1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp (S n1) e1).
Proof.
apply_mutual_ind degree_exp_wrt_exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma degree_exp_wrt_exp_S :
forall n1 e1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp (S n1) e1.
Proof.
pose proof degree_exp_wrt_exp_S_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_S : lngen.

Lemma degree_exp_wrt_exp_O :
forall n1 e1,
  degree_exp_wrt_exp O e1 ->
  degree_exp_wrt_exp n1 e1.
Proof.
induction n1; default_simp.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_O : lngen.

(* begin hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp_rec_mutual :
(forall e1 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp (S n1) (close_exp_wrt_exp_rec n1 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp_rec :
forall e1 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp (S n1) (close_exp_wrt_exp_rec n1 x1 e1).
Proof.
pose proof degree_exp_wrt_exp_close_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_close_exp_wrt_exp_rec : lngen.

(* end hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp :
forall e1 x1,
  degree_exp_wrt_exp 0 e1 ->
  degree_exp_wrt_exp 1 (close_exp_wrt_exp x1 e1).
Proof.
unfold close_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_close_exp_wrt_exp : lngen.

(* begin hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv_mutual :
(forall e1 x1 n1,
  degree_exp_wrt_exp (S n1) (close_exp_wrt_exp_rec n1 x1 e1) ->
  degree_exp_wrt_exp n1 e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv :
forall e1 x1 n1,
  degree_exp_wrt_exp (S n1) (close_exp_wrt_exp_rec n1 x1 e1) ->
  degree_exp_wrt_exp n1 e1.
Proof.
pose proof degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv_mutual as H; intuition eauto.
Qed.

#[export] Hint Immediate degree_exp_wrt_exp_close_exp_wrt_exp_rec_inv : lngen.

(* end hide *)

Lemma degree_exp_wrt_exp_close_exp_wrt_exp_inv :
forall e1 x1,
  degree_exp_wrt_exp 1 (close_exp_wrt_exp x1 e1) ->
  degree_exp_wrt_exp 0 e1.
Proof.
unfold close_exp_wrt_exp; eauto with lngen.
Qed.

#[export] Hint Immediate degree_exp_wrt_exp_close_exp_wrt_exp_inv : lngen.

(* begin hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp_rec_mutual :
(forall e1 e2 n1,
  degree_exp_wrt_exp (S n1) e1 ->
  degree_exp_wrt_exp n1 e2 ->
  degree_exp_wrt_exp n1 (open_exp_wrt_exp_rec n1 e2 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp_rec :
forall e1 e2 n1,
  degree_exp_wrt_exp (S n1) e1 ->
  degree_exp_wrt_exp n1 e2 ->
  degree_exp_wrt_exp n1 (open_exp_wrt_exp_rec n1 e2 e1).
Proof.
pose proof degree_exp_wrt_exp_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_open_exp_wrt_exp_rec : lngen.

(* end hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp :
forall e1 e2,
  degree_exp_wrt_exp 1 e1 ->
  degree_exp_wrt_exp 0 e2 ->
  degree_exp_wrt_exp 0 (open_exp_wrt_exp e1 e2).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_open_exp_wrt_exp : lngen.

(* begin hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv_mutual :
(forall e1 e2 n1,
  degree_exp_wrt_exp n1 (open_exp_wrt_exp_rec n1 e2 e1) ->
  degree_exp_wrt_exp (S n1) e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv :
forall e1 e2 n1,
  degree_exp_wrt_exp n1 (open_exp_wrt_exp_rec n1 e2 e1) ->
  degree_exp_wrt_exp (S n1) e1.
Proof.
pose proof degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv_mutual as H; intuition eauto.
Qed.

#[export] Hint Immediate degree_exp_wrt_exp_open_exp_wrt_exp_rec_inv : lngen.

(* end hide *)

Lemma degree_exp_wrt_exp_open_exp_wrt_exp_inv :
forall e1 e2,
  degree_exp_wrt_exp 0 (open_exp_wrt_exp e1 e2) ->
  degree_exp_wrt_exp 1 e1.
Proof.
unfold open_exp_wrt_exp; eauto with lngen.
Qed.

#[export] Hint Immediate degree_exp_wrt_exp_open_exp_wrt_exp_inv : lngen.

(* *********************************************************************** *)
(** * Theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_exp_wrt_exp_rec_inj_mutual :
(forall e1 e2 x1 n1,
  close_exp_wrt_exp_rec n1 x1 e1 = close_exp_wrt_exp_rec n1 x1 e2 ->
  e1 = e2).
Proof.
apply_mutual_ind exp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_exp_wrt_exp_rec_inj :
forall e1 e2 x1 n1,
  close_exp_wrt_exp_rec n1 x1 e1 = close_exp_wrt_exp_rec n1 x1 e2 ->
  e1 = e2.
Proof.
pose proof close_exp_wrt_exp_rec_inj_mutual as H; intuition eauto.
Qed.

#[export] Hint Immediate close_exp_wrt_exp_rec_inj : lngen.

(* end hide *)

Lemma close_exp_wrt_exp_inj :
forall e1 e2 x1,
  close_exp_wrt_exp x1 e1 = close_exp_wrt_exp x1 e2 ->
  e1 = e2.
Proof.
unfold close_exp_wrt_exp; eauto with lngen.
Qed.

#[export] Hint Immediate close_exp_wrt_exp_inj : lngen.

(* begin hide *)

Lemma close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual :
(forall e1 x1 n1,
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp_rec n1 x1 (open_exp_wrt_exp_rec n1 (var_f x1) e1) = e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_exp_wrt_exp_rec_open_exp_wrt_exp_rec :
forall e1 x1 n1,
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp_rec n1 x1 (open_exp_wrt_exp_rec n1 (var_f x1) e1) = e1.
Proof.
pose proof close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve close_exp_wrt_exp_rec_open_exp_wrt_exp_rec : lngen.
#[export] Hint Rewrite close_exp_wrt_exp_rec_open_exp_wrt_exp_rec using solve [auto] : lngen.

(* end hide *)

Lemma close_exp_wrt_exp_open_exp_wrt_exp :
forall e1 x1,
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp x1 (open_exp_wrt_exp e1 (var_f x1)) = e1.
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve close_exp_wrt_exp_open_exp_wrt_exp : lngen.
#[export] Hint Rewrite close_exp_wrt_exp_open_exp_wrt_exp using solve [auto] : lngen.

(* begin hide *)

Lemma open_exp_wrt_exp_rec_close_exp_wrt_exp_rec_mutual :
(forall e1 x1 n1,
  open_exp_wrt_exp_rec n1 (var_f x1) (close_exp_wrt_exp_rec n1 x1 e1) = e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_exp_wrt_exp_rec_close_exp_wrt_exp_rec :
forall e1 x1 n1,
  open_exp_wrt_exp_rec n1 (var_f x1) (close_exp_wrt_exp_rec n1 x1 e1) = e1.
Proof.
pose proof open_exp_wrt_exp_rec_close_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve open_exp_wrt_exp_rec_close_exp_wrt_exp_rec : lngen.
#[export] Hint Rewrite open_exp_wrt_exp_rec_close_exp_wrt_exp_rec using solve [auto] : lngen.

(* end hide *)

Lemma open_exp_wrt_exp_close_exp_wrt_exp :
forall e1 x1,
  open_exp_wrt_exp (close_exp_wrt_exp x1 e1) (var_f x1) = e1.
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve open_exp_wrt_exp_close_exp_wrt_exp : lngen.
#[export] Hint Rewrite open_exp_wrt_exp_close_exp_wrt_exp using solve [auto] : lngen.

(* begin hide *)

Lemma open_exp_wrt_exp_rec_inj_mutual :
(forall e2 e1 x1 n1,
  x1 `notin` fv_exp e2 ->
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp_rec n1 (var_f x1) e2 = open_exp_wrt_exp_rec n1 (var_f x1) e1 ->
  e2 = e1).
Proof.
apply_mutual_ind exp_mutind;
intros; match goal with
          | |- _ = ?term => destruct term
        end;
default_simp; eauto with lngen.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_exp_wrt_exp_rec_inj :
forall e2 e1 x1 n1,
  x1 `notin` fv_exp e2 ->
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp_rec n1 (var_f x1) e2 = open_exp_wrt_exp_rec n1 (var_f x1) e1 ->
  e2 = e1.
Proof.
pose proof open_exp_wrt_exp_rec_inj_mutual as H; intuition eauto.
Qed.

#[export] Hint Immediate open_exp_wrt_exp_rec_inj : lngen.

(* end hide *)

Lemma open_exp_wrt_exp_inj :
forall e2 e1 x1,
  x1 `notin` fv_exp e2 ->
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp e2 (var_f x1) = open_exp_wrt_exp e1 (var_f x1) ->
  e2 = e1.
Proof.
unfold open_exp_wrt_exp; eauto with lngen.
Qed.

#[export] Hint Immediate open_exp_wrt_exp_inj : lngen.

(* *********************************************************************** *)
(** * Theorems about [lc] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma degree_exp_wrt_exp_of_lc_exp_mutual :
(forall e1,
  lc_exp e1 ->
  degree_exp_wrt_exp 0 e1).
Proof.
apply_mutual_ind lc_exp_mutind;
intros;
let x1 := fresh "x1" in pick_fresh x1;
repeat (match goal with
          | H1 : _, H2 : _ |- _ => specialize H1 with H2
        end);
default_simp; eauto with lngen.
Qed.

(* end hide *)

Lemma degree_exp_wrt_exp_of_lc_exp :
forall e1,
  lc_exp e1 ->
  degree_exp_wrt_exp 0 e1.
Proof.
pose proof degree_exp_wrt_exp_of_lc_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve degree_exp_wrt_exp_of_lc_exp : lngen.

(* begin hide *)

Lemma lc_exp_of_degree_size_mutual :
forall i1,
(forall e1,
  size_exp e1 = i1 ->
  degree_exp_wrt_exp 0 e1 ->
  lc_exp e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind exp_mutind;
default_simp;
(* non-trivial cases *)
constructor; default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_exp_of_degree :
forall e1,
  degree_exp_wrt_exp 0 e1 ->
  lc_exp e1.
Proof.
intros e1; intros;
pose proof (lc_exp_of_degree_size_mutual (size_exp e1));
intuition eauto.
Qed.

#[export] Hint Resolve lc_exp_of_degree : lngen.

Ltac typ_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              fail 1
          end).

Ltac exp_lc_exists_tac :=
  repeat (match goal with
            | H : _ |- _ =>
              let J1 := fresh in pose proof H as J1; apply degree_exp_wrt_exp_of_lc_exp in J1; clear H
          end).

Lemma lc_abs_exists :
forall x1 e1,
  lc_exp (open_exp_wrt_exp e1 (var_f x1)) ->
  lc_exp (abs e1).
Proof.
intros; exp_lc_exists_tac; eauto 6 with lngen.
Qed.

#[export] Hint Extern 1 (lc_exp (abs _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_abs_exists x1) : core.

Lemma lc_body_exp_wrt_exp :
forall e1 e2,
  body_exp_wrt_exp e1 ->
  lc_exp e2 ->
  lc_exp (open_exp_wrt_exp e1 e2).
Proof.
unfold body_exp_wrt_exp;
default_simp;
let x1 := fresh "x" in
pick_fresh x1;
specialize_all x1;
exp_lc_exists_tac;
eauto 7 with lngen.
Qed.

#[export] Hint Resolve lc_body_exp_wrt_exp : lngen.

Lemma lc_body_abs_1 :
forall e1,
  lc_exp (abs e1) ->
  body_exp_wrt_exp e1.
Proof.
default_simp.
Qed.

#[export] Hint Resolve lc_body_abs_1 : lngen.

(* begin hide *)

Lemma lc_exp_unique_mutual :
(forall e1 (proof2 proof3 : lc_exp e1), proof2 = proof3).
Proof.
apply_mutual_ind lc_exp_mutind;
intros;
let proof1 := fresh "proof1" in
rename_last_into proof1; dependent destruction proof1;
f_equal; default_simp; auto using @functional_extensionality_dep with lngen.
Qed.

(* end hide *)

Lemma lc_exp_unique :
forall e1 (proof2 proof3 : lc_exp e1), proof2 = proof3.
Proof.
pose proof lc_exp_unique_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve lc_exp_unique : lngen.

(* begin hide *)

Lemma lc_exp_of_lc_set_exp_mutual :
(forall e1, lc_set_exp e1 -> lc_exp e1).
Proof.
apply_mutual_ind lc_set_exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma lc_exp_of_lc_set_exp :
forall e1, lc_set_exp e1 -> lc_exp e1.
Proof.
pose proof lc_exp_of_lc_set_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve lc_exp_of_lc_set_exp : lngen.

(* begin hide *)

Lemma lc_set_exp_of_lc_exp_size_mutual :
forall i1,
(forall e1,
  size_exp e1 = i1 ->
  lc_exp e1 ->
  lc_set_exp e1).
Proof.
intros i1; pattern i1; apply lt_wf_rec;
clear i1; intros i1 H1;
apply_mutual_ind exp_mutrec;
default_simp;
try solve [assert False by default_simp; tauto];
(* non-trivial cases *)
constructor; default_simp;
try first [apply lc_set_exp_of_lc_exp];
default_simp; eapply_first_lt_hyp;
(* instantiate the size *)
match goal with
  | |- _ = _ => reflexivity
  | _ => idtac
end;
instantiate;
(* everything should be easy now *)
default_simp.
Qed.

(* end hide *)

Lemma lc_set_exp_of_lc_exp :
forall e1,
  lc_exp e1 ->
  lc_set_exp e1.
Proof.
intros e1; intros;
pose proof (lc_set_exp_of_lc_exp_size_mutual (size_exp e1));
intuition eauto.
Qed.

#[export] Hint Resolve lc_set_exp_of_lc_exp : lngen.

(* *********************************************************************** *)
(** * More theorems about [open] and [close] *)

Ltac default_auto ::= auto with lngen; tauto.
Ltac default_autorewrite ::= fail.

(* begin hide *)

Lemma close_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual :
(forall e1 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp_rec n1 x1 e1 = e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma close_exp_wrt_exp_rec_degree_exp_wrt_exp :
forall e1 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp_rec n1 x1 e1 = e1.
Proof.
pose proof close_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve close_exp_wrt_exp_rec_degree_exp_wrt_exp : lngen.
#[export] Hint Rewrite close_exp_wrt_exp_rec_degree_exp_wrt_exp using solve [auto] : lngen.

(* end hide *)

Lemma close_exp_wrt_exp_lc_exp :
forall e1 x1,
  lc_exp e1 ->
  x1 `notin` fv_exp e1 ->
  close_exp_wrt_exp x1 e1 = e1.
Proof.
unfold close_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve close_exp_wrt_exp_lc_exp : lngen.
#[export] Hint Rewrite close_exp_wrt_exp_lc_exp using solve [auto] : lngen.

(* begin hide *)

Lemma open_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual :
(forall e2 e1 n1,
  degree_exp_wrt_exp n1 e2 ->
  open_exp_wrt_exp_rec n1 e1 e2 = e2).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma open_exp_wrt_exp_rec_degree_exp_wrt_exp :
forall e2 e1 n1,
  degree_exp_wrt_exp n1 e2 ->
  open_exp_wrt_exp_rec n1 e1 e2 = e2.
Proof.
pose proof open_exp_wrt_exp_rec_degree_exp_wrt_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve open_exp_wrt_exp_rec_degree_exp_wrt_exp : lngen.
#[export] Hint Rewrite open_exp_wrt_exp_rec_degree_exp_wrt_exp using solve [auto] : lngen.

(* end hide *)

Lemma open_exp_wrt_exp_lc_exp :
forall e2 e1,
  lc_exp e2 ->
  open_exp_wrt_exp e2 e1 = e2.
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve open_exp_wrt_exp_lc_exp : lngen.
#[export] Hint Rewrite open_exp_wrt_exp_lc_exp using solve [auto] : lngen.

(* *********************************************************************** *)
(** * Theorems about [fv] *)

Ltac default_auto ::= auto with set lngen; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma fv_exp_close_exp_wrt_exp_rec_mutual :
(forall e1 x1 n1,
  fv_exp (close_exp_wrt_exp_rec n1 x1 e1) [=] remove x1 (fv_exp e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_exp_close_exp_wrt_exp_rec :
forall e1 x1 n1,
  fv_exp (close_exp_wrt_exp_rec n1 x1 e1) [=] remove x1 (fv_exp e1).
Proof.
pose proof fv_exp_close_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_close_exp_wrt_exp_rec : lngen.
#[export] Hint Rewrite fv_exp_close_exp_wrt_exp_rec using solve [auto] : lngen.

(* end hide *)

Lemma fv_exp_close_exp_wrt_exp :
forall e1 x1,
  fv_exp (close_exp_wrt_exp x1 e1) [=] remove x1 (fv_exp e1).
Proof.
unfold close_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve fv_exp_close_exp_wrt_exp : lngen.
#[export] Hint Rewrite fv_exp_close_exp_wrt_exp using solve [auto] : lngen.

(* begin hide *)

Lemma fv_exp_open_exp_wrt_exp_rec_lower_mutual :
(forall e1 e2 n1,
  fv_exp e1 [<=] fv_exp (open_exp_wrt_exp_rec n1 e2 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_exp_open_exp_wrt_exp_rec_lower :
forall e1 e2 n1,
  fv_exp e1 [<=] fv_exp (open_exp_wrt_exp_rec n1 e2 e1).
Proof.
pose proof fv_exp_open_exp_wrt_exp_rec_lower_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_open_exp_wrt_exp_rec_lower : lngen.

(* end hide *)

Lemma fv_exp_open_exp_wrt_exp_lower :
forall e1 e2,
  fv_exp e1 [<=] fv_exp (open_exp_wrt_exp e1 e2).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve fv_exp_open_exp_wrt_exp_lower : lngen.

(* begin hide *)

Lemma fv_exp_open_exp_wrt_exp_rec_upper_mutual :
(forall e1 e2 n1,
  fv_exp (open_exp_wrt_exp_rec n1 e2 e1) [<=] fv_exp e2 `union` fv_exp e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

(* begin hide *)

Lemma fv_exp_open_exp_wrt_exp_rec_upper :
forall e1 e2 n1,
  fv_exp (open_exp_wrt_exp_rec n1 e2 e1) [<=] fv_exp e2 `union` fv_exp e1.
Proof.
pose proof fv_exp_open_exp_wrt_exp_rec_upper_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_open_exp_wrt_exp_rec_upper : lngen.

(* end hide *)

Lemma fv_exp_open_exp_wrt_exp_upper :
forall e1 e2,
  fv_exp (open_exp_wrt_exp e1 e2) [<=] fv_exp e2 `union` fv_exp e1.
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve fv_exp_open_exp_wrt_exp_upper : lngen.

(* begin hide *)

Lemma fv_exp_subst_exp_fresh_mutual :
(forall e1 e2 x1,
  x1 `notin` fv_exp e1 ->
  fv_exp (subst_exp e2 x1 e1) [=] fv_exp e1).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_exp_subst_exp_fresh :
forall e1 e2 x1,
  x1 `notin` fv_exp e1 ->
  fv_exp (subst_exp e2 x1 e1) [=] fv_exp e1.
Proof.
pose proof fv_exp_subst_exp_fresh_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_subst_exp_fresh : lngen.
#[export] Hint Rewrite fv_exp_subst_exp_fresh using solve [auto] : lngen.

(* begin hide *)

Lemma fv_exp_subst_exp_lower_mutual :
(forall e1 e2 x1,
  remove x1 (fv_exp e1) [<=] fv_exp (subst_exp e2 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_exp_subst_exp_lower :
forall e1 e2 x1,
  remove x1 (fv_exp e1) [<=] fv_exp (subst_exp e2 x1 e1).
Proof.
pose proof fv_exp_subst_exp_lower_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_subst_exp_lower : lngen.

(* begin hide *)

Lemma fv_exp_subst_exp_notin_mutual :
(forall e1 e2 x1 x2,
  x2 `notin` fv_exp e1 ->
  x2 `notin` fv_exp e2 ->
  x2 `notin` fv_exp (subst_exp e2 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_exp_subst_exp_notin :
forall e1 e2 x1 x2,
  x2 `notin` fv_exp e1 ->
  x2 `notin` fv_exp e2 ->
  x2 `notin` fv_exp (subst_exp e2 x1 e1).
Proof.
pose proof fv_exp_subst_exp_notin_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_subst_exp_notin : lngen.

(* begin hide *)

Lemma fv_exp_subst_exp_upper_mutual :
(forall e1 e2 x1,
  fv_exp (subst_exp e2 x1 e1) [<=] fv_exp e2 `union` remove x1 (fv_exp e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp; fsetdec.
Qed.

(* end hide *)

Lemma fv_exp_subst_exp_upper :
forall e1 e2 x1,
  fv_exp (subst_exp e2 x1 e1) [<=] fv_exp e2 `union` remove x1 (fv_exp e1).
Proof.
pose proof fv_exp_subst_exp_upper_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve fv_exp_subst_exp_upper : lngen.

(* *********************************************************************** *)
(** * Theorems about [subst] *)

Ltac default_auto ::= auto with lngen brute_force; tauto.
Ltac default_autorewrite ::= autorewrite with lngen.

(* begin hide *)

Lemma subst_exp_close_exp_wrt_exp_rec_mutual :
(forall e2 e1 x1 x2 n1,
  degree_exp_wrt_exp n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_exp e1 ->
  subst_exp e1 x1 (close_exp_wrt_exp_rec n1 x2 e2) = close_exp_wrt_exp_rec n1 x2 (subst_exp e1 x1 e2)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_close_exp_wrt_exp_rec :
forall e2 e1 x1 x2 n1,
  degree_exp_wrt_exp n1 e1 ->
  x1 <> x2 ->
  x2 `notin` fv_exp e1 ->
  subst_exp e1 x1 (close_exp_wrt_exp_rec n1 x2 e2) = close_exp_wrt_exp_rec n1 x2 (subst_exp e1 x1 e2).
Proof.
pose proof subst_exp_close_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_close_exp_wrt_exp_rec : lngen.

Lemma subst_exp_close_exp_wrt_exp :
forall e2 e1 x1 x2,
  lc_exp e1 ->  x1 <> x2 ->
  x2 `notin` fv_exp e1 ->
  subst_exp e1 x1 (close_exp_wrt_exp x2 e2) = close_exp_wrt_exp x2 (subst_exp e1 x1 e2).
Proof.
unfold close_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_close_exp_wrt_exp : lngen.

(* begin hide *)

Lemma subst_exp_degree_exp_wrt_exp_mutual :
(forall e1 e2 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp n1 e2 ->
  degree_exp_wrt_exp n1 (subst_exp e2 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_degree_exp_wrt_exp :
forall e1 e2 x1 n1,
  degree_exp_wrt_exp n1 e1 ->
  degree_exp_wrt_exp n1 e2 ->
  degree_exp_wrt_exp n1 (subst_exp e2 x1 e1).
Proof.
pose proof subst_exp_degree_exp_wrt_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_degree_exp_wrt_exp : lngen.

(* begin hide *)

Lemma subst_exp_fresh_eq_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_exp e2 ->
  subst_exp e1 x1 e2 = e2).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_fresh_eq :
forall e2 e1 x1,
  x1 `notin` fv_exp e2 ->
  subst_exp e1 x1 e2 = e2.
Proof.
pose proof subst_exp_fresh_eq_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_fresh_eq : lngen.
#[export] Hint Rewrite subst_exp_fresh_eq using solve [auto] : lngen.

(* begin hide *)

Lemma subst_exp_fresh_same_mutual :
(forall e2 e1 x1,
  x1 `notin` fv_exp e1 ->
  x1 `notin` fv_exp (subst_exp e1 x1 e2)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_fresh_same :
forall e2 e1 x1,
  x1 `notin` fv_exp e1 ->
  x1 `notin` fv_exp (subst_exp e1 x1 e2).
Proof.
pose proof subst_exp_fresh_same_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_fresh_same : lngen.

(* begin hide *)

Lemma subst_exp_fresh_mutual :
(forall e2 e1 x1 x2,
  x1 `notin` fv_exp e2 ->
  x1 `notin` fv_exp e1 ->
  x1 `notin` fv_exp (subst_exp e1 x2 e2)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_fresh :
forall e2 e1 x1 x2,
  x1 `notin` fv_exp e2 ->
  x1 `notin` fv_exp e1 ->
  x1 `notin` fv_exp (subst_exp e1 x2 e2).
Proof.
pose proof subst_exp_fresh_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_fresh : lngen.

Lemma subst_exp_lc_exp :
forall e1 e2 x1,
  lc_exp e1 ->
  lc_exp e2 ->
  lc_exp (subst_exp e2 x1 e1).
Proof.
default_simp.
Qed.

#[export] Hint Resolve subst_exp_lc_exp : lngen.

(* begin hide *)

Lemma subst_exp_open_exp_wrt_exp_rec_mutual :
(forall e3 e1 e2 x1 n1,
  lc_exp e1 ->
  subst_exp e1 x1 (open_exp_wrt_exp_rec n1 e2 e3) = open_exp_wrt_exp_rec n1 (subst_exp e1 x1 e2) (subst_exp e1 x1 e3)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_exp_open_exp_wrt_exp_rec :
forall e3 e1 e2 x1 n1,
  lc_exp e1 ->
  subst_exp e1 x1 (open_exp_wrt_exp_rec n1 e2 e3) = open_exp_wrt_exp_rec n1 (subst_exp e1 x1 e2) (subst_exp e1 x1 e3).
Proof.
pose proof subst_exp_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_open_exp_wrt_exp_rec : lngen.

(* end hide *)

Lemma subst_exp_open_exp_wrt_exp :
forall e3 e1 e2 x1,
  lc_exp e1 ->
  subst_exp e1 x1 (open_exp_wrt_exp e3 e2) = open_exp_wrt_exp (subst_exp e1 x1 e3) (subst_exp e1 x1 e2).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_open_exp_wrt_exp : lngen.

Lemma subst_exp_open_exp_wrt_exp_var :
forall e2 e1 x1 x2,
  x1 <> x2 ->
  lc_exp e1 ->
  open_exp_wrt_exp (subst_exp e1 x1 e2) (var_f x2) = subst_exp e1 x1 (open_exp_wrt_exp e2 (var_f x2)).
Proof.
intros; rewrite subst_exp_open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_open_exp_wrt_exp_var : lngen.

(* begin hide *)

Lemma subst_exp_spec_rec_mutual :
(forall e1 e2 x1 n1,
  subst_exp e2 x1 e1 = open_exp_wrt_exp_rec n1 e2 (close_exp_wrt_exp_rec n1 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_exp_spec_rec :
forall e1 e2 x1 n1,
  subst_exp e2 x1 e1 = open_exp_wrt_exp_rec n1 e2 (close_exp_wrt_exp_rec n1 x1 e1).
Proof.
pose proof subst_exp_spec_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_spec_rec : lngen.

(* end hide *)

Lemma subst_exp_spec :
forall e1 e2 x1,
  subst_exp e2 x1 e1 = open_exp_wrt_exp (close_exp_wrt_exp x1 e1) e2.
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_spec : lngen.

(* begin hide *)

Lemma subst_exp_subst_exp_mutual :
(forall e1 e2 e3 x2 x1,
  x2 `notin` fv_exp e2 ->
  x2 <> x1 ->
  subst_exp e2 x1 (subst_exp e3 x2 e1) = subst_exp (subst_exp e2 x1 e3) x2 (subst_exp e2 x1 e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_subst_exp :
forall e1 e2 e3 x2 x1,
  x2 `notin` fv_exp e2 ->
  x2 <> x1 ->
  subst_exp e2 x1 (subst_exp e3 x2 e1) = subst_exp (subst_exp e2 x1 e3) x2 (subst_exp e2 x1 e1).
Proof.
pose proof subst_exp_subst_exp_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_subst_exp : lngen.

(* begin hide *)

Lemma subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual :
(forall e2 e1 x1 x2 n1,
  x2 `notin` fv_exp e2 ->
  x2 `notin` fv_exp e1 ->
  x2 <> x1 ->
  degree_exp_wrt_exp n1 e1 ->
  subst_exp e1 x1 e2 = close_exp_wrt_exp_rec n1 x2 (subst_exp e1 x1 (open_exp_wrt_exp_rec n1 (var_f x2) e2))).
Proof.
apply_mutual_ind exp_mutrec;
default_simp.
Qed.

(* end hide *)

(* begin hide *)

Lemma subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec :
forall e2 e1 x1 x2 n1,
  x2 `notin` fv_exp e2 ->
  x2 `notin` fv_exp e1 ->
  x2 <> x1 ->
  degree_exp_wrt_exp n1 e1 ->
  subst_exp e1 x1 e2 = close_exp_wrt_exp_rec n1 x2 (subst_exp e1 x1 (open_exp_wrt_exp_rec n1 (var_f x2) e2)).
Proof.
pose proof subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_close_exp_wrt_exp_rec_open_exp_wrt_exp_rec : lngen.

(* end hide *)

Lemma subst_exp_close_exp_wrt_exp_open_exp_wrt_exp :
forall e2 e1 x1 x2,
  x2 `notin` fv_exp e2 ->
  x2 `notin` fv_exp e1 ->
  x2 <> x1 ->
  lc_exp e1 ->
  subst_exp e1 x1 e2 = close_exp_wrt_exp x2 (subst_exp e1 x1 (open_exp_wrt_exp e2 (var_f x2))).
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_close_exp_wrt_exp_open_exp_wrt_exp : lngen.

Lemma subst_exp_abs :
forall x2 e2 e1 x1,
  lc_exp e1 ->
  x2 `notin` fv_exp e1 `union` fv_exp e2 `union` singleton x1 ->
  subst_exp e1 x1 (abs e2) = abs (close_exp_wrt_exp x2 (subst_exp e1 x1 (open_exp_wrt_exp e2 (var_f x2)))).
Proof.
default_simp.
Qed.

#[export] Hint Resolve subst_exp_abs : lngen.

(* begin hide *)

Lemma subst_exp_intro_rec_mutual :
(forall e1 x1 e2 n1,
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp_rec n1 e2 e1 = subst_exp e2 x1 (open_exp_wrt_exp_rec n1 (var_f x1) e1)).
Proof.
apply_mutual_ind exp_mutind;
default_simp.
Qed.

(* end hide *)

Lemma subst_exp_intro_rec :
forall e1 x1 e2 n1,
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp_rec n1 e2 e1 = subst_exp e2 x1 (open_exp_wrt_exp_rec n1 (var_f x1) e1).
Proof.
pose proof subst_exp_intro_rec_mutual as H; intuition eauto.
Qed.

#[export] Hint Resolve subst_exp_intro_rec : lngen.
#[export] Hint Rewrite subst_exp_intro_rec using solve [auto] : lngen.

Lemma subst_exp_intro :
forall x1 e1 e2,
  x1 `notin` fv_exp e1 ->
  open_exp_wrt_exp e1 e2 = subst_exp e2 x1 (open_exp_wrt_exp e1 (var_f x1)).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

#[export] Hint Resolve subst_exp_intro : lngen.

(* *********************************************************************** *)
(** * "Restore" tactics *)

Ltac default_auto ::= auto; tauto.
Ltac default_autorewrite ::= fail.


From PA Require Import ProgramAlgebra.
Import Nat.
Import List.
Require Import String.
Import ListNotations.

Variable bot : Type.

Record MyVar := mkVar {
  id: string;
  val : nat;
}.

Definition eqVarb (x y : MyVar) :=
  andb (eqb x.(id) y.(id)) (PeanoNat.Nat.eqb x.(val) y.(val)).

Definition tt := mkVar "a" 1.

Definition GLOBVARS := [tt;(mkVar "b" 2);(mkVar "c" 3)].

Definition UNDEF := mkVar "Undefined" 0.

Instance myParams : ProgramAlgebra.UserParams :=
  ProgramAlgebra.Build_UserParams MyVar GLOBVARS eqVarb.

Axiom equalGLOB : GLOBVARS = ProgramAlgebra.GLOBVARS.

Axiom equalB : eqVarb = ProgramAlgebra.eqb.

Notation "|-| l" := (ProgramAlgebra.Choice_of_Alg_List l)(at level 20).

Notation "_|_" := (ProgramAlgebra.Chaos)(at level 10).

Notation "@{ e }" := (fun x => ProgramAlgebra.Assn x e)(at level 10).

Fixpoint ascending (l : list (ProgramAlgebra.Var)) : list (ProgramAlgebra.Var) :=
  match l with
  | [] => []
  | h :: tl => (mkVar h.(id) (h.(val) + 1)) :: ascending tl
  end.

Definition cast (a : list MyVar) : list ProgramAlgebra.Var := a.

Definition fstassn := ProgramAlgebra.makeAssign (cast [tt]) ascending.

Definition allassn := ProgramAlgebra.makeAssign ProgramAlgebra.GLOBVARS ascending.

Definition hdge2 : ProgramAlgebra.Boolexp :=
 fun l =>
  match (hd_error l) with
  | None => false
  | Some x => if (PeanoNat.Nat.leb 2 x.(val)) then true else false
  end.

Definition testAlg := ProgramAlgebra.Seq bot (@{fstassn} bot)
  (ProgramAlgebra.Cond bot (@{allassn} bot) hdge2 (@{fstassn} bot)).

Definition testAlg2 := ProgramAlgebra.Cond bot
  (_|_ bot) hdge2
  (ProgramAlgebra.Seq bot
  (|-|[@{fstassn} bot;@{allassn} bot])
  (@{fstassn} bot)).

Definition testassn := ProgramAlgebra.Assn bot
  (ProgramAlgebra.extends_assign
  {|
    ProgramAlgebra.ids := ProgramAlgebra.GLOBVARS;
    ProgramAlgebra.values :=
      fun x =>
      ProgramAlgebra.extends_mapping
        (cast [tt]) ascending
        (ProgramAlgebra.extends_mapping
           (cast [tt]) ascending x)
  |}).

Definition testnf :=
 ProgramAlgebra.Cond bot (_|_ bot) ProgramAlgebra.false_stat (|-| [testassn]).

Lemma nf_assn : testAlg = testassn.
Proof. unfold testAlg. remember (ProgramAlgebra.Cond bot
     (ProgramAlgebra.Assn bot allassn) hdge2
     (ProgramAlgebra.Assn bot fstassn)).
  rewrite (ProgramAlgebra.Assign_extends fstassn) in *.
  unfold ProgramAlgebra.extends_assign in *.
  unfold allassn in Heqa.
  rewrite (ProgramAlgebra.Assign_Cond bot ProgramAlgebra.GLOBVARS ascending) in Heqa.
  rewrite Heqa. rewrite ProgramAlgebra.Assign_compose.
  unfold testassn. rewrite <- equalGLOB. unfold GLOBVARS.
  unfold hdge2. unfold tt. simpl.
  rewrite <- ProgramAlgebra.Assign_extends. auto.
Qed.

Lemma nf : testAlg = testnf.
Proof. rewrite nf_assn. unfold testassn.
  rewrite <- ProgramAlgebra.Assign_extends.
  rewrite (ProgramAlgebra.Assign_to_NF _ _ ProgramAlgebra.false_stat);auto.
Qed.

Definition testassn2_1 := ProgramAlgebra.Assn bot
  {|
    ProgramAlgebra.ids :=
      ProgramAlgebra.GLOBVARS;
    ProgramAlgebra.values :=
      fun x : list ProgramAlgebra.Var =>
      ProgramAlgebra.extends_mapping
        (ProgramAlgebra.ids fstassn)
        (ProgramAlgebra.values fstassn)
        (ProgramAlgebra.extends_mapping
           (ProgramAlgebra.ids fstassn)
           (ProgramAlgebra.values fstassn) x)
  |}.

Definition testassn2_2 := ProgramAlgebra.Assn bot
   {|
     ProgramAlgebra.ids :=
       ProgramAlgebra.GLOBVARS;
     ProgramAlgebra.values :=
       fun x : list ProgramAlgebra.Var =>
       ProgramAlgebra.extends_mapping
         (ProgramAlgebra.ids fstassn)
         (ProgramAlgebra.values fstassn)
         (ascending x)
   |}.

Definition testnf2 :=
  ProgramAlgebra.Cond bot ((_|_) bot) hdge2 (|-|[testassn2_1;testassn2_2]).

Lemma nf2 : testAlg2 = testnf2.
Proof. unfold testAlg2.
  assert ((ProgramAlgebra.Assn bot fstassn) = |-| [(ProgramAlgebra.Assn bot fstassn)]).
  { unfold ProgramAlgebra.Choice_of_Alg_List. rewrite ProgramAlgebra.Choice_zero_r. auto. }
  remember (ProgramAlgebra.Seq bot
     (|-| [ProgramAlgebra.Assn bot fstassn;
           ProgramAlgebra.Assn bot allassn])).
  rewrite H. rewrite Heqa. rewrite ProgramAlgebra.Seq_over_Choice.
  unfold list_prod. simpl. all : rewrite (ProgramAlgebra.Assign_extends fstassn).
  all : unfold allassn. all: unfold ProgramAlgebra.extends_assign.
  do 2 (rewrite ProgramAlgebra.Assign_compose).
  unfold testnf2. unfold ProgramAlgebra.Choice_of_Alg_List.
  auto. all : unfold ProgramAlgebra.CH;intros;try destruct H0;eexists;split;auto.
  all : unfold ProgramAlgebra.Total_Assign. all : try rewrite H0; auto.
  all : try destruct H0;try rewrite e;auto.
  unfold In in i. contradiction. Unshelve. unfold In in H0. contradiction.
Qed.

Example testrefine : ProgramAlgebra.Refine testnf2 testnf.
Proof.
  unfold ProgramAlgebra.Refine. unfold testnf. unfold testnf2.
  do 6 eexists. split;split;try split.
  - reflexivity.
  - unfold ProgramAlgebra.CH. intros. destruct H.
    + eexists. split. rewrite <- H. reflexivity. unfold ProgramAlgebra.Total_Assign.
      auto.
    + destruct H;try contradiction. eexists. split. rewrite <- H. reflexivity.
      unfold ProgramAlgebra.Total_Assign. auto.
  - reflexivity.
  - split. reflexivity. unfold ProgramAlgebra.CH.
    intros. destruct H;try contradiction.
    rewrite <- H. eexists. split;try reflexivity.
    unfold ProgramAlgebra.extends_assign.
    unfold ProgramAlgebra.Total_Assign. auto.
  - unfold ProgramAlgebra.false_stat. unfold ProgramAlgebra.GLOBVARS. simpl.
    left. split;auto. unfold ProgramAlgebra.RefineCH.
    intros. destruct H; try contradiction. eexists.
    split.
    + unfold In. left. reflexivity.
    + rewrite <- H. unfold ProgramAlgebra.eqAssn. unfold ProgramAlgebra.eqEval.
      simpl. intros. auto.
Qed.

Fixpoint hdge2inf {s} (x : ProgramAlgebra.Alg s) : bool :=
  match x with
  | ProgramAlgebra.Assn _ a => hdge2 (a.(ProgramAlgebra.values) a.(ProgramAlgebra.ids))
  | ProgramAlgebra.Choice _ P Q => orb (hdge2inf P) (hdge2inf Q)
  | _ => false
  end.

Fixpoint update {s} (x : ProgramAlgebra.Alg s) : ProgramAlgebra.Alg (ProgramAlgebra.Alg s) :=
  match x with
  | ProgramAlgebra.Assn _ a => @{ {|
      ProgramAlgebra.ids := ProgramAlgebra.GLOBVARS;
      ProgramAlgebra.values :=
        fun x =>
        ProgramAlgebra.extends_mapping
          (cast [tt]) ascending
          (a.(ProgramAlgebra.values) x)
    |} } (ProgramAlgebra.Alg s)
  | ProgramAlgebra.Choice _ P Q =>
      ProgramAlgebra.Choice (ProgramAlgebra.Alg s) (update P) (update Q)
  | _ => |-|[]
  end.

Fixpoint mapid {s} (x : ProgramAlgebra.Alg s) :=
  match x with
  | ProgramAlgebra.Assn _ a => @{a} (ProgramAlgebra.Alg s)
  | ProgramAlgebra.Choice _ P Q =>
     ProgramAlgebra.Choice (ProgramAlgebra.Alg s) (mapid P) (mapid Q)
  | ProgramAlgebra.Chaos _ => _|_ (ProgramAlgebra.Alg s)
  | _ => |-|[]
  end.

Definition testIter {s} (x : ProgramAlgebra.Alg s) :=
  match x with
  | ProgramAlgebra.Cond _ p b t => if hdge2inf t then
         ProgramAlgebra.Cond (ProgramAlgebra.Alg s) (mapid p) b (mapid t)
         else ProgramAlgebra.Cond (ProgramAlgebra.Alg s) (mapid p) b (update t)
  | _ => ProgramAlgebra.Cond (ProgramAlgebra.Alg s)
         (_|_ (ProgramAlgebra.Alg s))
         ProgramAlgebra.false_stat
         (|-| [])
  end.

Definition testRec := ProgramAlgebra.Recur (ProgramAlgebra.Alg bot) testIter.

Search "fix_is_lub".

Variable lub : ProgramAlgebra.Closure -> ProgramAlgebra.Ualg.

Example testlim : testIter testnf = testRec .
Proof. unfold testRec. rewrite ProgramAlgebra.Recur_clos with (lub := lub).
rewrite ProgramAlgebra.fix_is_lub with (lub := lub);auto.
unfold ProgramAlgebra.RecurFix. unfold testnf. unfold testIter.
unfold hdge2inf. unfold testassn. unfold ProgramAlgebra.EqAlg.
unfold mapid. simpl. repeat split;auto.
unfold ProgramAlgebra.eqEval. intros. simpl in *. auto.
unfold ProgramAlgebra.eqEval. intros. auto.
Qed.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job
               prosa.classic.model.arrival.basic.task
               prosa.classic.model.priority
               prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.uni.schedule
               prosa.classic.model.schedule.uni.service
               prosa.classic.model.schedule.uni.basic.platform.
Require Import prosa.classic.model.schedule.uni.nonpreemptive.schedule.
Require Export prosa.classic.model.schedule.uni.limited.platform.definitions.

From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

(** * Platform for fully nonpreemptive model *)
(** In module uni.limited.platform we introduce the notion of whether a job can be preempted
   at a given time (using a predicate can_be_preempted). In this section, we instantiate
   can_be_preempted for the fully nonpreemptive model and prove its correctness. *)
Module FullyNonPreemptivePlatform.

  Import Job SporadicTaskset UniprocessorSchedule Priority
         Service LimitedPreemptionPlatform.

  Section FullyNonPreemptiveModel.

    Context {Task: eqType}.
    Variable task_cost: Task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any arrival sequence with consistent, non-duplicate arrivals. *)
    Variable arr_seq: arrival_sequence Job.
    Hypothesis H_arrival_times_are_consistent: arrival_times_are_consistent job_arrival arr_seq.
    Hypothesis H_arr_seq_is_a_set: arrival_sequence_is_a_set arr_seq.

    (* Next, consider any uniprocessor nonpreemptive schedule of this arrival sequence...*)
    Variable sched: schedule Job.
    Hypothesis H_jobs_come_from_arrival_sequence: jobs_come_from_arrival_sequence sched arr_seq.
    Hypothesis H_nonpreemptive_sched:
      NonpreemptiveSchedule.is_nonpreemptive_schedule job_cost sched.

    (* ... where jobs do not execute before their arrival nor after completion. *)
    Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.
    Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

    (* For simplicity, let's define some local names. *)
    Let job_pending := pending job_arrival job_cost sched.
    Let job_completed_by := completed_by job_cost sched.
    Let job_scheduled_at := scheduled_at sched.

    (* Assume that a job cost cannot be larger than a task cost. *)
    Hypothesis H_job_cost_le_task_cost:
      cost_of_jobs_from_arrival_sequence_le_task_cost
        task_cost job_cost job_task arr_seq.

    (* We say that the model is fully nonpreemptive
       iff every job cannot be preempted until its completion. *)
    Definition can_be_preempted_for_fully_nonpreemptive_model (j: Job) (progr: time) :=
      (progr == 0) || (progr == job_cost j).

    (* Since in a fully nonpreemptive model a job cannot be preempted after
       it starts the execution, job_max_nps is equal to job_cost. *)
    Let job_max_nps (j: Job) := job_cost j.

    (* In order to bound job_max_nps, task_max_nps should be equal to task_cost. *)
    Let task_max_nps (tsk: Task) := task_cost tsk.

    (* Then, we prove that fully_nonpreemptive_model is a correct preemption model... *)
    Lemma fully_nonpreemptive_model_is_correct:
      correct_preemption_model arr_seq sched can_be_preempted_for_fully_nonpreemptive_model.
    Proof.
      intros j; split.
      { move => t.
        rewrite /can_be_preempted_for_fully_nonpreemptive_model Bool.negb_orb -lt0n.
        move => /andP [POS NCOMPL].
        unfold NonpreemptiveSchedule.is_nonpreemptive_schedule in *.
        move: (incremental_service_during _ _ _ _ _ POS) => [ft [/andP [_ LT] [SCHED SERV]]].
        apply H_nonpreemptive_sched with ft.
        { by apply ltnW. }
        { by done. }
        { rewrite /completed_by -ltnNge.
          move: NCOMPL; rewrite neq_ltn; move => /orP [LE|GE]; [by done | exfalso].
          move: GE; rewrite ltnNge; move => /negP GE; apply: GE.
            by eauto 2.
        }
      }
      { intros t NSCHED SCHED.
        rewrite /can_be_preempted_for_fully_nonpreemptive_model.
        apply/orP; left.
        apply/negP; intros CONTR.
        move: CONTR => /negP; rewrite -lt0n; intros POS.
        move: (incremental_service_during _ _ _ _ _ POS) => [ft [/andP [_ LT] [SCHEDn SERV]]].
        move: NSCHED => /negP NSCHED; apply: NSCHED.
        apply H_nonpreemptive_sched with ft.
        { by rewrite -ltnS. }
        { by done. }
        { rewrite /completed_by -ltnNge.
          apply leq_ltn_trans with (service sched j t.+1).
          { by rewrite /service /service_during big_nat_recr //= leq_addr. }
          { rewrite -addn1.
            apply leq_trans with (service sched j t.+2).
            - unfold service, service_during.
              have EQ: (service_at sched j t.+1) = 1.
              { by apply/eqP; rewrite eqb1. }
                by rewrite -EQ -big_nat_recr //=.
            - by eauto 2.
          }
        }
      }
    Qed.

    (* ... and has bounded nonpreemptive regions. *)
    Lemma fully_nonpreemptive_model_is_model_with_bounded_nonpreemptive_regions:
      model_with_bounded_nonpreemptive_segments
        job_cost job_task arr_seq can_be_preempted_for_fully_nonpreemptive_model job_max_nps task_max_nps.
    Proof.
      have F: forall n, n = 0 \/ n > 0.
      { by intros n; destruct n; [left | right]. }
      intros j; split; last split; last split.
      { by done. }
      { by apply/orP; right. }
      { intros ARR.
        rewrite /job_max_nps /task_max_nps.
          by eauto 2.
      }
      { intros progr.
        move: (F (progr)) => [EQ | GT].
        { exists progr; split.
          - by apply/andP; split; [done | rewrite leq_addr].
          - by rewrite /can_be_preempted_for_fully_nonpreemptive_model EQ. }
        { exists (maxn progr (job_cost j)).
          have POS: 0 < job_cost j.
          { by apply leq_trans with progr; last move: H0 => /andP [_ H0]. }
          split.
          { apply/andP; split; first by rewrite leq_maxl.
            rewrite /job_max_nps addnBA; last eauto 2.
            rewrite geq_max; apply/andP; split.
            - rewrite -addnBA; last by eauto 2.
                  by rewrite leq_addr.
            - by rewrite addnC -addnBA // leq_addr.
          }
          { unfold can_be_preempted_for_fully_nonpreemptive_model.
            apply/orP; right.
            move: H0 => /andP [_ LE].
            rewrite eqn_leq; apply/andP; split.
            - by rewrite geq_max; apply/andP; split.
            - by rewrite leq_max; apply/orP; right.
          }
        }
      }
    Qed.

  End FullyNonPreemptiveModel.

End FullyNonPreemptivePlatform.


Require Import VST.msl.msl_direct.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.

Require Import neg_logic.
Require Import modal_logic.
Require Import ssl_shares.
Require Import ssl_logic.

Open Scope logic.

(* EXAMPLES: PROOF THEORY *)

Section Examples_ProofTheory.

Variable addr : Type.
Variable null : addr.
Definition value : Type := addr.

Variables heapR Pred : Type.

Variable ND : @NatDed Pred.
Variable CND : @ClassicNatDed Pred ND.
Variable SL : @SepLog Pred ND.
Variable CSL : @ClassicalSep Pred ND SL.
Variable PSL : @PreciseSepLog Pred ND SL.
Variable ML : @ModLog heapR Pred ND.
Variable MLS : @ModLogSeq heapR Pred ND ML.
Variable SSL : @ScaledSepLog Pred heapR ND SL PSL ML MLS.
Variable FIL : @FracIndLog Pred heapR ND SL PSL ML MLS SSL.
Variable CL : @CorecLog heapR Pred ND SL ML MLS.

(* Maps-to *)
Variable SML : @ScaledMapsLog Pred (addr * value) heapR ND SL PSL ML MLS SSL.
Definition maps_to a pi v := !!!(a <> null) * maps_to' pi (a,v).
Variable maps_to_eq: forall a p1 p2 v1 v2,
  (maps_to a p1 v1 * TT) && (maps_to a p2 v2 * TT) |-- !!(v1 = v2).

Lemma maps_to_nonempty: forall a pi v,
  maps_to a pi v |-- !Emp.
Proof.
  intros.
  rewrite <- (emp_sepcon (! Emp)).
  apply sepcon_derives.
  apply andp_left1. trivial.
  apply maps_to'_nonempty.
Qed.

Lemma maps_to_uniform: forall a pi v,
  maps_to a pi v |-- uniform pi.
Proof.
  intros.
  rewrite <- star_uniform.
  apply sepcon_derives.
  apply uniform_prop.
  apply maps_to'_uniform.
Qed.

Lemma maps_to_precise: forall a pi v,
  precise (maps_to a pi v).
Proof.
  intros.
  apply star_precise.
  apply prop_precise.
  apply maps_to'_precise.
Qed.

Lemma dot_maps_to: forall pi1 a pi2 v,
  dot pi1 (maps_to a pi2 v) = maps_to a (pbow pi2 pi1) v.
Proof.
  intros.
  unfold maps_to.
  rewrite (dot_star _ _ pi2 _).
  rewrite dot_prop.
  rewrite dot_maps_to'. trivial.
  apply uniform_prop.
  apply maps_to'_uniform.
Qed.

(* Lists *)

Definition listF (rec : addr -> Pred) : addr -> Pred :=
  fun a => !!! (a = null) ||
               EX n : value, maps_to a pfullshare n * rec n.

Lemma covariant_listF : covariant listF.
Proof.
  apply covariant_orp.
  apply covariant_const.
  apply covariant_exp. intro.
  apply covariant_sepcon.
  apply covariant_const.
  apply covariant_const'.
Qed.

Definition plist : addr -> Pred := corec listF.

Lemma plist_unfold :
  plist = fun a => !!! (a = null) ||
                   EX n : value, maps_to a pfullshare n * plist n.
Proof. unfold plist at 1. rewrite corec_fold_unfold. trivial. apply covariant_listF. Qed.

Lemma plist_uniform: forall x,
  plist x |-- uniform pfullshare.
Proof.
  intros. rewrite <- (andp_TT (plist x)).
  rewrite andp_comm. rewrite imp_andp_adjoint.
  apply derives_trans with (ALL x : addr, plist x --> uniform pfullshare).
  2: apply allp_left with x; apply derives_refl. clear -FIL CND CSL.
  apply (shrinking_W pfullshare).
  apply allp_right. intro r.
  rewrite <- imp_andp_adjoint.
  pattern plist at 2. rewrite plist_unfold.
  rewrite andp_comm. rewrite distrib_orp_andp.
  apply orp_left.
  + apply andp_left1. apply andp_left1. apply uniform_emp.
  + rewrite imp_andp_adjoint. apply exp_left. intro n.
    rewrite <- imp_andp_adjoint.
    apply conj_shrinking_entailswithin_uniform.
    apply andp_right.
    apply maps_to_uniform. apply maps_to_nonempty.
    rewrite andp_comm.
    rewrite imp_andp_adjoint.
    eapply derives_trans. apply within_T.
    apply allp_left with n.
    apply derives_refl.
Qed.

Lemma plist_precise: forall x,
  precise (plist x).
Proof.
  intro. rewrite precise_precisely'.
  rewrite <- (TT_andp (plist x * TT)).
  rewrite imp_andp_adjoint.
  apply derives_trans with (ALL x : addr, plist x * TT --> precisely (plist x)).
  2: apply allp_left with x; trivial. clear x.
  apply (shrinking_W pfullshare).
  apply allp_right. intro x.
  eapply derives_trans.
  2: rewrite plist_unfold. 2: apply derives_refl.
  rewrite <- imp_andp_adjoint.
  apply orp_induct. (* YES! *)
  apply precise_derives_precisely.
  apply prop_precise.
  apply exp_induct. intro n. (* YES! *)
{ rewrite sepcon_assoc.
  eapply derives_trans.
  2: apply star_precisely2, maps_to_precise. (* YES! *)
  rewrite andp_comm.
  rewrite <- shrinkingR_withinR. rewrite seqR_box.
  eapply derives_trans.
  apply (conj_shrinking_star1 (maps_to x pfullshare n)). (* YES! *)
  apply andp_right. apply maps_to_uniform. apply maps_to_nonempty.
  apply sepcon_derives. apply andp_left1. apply derives_refl.
  apply andp_left2.
  eapply derives_trans; try apply within_T.
  apply allp_left with n.
  apply precisely_strengthen. }
{ intros a b. eapply derives_trans.
  2: apply (maps_to_eq x pfullshare pfullshare a b).
  apply andp_derives;
  rewrite sepcon_assoc;
  apply sepcon_derives; trivial;
  apply TT_right. }
{ rewrite imp_andp_adjoint, wand_sepcon_adjoint.
  unfold sprop. rewrite andp_comm. rewrite imp_andp_adjoint.
  apply prop_left. intro. subst x.
  rewrite <- imp_andp_adjoint. rewrite <- wand_sepcon_adjoint. rewrite <- imp_andp_adjoint.
  apply andp_left2.
  rewrite wand_sepcon_adjoint.
  apply exp_left. intro n.
  unfold maps_to.
  repeat rewrite wand_sepcon_adjoint.
  apply andp_left2. apply prop_left.
  intro. destruct H. trivial. }
Qed.

Lemma plist_mult_unfold: forall sh x,
  dot sh (plist x) = !!! (x = null) ||
                     EX n : value,
                       maps_to x sh n *
                       dot sh (plist n).
Proof.
  intros. pattern plist at 1. rewrite plist_unfold.
  rewrite dot_orp.
  rewrite dot_prop.
  rewrite dot_exp.
  assert (pbow pfullshare sh = sh). {
      unfold pbow, pfullshare. destruct sh. apply exist_ext. simpl.
      unfold fullshare. rewrite Share.rel_top2. trivial. }
  apply pred_ext;
  apply orp_derives; trivial;
  apply exp_derives; intro n;
  do 3 (try rewrite (dot_star _ _ pfullshare _));
  try apply uniform_star;
  try apply uniform_star;
  try apply plist_uniform;
  try apply maps_to'_uniform;
  try apply maps_to_uniform;
  try apply uniform_prop;
  repeat rewrite dot_maps_to;
  try rewrite H; trivial.
Qed.

Lemma plist_split: forall sh1 sh2 sh x,
  join sh1 sh2 pfullshare ->
  dot sh (plist x) = dot sh1 (dot sh (plist x)) * dot sh2 (dot sh (plist x)).
Proof.
  intros.
  pattern (dot sh (plist x)) at 1.
  rewrite <- (dot_top (dot sh (plist x))).
  pose proof (dot_precise (plist x) sh).
  destruct H0.
  rewrite (dot_plus _ (H0 (plist_precise x)) _ _ _ H).
  trivial.
Qed.

(* Trees *)
Variable S1 : addr -> addr.

Definition treeF (rec : addr -> Pred) : addr -> Pred :=
  fun a => !!! (a = null) ||
               EX l : value, EX r : value,
               maps_to a pfullshare l *
               maps_to (S1 a) pfullshare r *
               rec l *
               rec r.

Lemma covariant_treeF : covariant treeF.
Proof.
  apply covariant_orp.
  apply covariant_const.
  apply covariant_exp. intro.
  apply covariant_exp. intro.
  apply covariant_sepcon.
  apply covariant_sepcon.
  apply covariant_sepcon.
  apply covariant_const.
  apply covariant_const.
  apply covariant_const'.
  apply covariant_const'.
Qed.

Definition ptree : addr -> Pred := corec treeF.

Lemma ptree_unfold :
  ptree = fun a => !!! (a = null) ||
                   EX l : value, EX r : value,
                   maps_to a pfullshare l *
                   maps_to (S1 a) pfullshare r *
                   ptree l *
                   ptree r.
Proof.
  unfold ptree at 1. rewrite corec_fold_unfold. trivial. apply covariant_treeF.
Qed.

Lemma ptree_uniform: forall x,
  ptree x |-- uniform pfullshare.
Proof.
  intros. rewrite <- (andp_TT (ptree x)).
  rewrite andp_comm. rewrite imp_andp_adjoint.
  apply derives_trans with (ALL x : addr, ptree x --> uniform pfullshare).
  2: apply allp_left with x; apply derives_refl. clear -FIL CND CSL.
  apply (shrinking_W pfullshare).
  apply allp_right. intro rt.
  rewrite <- imp_andp_adjoint.
  pattern ptree at 2. rewrite ptree_unfold.
  rewrite andp_comm. rewrite distrib_orp_andp.
  apply orp_left.
  + apply andp_left1. apply andp_left1. apply uniform_emp.
  + rewrite imp_andp_adjoint. apply exp_left. intro l. apply exp_left. intro r.
    rewrite <- imp_andp_adjoint.
    repeat rewrite sepcon_assoc.
    apply conj_shrinking_entailswithin_uniform.
    apply andp_right.
    apply maps_to_uniform. apply maps_to_nonempty.
    eapply derives_trans.
    apply conj_within_star.
    rewrite <- star_uniform at 1.
    apply sepcon_derives. apply andp_left1. apply maps_to_uniform.
    eapply derives_trans.
    apply conj_within_star.
    rewrite <- star_uniform at 1.
    apply sepcon_derives; rewrite andp_comm, imp_andp_adjoint;
    eapply derives_trans; try apply within_T;
    eapply allp_left; trivial.
Qed.

Lemma ptree_precise: forall x,
  precise (ptree x).
Proof.
  intro. rewrite precise_precisely'.
  rewrite <- (TT_andp (ptree x * TT)).
  rewrite imp_andp_adjoint.
  apply derives_trans with (ALL x : addr, ptree x * TT --> precisely (ptree x)).
  2: apply allp_left with x; trivial. clear x.
  apply (shrinking_W pfullshare).
  apply allp_right. intro rt.
  eapply derives_trans.
  2: rewrite ptree_unfold. 2: apply derives_refl.
  rewrite <- imp_andp_adjoint.
  apply orp_induct. (* YES! *)
  apply precise_derives_precisely.
  apply prop_precise.
  apply exp_induct. intro l. (* YES! *)
  apply exp_induct. intro r. (* YES! *)
{ repeat rewrite sepcon_assoc.
  eapply derives_trans.
  2: apply star_precisely2, maps_to_precise. (* YES! *)
  rewrite andp_comm.
  rewrite <- shrinkingR_withinR. rewrite seqR_box.
  eapply derives_trans.
  apply (conj_shrinking_star1 (maps_to rt pfullshare l)). (* YES! *)
  apply andp_right. apply maps_to_uniform. apply maps_to_nonempty.
  apply sepcon_derives. apply andp_left1. apply derives_refl.
  apply andp_left2. apply star_precisely.
  apply precise_derives_precisely, maps_to_precise.
  apply star_precisely; eapply derives_trans; try apply within_T.
  apply allp_left with l.
  apply precisely_strengthen.
  apply allp_left with r.
  apply precisely_strengthen. }
{ intros x y. eapply derives_trans.
  2: apply (maps_to_eq (S1 rt) pfullshare pfullshare x y).
  apply andp_derives;
  rewrite (sepcon_comm (maps_to rt pfullshare l));
  repeat rewrite sepcon_assoc;
  apply sepcon_derives; trivial;
  apply TT_right. }
{ intros x y. eapply derives_trans.
  2: apply (maps_to_eq rt pfullshare pfullshare x y).
  do 2 rewrite exp_sepcon1.
  apply andp_derives; apply exp_left; intro r;
  repeat rewrite sepcon_assoc;
  apply sepcon_derives; trivial;
  apply TT_right. }
{ rewrite imp_andp_adjoint, wand_sepcon_adjoint.
  unfold sprop. rewrite andp_comm. rewrite imp_andp_adjoint.
  apply prop_left. intro. subst rt.
  rewrite <- imp_andp_adjoint. rewrite <- wand_sepcon_adjoint. rewrite <- imp_andp_adjoint.
  apply andp_left2.
  rewrite wand_sepcon_adjoint.
  apply exp_left. intro l. apply exp_left. intro r.
  unfold maps_to.
  repeat rewrite wand_sepcon_adjoint.
  apply andp_left2. apply prop_left.
  intro. destruct H. trivial. }
Qed.

Lemma ptree_mult_unfold: forall sh x,
  dot sh (ptree x) = !!! (x = null) ||
                     EX l : value, EX r : value,
                       maps_to x sh l *
                       maps_to (S1 x) sh r *
                       dot sh (ptree l) *
                       dot sh (ptree r).
Proof.
  intros. pattern ptree at 1. rewrite ptree_unfold.
  rewrite dot_orp.
  rewrite dot_prop.
  rewrite dot_exp.
  assert (pbow pfullshare sh = sh). {
      unfold pbow, pfullshare. destruct sh. apply exist_ext. simpl.
      unfold fullshare. rewrite Share.rel_top2. trivial. }
  apply pred_ext;
  apply orp_derives; trivial;
  apply exp_derives; intro l;
  rewrite dot_exp;
  apply exp_derives; intro r;
  do 3 (try rewrite (dot_star _ _ pfullshare _));
  try apply uniform_star;
  try apply uniform_star;
  try apply ptree_uniform;
  try apply maps_to'_uniform;
  try apply maps_to_uniform;
  try apply uniform_prop;
  repeat rewrite dot_maps_to;
  try rewrite H; trivial.
Qed.

Lemma ptree_split: forall sh1 sh2 sh x,
  join sh1 sh2 pfullshare ->
  dot sh (ptree x) = dot sh1 (dot sh (ptree x)) * dot sh2 (dot sh (ptree x)).
Proof.
  intros.
  pattern (dot sh (ptree x)) at 1.
  rewrite <- (dot_top (dot sh (ptree x))).
  pose proof (dot_precise (ptree x) sh).
  destruct H0.
  rewrite (dot_plus _ (H0 (ptree_precise x)) _ _ _ H).
  trivial.
Qed.

End Examples_ProofTheory.