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.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj20synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus (mult lv3 (plus lv1 (Succ Zero))) (plus lv1 (Succ Zero)))).
Admitted.
QuickChick conj20synthconj3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 (mult lv1 lv2)) lv2) (plus lv0 (mult (Succ lv1) lv2))).
Admitted.
QuickChick conj19synthconj3.


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.