(* !!! WARNING: AUTO GENERATED. DO NOT MODIFY !!! *)
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

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

Require Export syntax_ott.

(** 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 H4 H5 =>
  typ_ind' H1 H2 H3 H4 H5.

Scheme typ_rec' := Induction for typ Sort Set.

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

Scheme exp_ind' := Induction for exp Sort Prop.

Definition exp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 =>
  exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

Scheme exp_rec' := Induction for exp Sort Set.

Definition exp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 =>
  exp_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

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

Fixpoint close_exp_wrt_exp_rec (n1 : nat) (x1 : var) (e1 : exp) {struct e1} : exp :=
  match e1 with
    | e_var_f x2 => if (x1 == x2) then (e_var_b n1) else (e_var_f x2)
    | e_var_b n2 => if (lt_ge_dec n2 n1) then (e_var_b n2) else (e_var_b (S n2))
    | e_top => e_top
    | e_lit i1 => e_lit i1
    | e_abs A1 e2 B1 => e_abs A1 (close_exp_wrt_exp_rec (S n1) x1 e2) B1
    | e_fixpoint e2 A1 => e_fixpoint (close_exp_wrt_exp_rec (S n1) x1 e2) A1
    | e_app e2 e3 => e_app (close_exp_wrt_exp_rec n1 x1 e2) (close_exp_wrt_exp_rec n1 x1 e3)
    | e_merge e2 e3 => e_merge (close_exp_wrt_exp_rec n1 x1 e2) (close_exp_wrt_exp_rec n1 x1 e3)
    | e_anno e2 A1 => e_anno (close_exp_wrt_exp_rec n1 x1 e2) A1
  end.

Definition close_exp_wrt_exp x1 e1 := close_exp_wrt_exp_rec 0 x1 e1.

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

Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | t_int => 1
    | t_top => 1
    | t_arrow A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | t_and A2 B1 => 1 + (size_typ A2) + (size_typ B1)
  end.

Fixpoint size_exp (e1 : exp) {struct e1} : nat :=
  match e1 with
    | e_var_f x1 => 1
    | e_var_b n1 => 1
    | e_top => 1
    | e_lit i1 => 1
    | e_abs A1 e2 B1 => 1 + (size_typ A1) + (size_exp e2) + (size_typ B1)
    | e_fixpoint e2 A1 => 1 + (size_exp e2) + (size_typ A1)
    | e_app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
    | e_merge e2 e3 => 1 + (size_exp e2) + (size_exp e3)
    | e_anno e2 A1 => 1 + (size_exp e2) + (size_typ A1)
  end.

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

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

Inductive degree_exp_wrt_exp : nat -> exp -> Prop :=
  | degree_wrt_exp_e_var_f : forall n1 x1,
    degree_exp_wrt_exp n1 (e_var_f x1)
  | degree_wrt_exp_e_var_b : forall n1 n2,
    lt n2 n1 ->
    degree_exp_wrt_exp n1 (e_var_b n2)
  | degree_wrt_exp_e_top : forall n1,
    degree_exp_wrt_exp n1 (e_top)
  | degree_wrt_exp_e_lit : forall n1 i1,
    degree_exp_wrt_exp n1 (e_lit i1)
  | degree_wrt_exp_e_abs : forall n1 A1 e1 B1,
    degree_exp_wrt_exp (S n1) e1 ->
    degree_exp_wrt_exp n1 (e_abs A1 e1 B1)
  | degree_wrt_exp_e_fixpoint : forall n1 e1 A1,
    degree_exp_wrt_exp (S n1) e1 ->
    degree_exp_wrt_exp n1 (e_fixpoint e1 A1)
  | degree_wrt_exp_e_app : forall n1 e1 e2,
    degree_exp_wrt_exp n1 e1 ->
    degree_exp_wrt_exp n1 e2 ->
    degree_exp_wrt_exp n1 (e_app e1 e2)
  | degree_wrt_exp_e_merge : forall n1 e1 e2,
    degree_exp_wrt_exp n1 e1 ->
    degree_exp_wrt_exp n1 e2 ->
    degree_exp_wrt_exp n1 (e_merge e1 e2)
  | degree_wrt_exp_e_anno : forall n1 e1 A1,
    degree_exp_wrt_exp n1 e1 ->
    degree_exp_wrt_exp n1 (e_anno e1 A1).

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 H6 H7 H8 H9 H10 =>
  degree_exp_wrt_exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9 H10.

Hint Constructors degree_exp_wrt_exp : core lngen.

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

Inductive lc_set_exp : exp -> Set :=
  | lc_set_e_var_f : forall x1,
    lc_set_exp (e_var_f x1)
  | lc_set_e_top :
    lc_set_exp (e_top)
  | lc_set_e_lit : forall i1,
    lc_set_exp (e_lit i1)
  | lc_set_e_abs : forall A1 e1 B1,
    (forall x1 : var, lc_set_exp (open_exp_wrt_exp e1 (e_var_f x1))) ->
    lc_set_exp (e_abs A1 e1 B1)
  | lc_set_e_fixpoint : forall e1 A1,
    (forall x1 : var, lc_set_exp (open_exp_wrt_exp e1 (e_var_f x1))) ->
    lc_set_exp (e_fixpoint e1 A1)
  | lc_set_e_app : forall e1 e2,
    lc_set_exp e1 ->
    lc_set_exp e2 ->
    lc_set_exp (e_app e1 e2)
  | lc_set_e_merge : forall e1 e2,
    lc_set_exp e1 ->
    lc_set_exp e2 ->
    lc_set_exp (e_merge e1 e2)
  | lc_set_e_anno : forall e1 A1,
    lc_set_exp e1 ->
    lc_set_exp (e_anno e1 A1).

Scheme lc_exp_ind' := Induction for lc_exp Sort Prop.

Definition lc_exp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Scheme lc_set_exp_ind' := Induction for lc_set_exp Sort Prop.

Definition lc_set_exp_mutind :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_set_exp_ind' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Scheme lc_set_exp_rec' := Induction for lc_set_exp Sort Set.

Definition lc_set_exp_mutrec :=
  fun H1 H2 H3 H4 H5 H6 H7 H8 H9 =>
  lc_set_exp_rec' H1 H2 H3 H4 H5 H6 H7 H8 H9.

Hint Constructors lc_exp : core lngen.

Hint Constructors lc_set_exp : core lngen.

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

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

Hint Unfold body_exp_wrt_exp.

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

(** Additional hint declarations. *)

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 A1, 1 <= size_typ A1).
Proof.
apply_mutual_ind typ_mutind;
default_simp.
Qed.

(* end hide *)

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

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.

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.

Hint Resolve size_exp_close_exp_wrt_exp_rec : lngen.
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.

Hint Resolve size_exp_close_exp_wrt_exp : lngen.
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.

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.

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 (e_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 (e_var_f x1) e1) = size_exp e1.
Proof.
pose proof size_exp_open_exp_wrt_exp_rec_var_mutual as H; intuition eauto.
Qed.

Hint Resolve size_exp_open_exp_wrt_exp_rec_var : lngen.
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 (e_var_f x1)) = size_exp e1.
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

Hint Resolve size_exp_open_exp_wrt_exp_var : lngen.
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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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 (e_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 (e_var_f x1) e1) = e1.
Proof.
pose proof close_exp_wrt_exp_rec_open_exp_wrt_exp_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve close_exp_wrt_exp_rec_open_exp_wrt_exp_rec : lngen.
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 (e_var_f x1)) = e1.
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

Hint Resolve close_exp_wrt_exp_open_exp_wrt_exp : lngen.
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 (e_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 (e_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.

Hint Resolve open_exp_wrt_exp_rec_close_exp_wrt_exp_rec : lngen.
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) (e_var_f x1) = e1.
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

Hint Resolve open_exp_wrt_exp_close_exp_wrt_exp : lngen.
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 (e_var_f x1) e2 = open_exp_wrt_exp_rec n1 (e_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 (e_var_f x1) e2 = open_exp_wrt_exp_rec n1 (e_var_f x1) e1 ->
  e2 = e1.
Proof.
pose proof open_exp_wrt_exp_rec_inj_mutual as H; intuition eauto.
Qed.

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 (e_var_f x1) = open_exp_wrt_exp e1 (e_var_f x1) ->
  e2 = e1.
Proof.
unfold open_exp_wrt_exp; eauto with lngen.
Qed.

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.

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.

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_e_abs_exists :
forall x1 A1 e1 B1,
  lc_exp (open_exp_wrt_exp e1 (e_var_f x1)) ->
  lc_exp (e_abs A1 e1 B1).
Proof.
intros; exp_lc_exists_tac; eauto with lngen.
Qed.

Lemma lc_e_fixpoint_exists :
forall x1 e1 A1,
  lc_exp (open_exp_wrt_exp e1 (e_var_f x1)) ->
  lc_exp (e_fixpoint e1 A1).
Proof.
intros; exp_lc_exists_tac; eauto with lngen.
Qed.

Hint Extern 1 (lc_exp (e_abs _ _ _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_e_abs_exists x1).

Hint Extern 1 (lc_exp (e_fixpoint _ _)) =>
  let x1 := fresh in
  pick_fresh x1;
  apply (lc_e_fixpoint_exists x1).

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 with lngen.
Qed.

Hint Resolve lc_body_exp_wrt_exp : lngen.

Lemma lc_body_e_abs_2 :
forall A1 e1 B1,
  lc_exp (e_abs A1 e1 B1) ->
  body_exp_wrt_exp e1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_e_abs_2 : lngen.

Lemma lc_body_e_fixpoint_1 :
forall e1 A1,
  lc_exp (e_fixpoint e1 A1) ->
  body_exp_wrt_exp e1.
Proof.
default_simp.
Qed.

Hint Resolve lc_body_e_fixpoint_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.

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.

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_typ_of_lc_typ
 | 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.

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.

Hint Resolve close_exp_wrt_exp_rec_degree_exp_wrt_exp : lngen.
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.

Hint Resolve close_exp_wrt_exp_lc_exp : lngen.
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.

Hint Resolve open_exp_wrt_exp_rec_degree_exp_wrt_exp : lngen.
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.

Hint Resolve open_exp_wrt_exp_lc_exp : lngen.
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.

Hint Resolve fv_exp_close_exp_wrt_exp_rec : lngen.
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.

Hint Resolve fv_exp_close_exp_wrt_exp : lngen.
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.

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.

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.

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.

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.

Hint Resolve fv_exp_subst_exp_fresh : lngen.
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.

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.

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.

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.

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.

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.

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.

Hint Resolve subst_exp_fresh_eq : lngen.
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.

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.

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.

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.

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.

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) (e_var_f x2) = subst_exp e1 x1 (open_exp_wrt_exp e2 (e_var_f x2)).
Proof.
intros; rewrite subst_exp_open_exp_wrt_exp; default_simp.
Qed.

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.

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.

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.

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 (e_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 (e_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.

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 (e_var_f x2))).
Proof.
unfold close_exp_wrt_exp; unfold open_exp_wrt_exp; default_simp.
Qed.

Hint Resolve subst_exp_close_exp_wrt_exp_open_exp_wrt_exp : lngen.

Lemma subst_exp_e_abs :
forall x2 A1 e2 B1 e1 x1,
  lc_exp e1 ->
  x2 `notin` fv_exp e1 `union` fv_exp e2 `union` singleton x1 ->
  subst_exp e1 x1 (e_abs A1 e2 B1) = e_abs (A1) (close_exp_wrt_exp x2 (subst_exp e1 x1 (open_exp_wrt_exp e2 (e_var_f x2)))) (B1).
Proof.
default_simp.
Qed.

Hint Resolve subst_exp_e_abs : lngen.

Lemma subst_exp_e_fixpoint :
forall x2 e2 A1 e1 x1,
  lc_exp e1 ->
  x2 `notin` fv_exp e1 `union` fv_exp e2 `union` singleton x1 ->
  subst_exp e1 x1 (e_fixpoint e2 A1) = e_fixpoint (close_exp_wrt_exp x2 (subst_exp e1 x1 (open_exp_wrt_exp e2 (e_var_f x2)))) (A1).
Proof.
default_simp.
Qed.

Hint Resolve subst_exp_e_fixpoint : 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 (e_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 (e_var_f x1) e1).
Proof.
pose proof subst_exp_intro_rec_mutual as H; intuition eauto.
Qed.

Hint Resolve subst_exp_intro_rec : lngen.
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 (e_var_f x1)).
Proof.
unfold open_exp_wrt_exp; default_simp.
Qed.

Hint Resolve subst_exp_intro : lngen.

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

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


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                             Lemmas_Struct.v                              *)
(****************************************************************************)

Require Export Base_Struct.
Require Export Proj_lists.
Require Export Bool_Compl.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma Ackor_false_fst :
 forall l : d_list bool 4, Ackor l = false -> Fst_of_l4 l = false.
intros l; elim (non_empty l); intros x H; elim H; clear H; intros X H;
 rewrite H.
unfold Ackor in |- *; unfold Fold_with_f_S in |- *; simpl in |- *.
elim x; auto.
Qed.

Lemma Ackor_false_scd :
 forall l : d_list bool 4, Ackor l = false -> Scd_of_l4 l = false.
intros l; elim (non_empty l); intros x H; elim H; clear H; intros X H;
 rewrite H.
unfold Ackor in |- *; unfold Fold_with_f_S in |- *; simpl in |- *.
unfold Scd_of_l4 in |- *; simpl in |- *.
elim (d_Head X); auto.
simpl in |- *.
elim orb_sym; auto.
Qed.

Lemma Ackor_false_thd :
 forall l : d_list bool 4, Ackor l = false -> Thd_of_l4 l = false.
intros l; elim (non_empty l); intros x H; elim H; clear H; intros X H;
 rewrite H.
unfold Ackor in |- *; unfold Fold_with_f_S in |- *; simpl in |- *.
unfold Thd_of_l4 in |- *; simpl in |- *.
elim (d_Head (d_tl X)); auto.
simpl in |- *.
replace (OR2 (d_Head X) true) with (OR2 true (d_Head X)); simpl in |- *.
elim orb_sym; auto with bool.
auto with bool.
Qed.

Lemma Ackor_false_fth :
 forall l : d_list bool 4, Ackor l = false -> Fth_of_l4 l = false.
intros l; elim (non_empty l); intros x H; elim H; clear H; intros X H;
 rewrite H.
unfold Ackor in |- *; unfold Fold_with_f_S in |- *; simpl in |- *.
unfold Fth_of_l4 in |- *; simpl in |- *.
(** (Elim (d_Head (d_tl (d_tl X))); Auto) : NE FAIT RIEN ??? **)
elim (non_empty X); intros x' H'; elim H'; clear H'; intros X' H'; rewrite H';
 simpl in |- *.
elim (d_Head (d_tl X')); auto.
replace (OR2 (d_Head X') true) with (OR2 true (d_Head X')); simpl in |- *.
replace (OR2 x' true) with (true || x'); simpl in |- *.
elim orb_sym; auto.
auto with bool.
auto with bool.
Qed.

Lemma Ackor_dmap_true_2 :
 forall l : d_list (d_list bool 4) 2,
 Ackor (d_map (Ackor (n:=3)) l) = true ->
 Ackor (Fst_of_l2 l) = true /\ Ackor (Scd_of_l2 l) = true \/
 Ackor (Fst_of_l2 l) = true /\ Ackor (Scd_of_l2 l) = false \/
 Ackor (Fst_of_l2 l) = false /\ Ackor (Scd_of_l2 l) = true.
intro l.
elim (non_empty l).
intros x t; elim t; clear t.
intros t.
elim (non_empty t).
intros x' t'; elim t'; clear t'.
intros t'.
intros H1 H2.
rewrite H2; rewrite H1; simpl in |- *.
replace t' with (d_nil (d_list bool 4)); auto.
intros.
unfold Scd_of_l2 in |- *; simpl in |- *.
generalize H.
elim (Ackor x); elim (Ackor x'); simpl in |- *; auto.
Qed.

Lemma Ackor_dmap_false_2 :
 forall l : d_list (d_list bool 4) 2,
 Ackor (d_map (Ackor (n:=3)) l) = false ->
 Ackor (Fst_of_l2 l) = false /\ Ackor (Scd_of_l2 l) = false.
intro l.
elim (non_empty l).
intros x t; elim t; clear t.
intros t; elim (non_empty t).
intros x' t'; elim t'; clear t'.
intros t'.
replace t' with (d_nil (d_list bool 4)); auto.
intros H1 H2.
rewrite H2; rewrite H1; simpl in |- *.
unfold Scd_of_l2 in |- *; simpl in |- *.
elim (Ackor x); elim (Ackor x'); auto.
Qed.

Lemma Ackor_dmap_true_4 :
 forall l : d_list (d_list bool 4) 4,
 Ackor (d_map (Ackor (n:=3)) l) = true ->
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = true \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = false \/
 Ackor (Fst_of_l4 l) = true /\
 Ackor (Scd_of_l4 l) = true /\
 Ackor (Thd_of_l4 l) = true /\ Ackor (Fth_of_l4 l) = true.
intro l.
elim (non_empty l).
intros x t; elim t; clear t.
intro t.
elim (non_empty t).
intros x' t'; elim t'; clear t'.
intro t'.
elim (non_empty t').
intros x'' t''; elim t''; clear t''.
intro t''.
elim (non_empty t'').
intros x''' t'''; elim t'''; clear t'''.
intro t'''.
intros H1 H2 H3 H4.
rewrite H4; rewrite H3; rewrite H2; rewrite H1; simpl in |- *.
replace t''' with (d_nil (d_list bool 4)); auto.
intro H.
unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *; unfold Fth_of_l4 in |- *;
 simpl in |- *.
generalize H.
elim (Ackor x); elim (Ackor x'); elim (Ackor x''); elim (Ackor x''');
 simpl in |- *; clear H; intro H.
do 14 right; auto.
do 13 right; auto.
do 12 right; auto.
do 11 right; auto.
do 10 right; auto.
do 9 right; auto.
do 8 right; auto.
do 7 right; auto.
do 6 right; auto.
do 5 right; auto.
do 4 right; auto.
do 3 right; auto.
do 2 right; auto.
right; auto.
auto.
unfold Ackor in H; simpl in H.
absurd (false = true); auto.
Qed.

Lemma Ackor_dmap_false_4 :
 forall l : d_list (d_list bool 4) 4,
 Ackor (d_map (Ackor (n:=3)) l) = false ->
 Ackor (Fst_of_l4 l) = false /\
 Ackor (Scd_of_l4 l) = false /\
 Ackor (Thd_of_l4 l) = false /\ Ackor (Fth_of_l4 l) = false.
intro l.
elim (non_empty l).
intros x t; elim t; clear t.
intros t; elim (non_empty t).
intros x' t'; elim t'; clear t'.
intros t'.
elim (non_empty t').
intros x'' t''; elim t''; clear t''.
intro t''.
elim (non_empty t'').
intros x''' t'''; elim t'''; clear t'''.
intro t'''.
replace t''' with (d_nil (d_list bool 4)); auto.
intros H1 H2 H3 H4.
rewrite H4; rewrite H3; rewrite H2; rewrite H1; simpl in |- *.
unfold Scd_of_l4 in |- *; unfold Thd_of_l4 in |- *; unfold Fth_of_l4 in |- *;
 simpl in |- *.
elim (Ackor x); elim (Ackor x'); elim (Ackor x''); elim (Ackor x'''); auto.
Qed.


From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import OSModel OSNodes.
Require Import ProgSem.
Require Import ProgSim.

(* Require Import SystemParams. *)
(* Require Import CEventSem. *)

Require Import Arith ZArith Bool.
Require Import String List Lia.

(* Import Params. *)
Import Clight Clightdefs.
Import ITreeNotations.

Set Nested Proofs Allowed.

Definition divide_c (n m: Z): bool :=
  let x := Z.div m n in
  (x * n =? m)%Z.

Lemma divide_comput (n m: Z)
  : divide_c n m = true <-> (n | m)%Z.
Proof.
  split.
  - unfold divide_c. intro COMP.
    exists (m/n)%Z.
    destruct (Z.eqb_spec (m / n * n) m); ss.
  - intro DIV. r in DIV. des.
    unfold divide_c. subst m.
    apply Z.eqb_eq.
    destruct (Z.eqb_spec n 0).
    2: { rewrite Z_div_mult_full by nia. ss. }
    subst.
    do 2 rewrite Z.mul_0_r. ss.
Qed.

Section EXPR_STRONG_IND.

  Fixpoint expr_measure (e: expr): nat :=
    match e with
    | Econst_int _ _ => 0
    | Econst_float _ _ => 0
    | Econst_single _ _ => 0
    | Econst_long _ _ => 0
    | Evar _ _ => 0
    | Etempvar _ _ => 0
    | Ederef e _ => S (expr_measure e)
    | Eaddrof e _ => S (expr_measure e)
    | Eunop _ e _ => S (expr_measure e)
    | Ebinop _ e1 e2 _ =>
      S (expr_measure e1 + expr_measure e2)
    | Ecast e _ => S (expr_measure e)
    | Efield e _ _ => S (expr_measure e)
    | Esizeof _ _ => 0
    | Ealignof _ _ => 0
    end.

  Variable P: expr -> Prop.
  Hypothesis IND_CASE: forall e (IH: forall e', expr_measure e' < expr_measure e -> P e'), P e.

  Lemma expr_str_ind
    : forall e, P e.
  Proof.
    intro e.
    remember (expr_measure e) as m eqn: M'.
    assert (M: expr_measure e <= m) by nia.
    clear M'.
    depgen e.

    induction m as [| m' IH].
    { i. eapply IND_CASE. i. nia. }

    i. eapply IND_CASE.
    i. eapply IH. nia.
  Qed.

End EXPR_STRONG_IND.

(** ** Deterministic behavior of Clight *)

Definition deref_loc_c (ty: type) (m:mem)
           (b:block) (ofs: ptrofs): val? :=
  match access_mode ty with
  | By_value chunk =>
    Mem.loadv chunk m (Vptr b ofs)
  | By_reference => Some (Vptr b ofs)
  | By_copy => Some (Vptr b ofs)
  | By_nothing => None
  end.

Lemma deref_loc_comput
      ty m' b ofs v
  : Clight.deref_loc ty m' b ofs v <->
    deref_loc_c ty m' b ofs = Some v.
Proof.
  split.
  - intro PROP.
    unfold deref_loc_c.
    inv PROP; desf.
  - intro COMP.
    unfold deref_loc_c in COMP.
    desf.
    + econs 1; eauto.
    + econs 2; eauto.
    + econs 3; eauto.
Qed.

Definition assign_loc_c (ce: composite_env)
           (ty: type) (m: mem) (b: block) (ofs: ptrofs)
           (v: val): mem? :=
  match access_mode ty with
  | By_value chunk =>
    Mem.storev chunk m (Vptr b ofs) v
  | By_copy =>
    match v with
    | Vptr b' ofs' =>
      let chk1 :=
          if (0 <? sizeof ce ty) then
            andb (divide_c
                    (alignof_blockcopy ce ty)
                    (Ptrofs.unsigned ofs'))
                 (divide_c
                    (alignof_blockcopy ce ty)
                    (Ptrofs.unsigned ofs))
          else true in
      if negb chk1 then None else
        let chk2 :=
            (orb (negb (b' =? b))%positive
                 (orb (Ptrofs.unsigned ofs' =? Ptrofs.unsigned ofs)
                      (orb (Ptrofs.unsigned ofs' + sizeof ce ty <=? Ptrofs.unsigned ofs)
                           (Ptrofs.unsigned ofs + sizeof ce ty <=? Ptrofs.unsigned ofs'))))%Z
        in
        if negb chk2 then None else
          match Mem.loadbytes
                  m b' (Ptrofs.unsigned ofs')
                  (sizeof ce ty) with
          | None => None
          | Some bytes =>
            Mem.storebytes m b (Ptrofs.unsigned ofs) bytes
          end
    | _ => None
    end
  | By_reference => None
  | By_nothing => None
  end%Z.

Lemma assign_loc_comput
      ce ty m b ofs v m'
  : Clight.assign_loc ce ty m b ofs v m' <->
    assign_loc_c ce ty m b ofs v = Some m'.
Proof.
  split; intro AUX.
  - inv AUX.
    + unfold assign_loc_c. desf.
    + renames H H0 H1 into ACC_MODE DIV1 DIV2.
      renames H2 H3 H4 into PTR LBS SBS.

      unfold assign_loc_c.
      replace (access_mode ty) with By_copy.
      match goal with
      | |- (if negb ?e then _ else _) = _ =>
        replace e with true
      end.
      2: {
        clear - DIV1 DIV2.
        desf.
        symmetry. apply andb_true_iff.
        destruct (Z.ltb_spec 0 (sizeof ce ty)); ss.
        split.
        - apply divide_comput.
          apply DIV1. nia.
        - apply divide_comput.
          apply DIV2. nia.
      }
      ss.
      clear DIV1 DIV2.
      match goal with
      | |- (if negb ?e then _ else _) = _ =>
        replace e with true
      end.
      2: {
        symmetry.
        do 3 rewrite orb_true_iff.
        clear - PTR. des.
        - left. destruct (Pos.eqb_spec b' b); ss.
        - right. left.
          rewrite PTR. apply Z.eqb_refl.
        - right. right. left.
          apply Zle_imp_le_bool. auto.
        - do 3 right.
          apply Zle_imp_le_bool. auto.
      }
      ss.
      desf.

  - unfold assign_loc_c in AUX.
    destruct (access_mode ty) eqn: ACC_MODE; ss.
    + econs 1; eauto.
    + destruct v as [ | | | | | b' ofs']; ss.
      match type of AUX with
      | (if negb ?e then None else _) = _ =>
        assert (CHK1: e = true); [by destruct e; ss|]
      end.
      rewrite CHK1 in AUX. ss.

      match type of AUX with
      | (if negb ?e then None else _) = _ =>
        assert (CHK2: e = true); [by destruct e; ss|]
      end.
      rewrite CHK2 in AUX. ss.

      match type of AUX with
      | match ?e with _ => _ end = _ =>
        destruct e eqn: LBS
      end; ss.

      econs 2; eauto.
      * clear AUX.
        destruct (Z.ltb_spec 0 (sizeof ce ty)); ss.
        apply Bool.andb_true_iff in CHK1. des.
        intro SIZE_POS.
        apply divide_comput. eauto.
      * clear AUX.
        destruct (Z.ltb_spec 0 (sizeof ce ty)); ss.
        apply Bool.andb_true_iff in CHK1. des.
        intro SIZE_POS.
        apply divide_comput. eauto.
      * clear CHK1 AUX.
        rewrite orb_true_iff in CHK2. des.
        { left. destruct (Pos.eqb_spec b' b); ss. }
        right. rewrite orb_true_iff in CHK2. des.
        { left.
          destruct (Z.eqb_spec (Ptrofs.unsigned ofs')
                               (Ptrofs.unsigned ofs)); ss. }
        right. rewrite orb_true_iff in CHK2. des.
        { left.
          destruct (Z.leb_spec (Ptrofs.unsigned ofs' + sizeof ce ty) (Ptrofs.unsigned ofs)); ss.
        }
        { right.
          destruct (Z.leb_spec (Ptrofs.unsigned ofs + sizeof ce ty) (Ptrofs.unsigned ofs')); ss.
        }
Qed.

Section EVAL_EXPR_COMP.

  Variable ge: Clight.genv.
  Variable e: Clight.env.
  Variable le: Clight.temp_env.
  Variable m: mem.

  Section EVAL_LVALUE.
    Variable _eval_expr_c: expr -> val?.

    Fixpoint _eval_lvalue_c (a: expr)
      : (block * ptrofs)? :=
      match a with
      | Evar id ty =>
        match e ! id with
        | Some (l, ty') =>
          if type_eq ty ty' then Some (l, Ptrofs.zero)
          else None
        | None =>
          match Genv.find_symbol
                  (Clight.genv_genv ge) id with
          | Some l => Some (l, Ptrofs.zero)
          | None => None
          end
        end
      | Ederef a ty =>
        match _eval_expr_c a with
        | Some (Vptr l ofs) => Some (l, ofs)
        | _ => None
        end
      | Efield a i ty =>
        match _eval_expr_c a with
        | Some (Vptr l ofs) =>
          match Clight.typeof a with
          | Tstruct id att =>
            match (Clight.genv_cenv ge) ! id with
            | Some co =>
              match field_offset (Clight.genv_cenv ge)
                                 i (co_members co) with
              | Errors.OK delta =>
                Some (l, (Ptrofs.add ofs (Ptrofs.repr delta)))
              | _ => None
              end
            | _ => None
            end
          | Tunion id att =>
            match (Clight.genv_cenv ge) ! id with
            | Some _ => Some (l, ofs)
            | None => None
            end
          | _ => None
          end
        | _ => None
        end
      | _ => None
      end.

  End EVAL_LVALUE.

  Fixpoint eval_expr_c (expr: Clight.expr): val? :=
    match expr with
    | Econst_int i ty => Some (Vint i)
    | Econst_float f ty => Some (Vfloat f)
    | Econst_single f ty => Some (Vsingle f)
    | Econst_long i ty => Some (Vlong i)
    | Etempvar id ty => (le ! id)
    | Eaddrof a ty =>
      match _eval_lvalue_c eval_expr_c a with
      | None => None (*??*)
      | Some (loc, ofs) => Some (Vptr loc ofs)
      end
    | Eunop op a ty =>
      match eval_expr_c a with
      | None => None
      | Some v1 =>
        Cop.sem_unary_operation
          op v1 (Clight.typeof a) m
      end
    | Ebinop op a1 a2 ty =>
      match eval_expr_c a1, eval_expr_c a2 with
      | Some v1, Some v2 =>
        Cop.sem_binary_operation
          (Clight.genv_cenv ge) op
          v1 (Clight.typeof a1)
          v2 (Clight.typeof a2) m
      | _, _ => None
      end
    | Ecast a ty =>
      match eval_expr_c a with
      | None => None
      | Some v1 =>
        Cop.sem_cast v1 (Clight.typeof a) ty m
      end
    | Esizeof ty1 ty =>
      Some (Vptrofs (Ptrofs.repr (sizeof (Clight.genv_cenv ge) ty1)))
    | Ealignof ty1 ty =>
      Some (Vptrofs (Ptrofs.repr (alignof (Clight.genv_cenv ge) ty1)))
    | a =>
      match _eval_lvalue_c eval_expr_c a with
      | None => None
      | Some (loc, ofs) =>
        deref_loc_c (Clight.typeof a) m loc ofs
      end
    end.

  Definition eval_lvalue_c
    : expr -> (block * ptrofs)? :=
    _eval_lvalue_c eval_expr_c.

  Ltac inv_eval_lvalue :=
    match goal with
    | H: eval_lvalue _ _ _ _ _ _ _ |- _ => inv H
    end.

  Lemma _eval_lvalue_comput
        _eval_expr_c a b ofs
        (EVAL_EXPR: forall a' v,
            expr_measure a' < expr_measure a ->
            eval_expr ge e le m a' v <->
            _eval_expr_c a' = Some v)
    : eval_lvalue ge e le m a b ofs <->
      _eval_lvalue_c _eval_expr_c a = Some (b, ofs).
  Proof.
    destruct a; ss;
      try by split; i; ss; inv_eval_lvalue.
    - split; intro AUX; ss.
      + inv AUX; desf.
      + desf.
        * eapply eval_Evar_local; ss.
        * eapply eval_Evar_global; ss.
    - split; intro AUX; ss.
      + inv AUX.
        rewrite EVAL_EXPR in * by nia.
        desf.
      + desf. econs.
        eapply EVAL_EXPR; eauto.
    - split; intro AUX; ss.
      + inv AUX.
        * hexploit (EVAL_EXPR a); ss.
          intros [AUX1 _].
          hexploit AUX1; eauto.
          intro R. rewrite R.
          desf.
        * hexploit (EVAL_EXPR a); ss.
          intros [AUX1 _].
          hexploit AUX1; eauto.
          intro R. rewrite R.
          desf.
      + desf.
        * eapply eval_Efield_struct; eauto.
          apply EVAL_EXPR; eauto.
        * eapply eval_Efield_union; eauto.
          apply EVAL_EXPR; eauto.
  Qed.

  Lemma eval_expr_comput a v
    : eval_expr ge e le m a v <->
      eval_expr_c a = Some v.
  Proof.
    depgen v.
    pattern a. revert a.
    apply expr_str_ind.

    intros a IH.
    destruct a; i;
      try by split; intro AUX; ss; clarify;
        [inv AUX; ss; inv_eval_lvalue | econs].
    (* 7 *)
    - split; intro AUX; ss.
      + inv AUX; ss.
        inv_eval_lvalue.
        * desf. apply deref_loc_comput; auto.
        * desf. apply deref_loc_comput; auto.
      + desf.
        * eapply eval_Elvalue.
          -- apply eval_Evar_local; eauto.
          -- apply deref_loc_comput; eauto.
        * eapply eval_Elvalue.
          -- apply eval_Evar_global; eauto.
          -- apply deref_loc_comput; eauto.
    - split; intro AUX; ss.
      + inv AUX; ss.
        inv_eval_lvalue.
        rewrite IH in * by nia.
        desf. eapply deref_loc_comput; auto.
      + desf.
        eapply eval_Elvalue.
        * eapply _eval_lvalue_comput with
              (_eval_expr_c := eval_expr_c).
          { i. rewrite <- IH; ss. }
          ss. desf.
        * eapply deref_loc_comput; auto.
    - split; intro AUX; ss.
      + inv AUX.
        * hexploit (_eval_lvalue_comput eval_expr_c a).
          { i. rewrite <- IH by nia. ss. }
          intros [R _]. rewrite R; eauto.
        * inv_eval_lvalue.
      + desf. econs.
        destruct a; ss.
        * desf.
          -- eapply eval_Evar_local; ss.
          -- eapply eval_Evar_global; ss.
        * desf.
          rewrite <- IH in * by nia.
          econs. eauto.
        * desf.
          -- eapply eval_Efield_struct; eauto.
             eapply IH; eauto.
          -- eapply eval_Efield_union; eauto.
             eapply IH; eauto.
    - split; intro AUX; ss.
      + inv AUX.
        * hexploit IH; eauto.
          intros [R _]. rewrite R; eauto.
        * inv_eval_lvalue.
      + desf. econs; eauto.
        eapply IH; eauto.
    - split; intro AUX; ss.
      + inv AUX.
        2: { inv_eval_lvalue. }

        hexploit (IH a1); eauto.
        { nia. }
        intros [R1 _]. rewrite R1; eauto.
        hexploit (IH a2); eauto.
        { nia. }
        intros [R2 _]. rewrite R2; eauto.
      + desf. econs; eauto.
        * eapply IH; eauto. nia.
        * eapply IH; eauto. nia.

    - split; intro AUX; ss.
      + inv AUX.
        * hexploit IH; eauto.
          intros [R _]. rewrite R; eauto.
        * inv_eval_lvalue.
      + desf. econs; eauto.
        eapply IH; eauto.
    - split; intro AUX; ss.
      + inv AUX.
        inv_eval_lvalue.
        * hexploit IH; eauto.
          intros [R _]. rewrite R; eauto.
          desf.
          apply deref_loc_comput. auto.
        * hexploit IH; eauto.
          intros [R _]. rewrite R; eauto.
          desf.
          apply deref_loc_comput. auto.
      + desf.
        * eapply eval_Elvalue.
          2: { apply deref_loc_comput; eauto. }
          eapply eval_Efield_struct; eauto.
          eapply IH; eauto.
        * eapply eval_Elvalue.
          2: { apply deref_loc_comput; eauto. }
          eapply eval_Efield_union; eauto.
          eapply IH; eauto.
  Qed.

  Lemma eval_lvalue_comput
    : forall a blk ofs,
      eval_lvalue ge e le m a blk ofs <->
      eval_lvalue_c a = Some (blk, ofs).
  Proof.
    i. apply _eval_lvalue_comput.
    i. apply eval_expr_comput.
  Qed.

  Fixpoint eval_exprlist_c
           (es: list expr) (ts: typelist)
    : (list val)? :=
    match es, ts with
    | [], Tnil => Some []
    | e::es', Tcons ty ts' =>
      match eval_expr_c e, eval_exprlist_c es' ts' with
      | Some v1, Some vs =>
        match Cop.sem_cast v1 (typeof e) ty m with
        | Some v2 => Some (v2::vs)
        | None => None
        end
      | _, _ => None
      end
    | _, _ => None
    end.

  Lemma eval_exprlist_comput
        es ts vs
    : eval_exprlist ge e le m es ts vs <->
      eval_exprlist_c es ts = Some vs.
  Proof.
    revert ts vs.
    induction es as [| a es' IH]; i; ss.
    { split; intro AUX; ss.
      - inv AUX. ss.
      - desf. econs.
    }
    split; intro AUX.
    - inv AUX.
      rewrite eval_expr_comput in *.
      rewrite IH in *.
      desf.
    - desf.
      econs; eauto.
      + apply eval_expr_comput. eauto.
      + apply IH. ss.
  Qed.

End EVAL_EXPR_COMP.

Section CLIGHT_STEP_DET.
  Variable ge: genv.

  Lemma alloc_variables_det
        e0 m fvars e1 m1 e2 m2
        (ALLOC1: alloc_variables
                   ge e0 m fvars e1 m1)
        (ALLOC2: alloc_variables
                   ge e0 m fvars e2 m2)
    : e1 = e2 /\ m1 = m2.
  Proof.
    depgen e2.
    induction ALLOC1; i; ss.
    { inv ALLOC2. ss. }

    inv ALLOC2. ss.
    match goal with
    | H1: Mem.alloc _ _ _ = _,
          H2: Mem.alloc _ _ _ = _ |- _ =>
      rewrite H2 in H1; clarify
    end.

    hexploit IHALLOC1; eauto.
  Qed.

  Lemma function_entry2_det
        f vargs m
        e1 le1 m1 e2 le2 m2
        (ENTRY1: function_entry2 ge f vargs m e1 le1 m1)
        (ENTRY2: function_entry2 ge f vargs m e2 le2 m2)
    : e1 = e2 /\ le1 = le2 /\ m1 = m2.
  Proof.
    inv ENTRY1. inv ENTRY2.
    match goal with
    | A1: alloc_variables _ _ _ _ _ _,
          A2: alloc_variables _ _ _ _ _ _ |- _ =>
      eapply alloc_variables_det in A1; try apply A2
    end.
    des. clarify.
  Qed.

  Lemma clight_silent_step_det
        st st1 st2
        (STEP1: Clight.step2 ge st [] st1)
        (STEP2: Clight.step2 ge st [] st2)
    : st1 = st2.
  Proof.
    inv STEP1; inv STEP2; ss; try by des; ss.
    (* 12 goals *)
    - f_equal.
      rewrite eval_lvalue_comput in *. clarify.
      rewrite eval_expr_comput in *. clarify.
      rewrite assign_loc_comput in *. clarify.
    - do 2 f_equal.
      rewrite eval_expr_comput in *. clarify.
    - rewrite eval_expr_comput in *. clarify.
      match goal with
      | H1: Cop.classify_fun _ = _,
            H2: Cop.classify_fun _ = _ |- _ =>
        rewrite H2 in H1; inv H1
      end.
      rewrite eval_exprlist_comput in *. clarify.
    - rewrite eval_exprlist_comput in *. clarify.

      assert (vres = vres0 /\ m' = m'0).
      { eapply Events.external_call_deterministic; eauto. }
      des. subst. ss.
    - rewrite eval_expr_comput in *. clarify.
    - clarify.
    - rewrite eval_expr_comput in *. clarify.
    - clarify.
    - rewrite eval_expr_comput in *. clarify.
    - clarify.
    - match goal with
      | H1: function_entry2 _ _ _ _ _ _ _,
            H2: function_entry2 _ _ _ _ _ _ _ |- _ =>
        eapply function_entry2_det in H1; try apply H2
      end.
      des. clarify.
    - assert (vres = vres0 /\ m' = m'0).
      { eapply Events.external_call_deterministic; eauto. }
      des. subst. ss.
  Qed.

End CLIGHT_STEP_DET.

(* Arguments PTree.get : simpl nomatch. *)
(* Arguments PTree.set: simpl nomatch. *)
(* Arguments Nat.sub: simpl nomatch. *)

(** ** lenv_equiv. *)

(* Definition lenv_equiv (le: PTree.t val) *)
(*            (l: list (ident * val)) : Prop := *)
(*   forall i, le ! i = find_ilist i l. *)

Definition ptree_equiv {A} (tr: PTree.t A)
           (l: list (ident * A)): Prop :=
  forall i, tr ! i = find_ilist i l.

Notation lenv_equiv := (@ptree_equiv val).
Notation env_equiv := (@ptree_equiv (block * type)).

(* Record lenv_state (le: PTree.t val) *)
(*        (l: list (ident * val)) : Prop := *)
(*   LenvState *)
(*     { lenv_equiv: forall i, le ! i = find_ilist i l ; }. *)

Lemma update_lenv_equiv
      i v
      (le le': PTree.t val) l l'
      (LENV: lenv_equiv le l)
      (UPD: le' = PTree.set i v le)
      (UPD_L: l' = update_ilist i v l)
  : lenv_equiv le' l'.
Proof.
  subst. rr.
  intros i'.
  rewrite update_ilist_find. ss.
  rewrite PTree.gsspec.
  erewrite <- LENV; eauto.
  destruct (Pos.eqb_spec i i').
  - subst i'.
    rewrite Coqlib.peq_true. ss.
  - rewrite Coqlib.peq_false; eauto.
Qed.

Lemma lenv_finit_temps
      (temps: list (ident * type)) le1
      (TEMP_NOREPET: Coqlib.list_norepet
                       (Clight.var_names temps))
      (LE: Clight.create_undef_temps temps = le1)
  : lenv_equiv le1 (List.map (fun x => (x, Vundef))
                             (Clight.var_names temps)).
Proof.
  depgen le1.
  induction temps as [| [id ty] temps' IH]; i; ss.
  { rr. subst.
    i. rewrite PTree.gempty. ss. }

  inv TEMP_NOREPET.
  hexploit IH; eauto.
  intro IH'. clear IH.
  eapply (update_lenv_equiv id Vundef) in IH';
    try reflexivity.

  erewrite update_ilist_new_id in IH'; ss.
  eapply find_ilist_None.
  apply Forall_forall.
  intros [id' v'] IN ID_EQ.
  ss. subst.
  eapply Coqlib.list_in_map_inv in IN.
  des. clarify.
Qed.

Lemma lenv_finit_params
      params args
      le lst le'
      (NOREPET: Coqlib.list_norepet
                  (Clight.var_names params))
      (LENV_EQUIV: lenv_equiv le lst)
      (DISJ: Coqlib.list_disjoint
               (Clight.var_names params)
               (map fst lst))
      (LE: Clight.bind_parameter_temps
             params args le = Some le')
  : lenv_equiv le' (rev (combine (Clight.var_names params) args) ++ lst).
Proof.
  depgen le. revert args lst DISJ.
  induction params as [| [id_h ?] tp IH]; i; ss.
  { destruct args; ss.
    clarify. }

  inv NOREPET.
  destruct args as [| ha ta]; ss.
  rewrite <- app_assoc. ss.
  cut (lenv_equiv (PTree.set id_h ha le)
                  ((id_h, ha):: lst)).
  { intro LE'. eapply IH in LE'; eauto.
    ii. subst. eapply DISJ; eauto.
    - right. eauto.
    - ss. des; ss.
      subst. congruence.
  }

  clear LE IH.
  cut ((id_h, ha)::lst = update_ilist id_h ha lst).
  { intro RW. rewrite RW.
    eapply update_lenv_equiv; eauto. }

  rewrite update_ilist_new_id; ss.
  apply find_ilist_None.
  apply Forall_forall.
  intros [id' x'] IN. ss.
  hexploit (DISJ id_h id'); ss; eauto.
  apply in_map with (f:=fst) in IN. ss.
Qed.

Lemma lenv_finit
      (params temps: list (ident * type))
      (args: list val)
      le
      (TEMPS_NOREPET: Coqlib.list_norepet
                        (Clight.var_names temps))
      (PARAMS_NOREPET: Coqlib.list_norepet
                         (Clight.var_names params))
      (DISJ: Coqlib.list_disjoint
               (Clight.var_names params)
               (Clight.var_names temps))

      (LE: Clight.bind_parameter_temps
             params args
             (Clight.create_undef_temps temps) =
           Some le)
  : lenv_equiv
      le (rev (combine (Clight.var_names params) args) ++
              (List.map (fun x => (x, Vundef))
                        (Clight.var_names temps))).
Proof.
  eapply lenv_finit_params; eauto.
  2: {
    rewrite map_map. ss.
    rewrite map_id. ss.
  }
  eapply lenv_finit_temps; eauto.
Qed.

Lemma alloc_variables_mem_unch
      ge m vars e m'
      (ALLOC: alloc_variables
                (* (Clight.globalenv cprog) *)
                ge
                empty_env m vars e m')
  : Mem.unchanged_on (fun _ _ => True) m m'.
Proof.
  induction ALLOC; ss.
  { apply Mem.unchanged_on_refl. }
  eapply Mem.unchanged_on_trans; eauto.
  eapply Mem.alloc_unchanged_on; eauto.
Qed.

Lemma clight_function_entry
      ge f args k m
      e m'
      (NREP_VARS: Coqlib.list_norepet
                    (var_names (fn_vars f)))
      (NREP_PARAMS: Coqlib.list_norepet
                      (var_names (fn_params f)))
      (NREP_TEMPS: Coqlib.list_norepet
                      (var_names (fn_temps f)))
      (DISJ_PT: Coqlib.list_disjoint
                  (var_names (fn_params f))
                  (var_names (fn_temps f)))
      (ENV: alloc_variables
              (* (Clight.globalenv cprog) *)
              ge
              empty_env m (fn_vars f) e m')
      (LENV: Clight.bind_parameter_temps
               (fn_params f) args
               (create_undef_temps (fn_temps f)) <> None)
  : exists le,
    <<STEP_ENTRY:
      Clight.step2
        (* (Clight.globalenv cprog) *)
        ge
        (Callstate (Internal f) args k m) []
        (State f (fn_body f) k e le m')>> /\
    (* <<UNCH: Mem.unchanged_on (fun _ _ => True) m m'>> /\ *)
    <<LENV_EQUIV:
      lenv_equiv le
        (rev (combine (var_names (fn_params f)) args)
             ++ (List.map (fun x => (x, Vundef))
                          (var_names (fn_temps f))))>>.
Proof.
  eapply Some_not_None in LENV.
  destruct LENV as [le LENV].
  exists le. esplits.
  - econs; ss.
  (* - eapply alloc_variables_mem_unch; eauto. *)
  - eapply lenv_finit; eauto.
Qed.

Section CPROG_SIM_LEMMAS.
  Context `{sysE: Type -> Type}.
  Context `{errE -< sysE}.
  (* Context `{event_conds sysE}. *)
  Let progE : Type -> Type := osE +' sysE.

  (* Instance progE_conds: event_conds progE. *)
  (* Proof. *)
  (*   unfold progE. *)
  (*   typeclasses eauto. *)
  (* Defined. *)

  Context `{@cprog_event progE}.

  Variable cprog: Clight.program.
  Let prog: @Prog.t progE := prog_of_clight cprog.

  Hypothesis wf_prog: Prog.wf prog.

  Let ge := globalenv cprog.
  Let itree_t: Type := itree progE unit.
  Let state: Type := Prog.state prog.

  (* Variable r: nat -> itree progE unit -> Clight.state -> Prop. *)
  Notation sim := (paco3 (_sim_itree prog)).

  Lemma sim_itree_clight_silent
        (r: nat -> itree _ _ -> Clight.state -> Prop)
        idx itr pst pst'
        (IDX_POS: 0 < idx)
        (SILENT_STEP1: Prog.step _ pst pst')
        (SIM: upaco3 (_sim_itree prog) r
                     (idx - 1) itr pst')
    : sim r idx itr pst.
  Proof.
    des.
    pfold. econs 2.
    { esplits; eauto. }
    inv SILENT_STEP1.
    rename STEP into STEP1.
    i. ss.
    inv PROG_SILENT_STEP.
    rename STEP into STEP2.
    hexploit clight_silent_step_det.
    { apply STEP2. }
    { apply STEP1. }
    i. subst.
    exists (idx - 1).
    esplits.
    { left. splits.
      - econs 1.
      - nia.
    }
    eauto.
  Qed.

  Lemma sim_itree_clight_silent_tau
        (r: nat -> itree _ _ -> Clight.state -> Prop)
        idx idx_n itr itr' pst pst'
        (SILENT_STEP1: Prog.step _ pst pst')
        (OBS_TAU: observe itr = TauF itr')
        (SIM: upaco3 (_sim_itree prog) r
                     idx_n itr' pst')
    : sim r idx itr pst.
  Proof.
    des.
    pfold. econs 2.
    { esplits; eauto. }
    inv SILENT_STEP1.
    rename STEP into STEP1.
    i. ss.
    inv PROG_SILENT_STEP.
    rename STEP into STEP2.
    hexploit clight_silent_step_det.
    { apply STEP2. }
    { apply STEP1. }
    i. subst.
    exists idx_n.
    esplits.
    { right. r.
      esplits; eauto.
      econs 1.
    }
    eauto.
  Qed.

  (** *** loop *)

  Definition for_loop_stmt
             (id_i: ident) (stmt_body: statement)
    (* (i_max: nat) *)
             (e_max: expr)
    : statement :=
    Sloop
      (Ssequence
         (Sifthenelse
            (Ebinop Cop.Olt (Etempvar id_i tint)
                    (* (Econst_int (Int.repr (Z.of_nat i_max)) tint) *)
                    e_max tint)
            Sskip Sbreak)
         stmt_body)
      (Sset id_i (Ebinop Cop.Oadd (Etempvar id_i tint) (Econst_int (Int.repr 1) tint) tint))
  .

  Lemma simple_for_loop_gen
        (r: nat -> itree _ _ -> Clight.state -> Prop)
        (f: Clight.function)
        (id_i: ident)
        (i_min i_max: nat) (e_max: expr)
        (idx0 idx idx_each: nat)
        (stmt_body: statement) k env
        itr le m
        (loop_inv: nat -> itree progE unit ->
                   PTree.t val -> mem -> Prop)
        (LINV_BEGIN: loop_inv i_min itr le m)
        (* (I_VAL_ZERO: le ! id_i = Some (Vint Int.zero)) *)
        (RANGE_I_MIN: i_min <= i_max)
        (RANGE_I_MAX: IntRange.sint i_max)
        (IDX_BIG: (idx0 + (i_max - i_min) * idx_each < idx)%nat)
        (* (E_MAX_CONST: *)
        (*    forall m, eval_expr_c ge env le m e_max = *)
        (*         Some (Vint (IntNat.of_nat i_max))) *)
        (LOOP_BODY_PROOF:
           forall (i: nat)
             idx1 itr1 le1 m1
             (IDX_BIG: idx0 + idx_each < idx1)
             (RANGE_I: (i_min <= i < i_max)%nat)
             (* (I_VAL: le1 ! id_i = Some (Vint (IntNat.of_nat i))) *)
             (LINV: loop_inv i itr1 le1 m1)
             (SIM_NEXT:
                forall itr2 le2 m2
                  (* (I_VAL': le2 ! id_i = Some (Vint (IntNat.of_nat (S i)))) *)
                  (LINV': loop_inv (S i) itr2 le2 m2),
                  sim r (idx1 - idx_each) itr2
                      (State f (for_loop_stmt
                                  id_i stmt_body e_max)
                             k env le2 m2)),
             sim r idx1 itr1
                 (State f (for_loop_stmt
                             id_i stmt_body e_max)
                        k env le1 m1))
        (LOOP_END_PROOF:
           forall itr_e le_e m_e
             (* (I_VAL: le_e ! id_i = Some (Vint (IntNat.of_nat i_max))) *)
             (LINV_END: loop_inv i_max itr_e le_e m_e),
             sim r (idx - (i_max - i_min) * idx_each) itr_e
                 (State f (for_loop_stmt
                             id_i stmt_body e_max)
                        k env le_e m_e))
    : sim r idx itr
          (State f (for_loop_stmt
                      id_i stmt_body e_max)
                 k env le m)
  .
  Proof.
    pose (stmt_lp := for_loop_stmt id_i stmt_body e_max).
    fold stmt_lp.
    fold stmt_lp in LOOP_BODY_PROOF.
    fold stmt_lp in LOOP_END_PROOF.

    assert (MID_AUX:
              forall i_m
                (RANGE_I_M: 0 <= i_m <= i_max - i_min)
                (AFTER: forall itr_m le_m m_m
                          (* (I_VAL: le_m ! id_i = *)
                          (*         Some (Vint (IntNat.of_nat i_m))) *)
                          (LINV: loop_inv (i_min + i_m) itr_m le_m m_m),
                    sim r (idx - i_m * idx_each) itr_m
                        (State f stmt_lp k env le_m m_m)),
                sim r idx itr
                    (State f stmt_lp k env le m)).
    { clear LOOP_END_PROOF.
      intro i_m.
      induction i_m as [| i_m' IH]; i; ss.
      { rewrite Nat.sub_0_r in AFTER.
        rewrite Nat.add_0_r in AFTER.
        eapply AFTER; ss. }

      eapply IH; ss.
      { nia. }
      i.

      eapply (LOOP_BODY_PROOF (i_min + i_m')); eauto.
      { nia. }
      { nia. }

      i.
      replace (idx - i_m' * idx_each - idx_each)
        with (idx - (idx_each + i_m' * idx_each)) by nia.
      eapply AFTER; eauto.
      rewrite plus_n_Sm in LINV'. ss.
    }

    apply MID_AUX with (i_m := i_max - i_min).
    - nia.
    - rewrite le_plus_minus_r by nia.
      eauto.
  Qed.

  Lemma simple_for_loop
        (r: nat -> itree _ _ -> Clight.state -> Prop)
        (f: Clight.function)
        (id_i: ident)
        (i_max: nat) (e_max: expr)
        (idx0 idx idx_each: nat)
        (stmt_body: statement) k env
        itr le m
        (loop_inv: nat -> itree progE unit ->
                   PTree.t val -> mem -> Prop)
        (LINV_BEGIN: loop_inv 0 itr le m)
        (* (I_VAL_ZERO: le ! id_i = Some (Vint Int.zero)) *)
        (RANGE_I_MAX: IntRange.sint i_max)
        (IDX_BIG: (idx0 + i_max * idx_each < idx)%nat)
        (* (E_MAX_CONST: *)
        (*    forall m, eval_expr_c ge env le m e_max = *)
        (*         Some (Vint (IntNat.of_nat i_max))) *)
        (LOOP_BODY_PROOF:
           forall (i: nat)
             idx1 itr1 le1 m1
             (IDX_BIG: idx0 + idx_each < idx1)
             (RANGE_I: (i < i_max)%nat)
             (* (I_VAL: le1 ! id_i = Some (Vint (IntNat.of_nat i))) *)
             (LINV: loop_inv i itr1 le1 m1)
             (SIM_NEXT:
                forall itr2 le2 m2
                  (* (I_VAL': le2 ! id_i = Some (Vint (IntNat.of_nat (S i)))) *)
                  (LINV': loop_inv (S i) itr2 le2 m2),
                  sim r (idx1 - idx_each) itr2
                      (State f (for_loop_stmt
                                  id_i stmt_body e_max)
                             k env le2 m2)),
             sim r idx1 itr1
                 (State f (for_loop_stmt
                             id_i stmt_body e_max)
                        k env le1 m1))
        (LOOP_END_PROOF:
           forall itr_e le_e m_e
             (* (I_VAL: le_e ! id_i = Some (Vint (IntNat.of_nat i_max))) *)
             (LINV_END: loop_inv i_max itr_e le_e m_e),
             sim r (idx - i_max * idx_each) itr_e
                 (State f (for_loop_stmt
                             id_i stmt_body e_max)
                        k env le_e m_e))
    : sim r idx itr
          (State f (for_loop_stmt
                      id_i stmt_body e_max)
                 k env le m)
  .
  Proof.
    eapply simple_for_loop_gen with
        (i_min := 0) (i_max := i_max); eauto.
    - nia.
    - rewrite Nat.sub_0_r. apply IDX_BIG.
    - i. eapply LOOP_BODY_PROOF; eauto.
      nia.
    - i. rewrite Nat.sub_0_r.
      apply LOOP_END_PROOF. eauto.
  Qed.

  Definition KWhile1 e s :=
    Kloop1 (Ssequence (Sifthenelse e Sskip Sbreak) s) Sskip.

  Definition KWhile2 e s :=
    Kloop2 (Ssequence (Sifthenelse e Sskip Sbreak) s) Sskip.

  Ltac fold_KWhile1 :=
    match goal with
    | |- context [Kloop1 (Ssequence (Sifthenelse ?e _ _) ?s) _ ?k] =>
      fold (KWhile1 e s k)
    end.

  Ltac fold_KWhile2 :=
    match goal with
    | |- context [Kloop2 (Ssequence (Sifthenelse ?e _ _) ?s) _ ?k] =>
      fold (KWhile2 e s k)
    end.

  Lemma sim_while
        (r: nat -> itree _ _ -> Clight.state -> Prop)
        (linv: itree progE unit ->
               PTree.t val -> mem -> Prop)
        idx itr f expr_c s k e le m

        (INIT_LOOP_INV: linv itr le m)
        (LINV_EXPR_COMPUTABLE:
           forall itr' le' m' (LINV: linv itr' le' m'),
             exists v1 b,
             eval_expr_c ge e le' m' expr_c = Some v1 /\
             Cop.bool_val v1 (typeof expr_c) m' = Some b)
        (LOOP_BODY_PROOF:
           forall r' itr_c le_c m_c v1
             (R_INCL: r <3= r')
             (LOOP_INV: linv itr_c le_c m_c)
             (EVAL_EXPR: eval_expr_c ge e le_c m_c expr_c = Some v1)
             (COND_TRUE: Cop.bool_val v1 (typeof expr_c) m_c = Some true)
             (CIH: forall itr_n le_n m_n
                     (LOOP_INV: linv itr_n le_n m_n),
                 r' (idx + 5) itr_n
                   (State f (Swhile expr_c s)
                          k e le_n m_n))
           ,
             sim r' idx itr_c (State f s (KWhile1 expr_c s k) e le_c m_c))
        (LOOP_FINAL:
           forall r' itr_f le_f m_f v1
             (R_INCL: r <3= r')
             (LOOP_INV: linv itr_f le_f m_f)
             (EVAL_EXPR: eval_expr_c ge e le_f m_f expr_c = Some v1)
             (COND_FALSE: Cop.bool_val v1 (typeof expr_c) m_f = Some false),
             sim r' idx itr_f (State f Sskip k e le_f m_f))
    : sim r (idx + 5) itr (State f (Swhile expr_c s) k e le m).
  Proof.
    revert itr le m INIT_LOOP_INV.
    pcofix CIH. i.

    eapply sim_itree_clight_silent; [nia| |left].
    { ss. econs; ss. econs. }
    eapply sim_itree_clight_silent; [nia| |left].
    { ss. econs; ss. econs. }

    hexploit LINV_EXPR_COMPUTABLE; eauto.
    intros (v1 & b & EVAL_EXPR_C & BOOL_VAL_C).
    destruct b.
    - (* true *)
      eapply sim_itree_red_idx with (idx_small:=idx + 2).
      { nia. }
      eapply sim_itree_clight_silent; [nia| |left].
      { ss. econs; ss. econs.
        - eapply eval_expr_comput; eauto.
        - eauto.
      }
      ss.
      eapply sim_itree_clight_silent; [nia| |left].
      { ss. econs; ss. econs. }
      eapply sim_itree_red_idx with (idx_small:=idx).
      { nia. }

      fold_KWhile1.
      eapply LOOP_BODY_PROOF; eauto.

    - (* false *)
      eapply sim_itree_clight_silent; [nia| |left].
      { ss. econs; ss. econs.
        - eapply eval_expr_comput; eauto.
        - eauto.
      }
      ss.
      eapply sim_itree_clight_silent; [nia| |left].
      { ss. econs; ss. econs. }
      eapply sim_itree_clight_silent; [nia| |left].
      { ss. econs; ss. eapply step_break_loop1. }
      eapply sim_itree_red_idx with (idx_small:=idx).
      { nia. }
      eauto.
  Qed.

End CPROG_SIM_LEMMAS.

Ltac fold_for_loop i :=
  match goal with
  | |- context [ Sloop (Ssequence ?s1 ?stmt) ?b ] =>
    match s1 with
    | Sifthenelse
        (Ebinop Cop.Olt (Etempvar i tint) ?e_max tint)
        Sskip Sbreak =>
      replace (Sloop (Ssequence s1 stmt) b)
        with (for_loop_stmt i stmt e_max); [| by ss]
    end
  end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D Aprime Bprime Cprime Dprime X Y E Z : Universe, ((wd_ X A /\ (wd_ X Aprime /\ (wd_ X C /\ (wd_ X Cprime /\ (wd_ Y B /\ (wd_ Y Bprime /\ (wd_ Y D /\ (wd_ Y Dprime /\ (wd_ A C /\ (wd_ B D /\ (wd_ A Aprime /\ (wd_ E Z /\ (wd_ A B /\ (wd_ X Y /\ (wd_ X B /\ (wd_ A Y /\ (wd_ B C /\ (wd_ Bprime Cprime /\ (wd_ A D /\ (wd_ Aprime Dprime /\ (wd_ Aprime Bprime /\ (col_ X A C /\ (col_ X A Aprime /\ (col_ X A Cprime /\ (col_ Y B D /\ (col_ Y B Bprime /\ (col_ Y B Dprime /\ (col_ E A B /\ (col_ E C D /\ (col_ X E Z /\ (col_ A E Z /\ (col_ B E Z /\ col_ Y E Z)))))))))))))))))))))))))))))))) -> col_ E Y B)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext uniq_tac machine_int.
Require Import multi_int.
Import MachineInt.
Require Import mips_seplog mips_tactics mips_contrib mapstos multi_halve_u_prg.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope multi_int_scope.

Lemma multi_halve_u_triple k a i tmp prev next : uniq(k, a, i, tmp, prev, next, r0) ->
  forall nk va, u2Z va + 4 * Z_of_nat nk < \B^1 ->
    forall A, size A = nk ->
      {{ fun s h => [ a ]_s = va /\ u2Z [ k ]_s = Z_of_nat nk /\ (var_e a |--> A) s h }}
      multi_halve_u k a i tmp prev next
      {{ fun s h => exists A', size A' = nk /\ [a]_s = va /\ u2Z [ k ]_s = Z_of_nat nk /\
        (var_e a |--> A') s h /\ 2 * \S_{ nk } A' + u2Z ([prev]_s `>> 31) = \S_{ nk } A }}.
Proof.
move=> Hset nk va Hna A HA; rewrite /multi_halve_u.

(** addiu i k zero16; *)

apply hoare_addiu with (fun s h => [a]_s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i]_s = Z_of_nat nk /\ (var_e a |--> A) s h).

move=> s h [Hra [Hri Hmem]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by rewrite sext_0 addi0.
by Assert_upd.

(** addiu prev r0 zero16; *)

apply hoare_addiu with (fun s h => [a]_s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i]_s = Z_of_nat nk /\ [prev]_s = zero32 /\ (var_e a |--> A) s h).

move=> s h [Hra [Hri [Hrk Hmem]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by rewrite sext_0 addi0.
by Assert_upd.

(** while (bne i r0) *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni <= nk)%nat /\
  (var_e a |--> A') s h /\
  take ni A' = take ni A /\
  2 * \S_{ nk - ni } (drop ni A') + u2Z ([prev]_s `>> 31) = \S_{ nk - ni } (drop ni A)).

move=> s h [Hra [Hrk [Hri [Hrprev Hmem]]]].
exists A, nk; repeat (split; trivial).
by rewrite Hrprev; left.
rewrite (_ : (_ - _ = O)%nat) /=; last by rewrite subnn.
by rewrite Hrprev shrl_Z2u_0 // Z2uK.

move=> s h [[A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 Hinv2]]]]]]]]]] Hri'].
rewrite /= in Hri'. move/negPn/eqP in Hri'.
have {Hri'} ? : ni = O.
  apply Z_of_nat_inj; by rewrite -Hri Hri' /= store.get_r0 Z2uK.
subst ni.
rewrite subn0 2!drop0 in Hinv2.
exists A'; by repeat (split; trivial).

(**  addiu i i mone16; *)

apply hoare_addiu with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 * \S_{ nk - ni.+1} (drop ni.+1 A') + u2Z ([prev ]_ s `>> 31) = \S_{ nk - ni.+1} (drop ni.+1 A)).

move=> s h [[A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 Hinv2]]]]]]]]]] Hri'].
rewrite /= store.get_r0 Z2uK // in Hri'.
move/eqP in Hri'.
exists A', (ni - 1)%nat.
repeat Reg_upd.
rewrite Hri (_ : 0 = Z_of_nat 0) // in Hri'; apply Z_of_nat_inj_neq, not_eq_sym in Hri'.
rewrite -subSn; last by rewrite lt0n; apply/eqP; auto.
rewrite subSS subn0.
repeat (split; trivial).
- rewrite sext_Z2s // u2Z_add_Z2s //; last first.
    rewrite Hri -(mul1Z (-1)) mulZN1 leZ_subRL addZ0 (_ : 1 = Z<=nat 1) //.
    exact/inj_le/neq_0_lt.
  rewrite inj_minus1 //; by [rewrite Hri | apply neq_0_lt].
- by Assert_upd.

(** lwxs tmp i a; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists A' ni, length A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 * \S_{nk - ni.+1} (drop ni.+1 A') + u2Z ([prev ]_ s `>> 31) = \S_{nk - ni.+1} (drop ni.+1 A) /\
  [tmp]_s = A' `32_ ni).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 Hinv2]]]]]]]]]].
exists (A' `32_ ni); split.
- Decompose_32 A' ni A1 A2 HlenA1 HA'; last by rewrite HlenA'.
  rewrite HA' (decompose_equiv _ _ _ _ _ HlenA1) in Hmem.
  rewrite conCE !conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u inj_mult Hri [Zmult]lock /= -lock mulZC.
- rewrite /update_store_lwxs.
  exists A', ni; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(** andi next tmp one16; *)

apply hoare_andi with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 * \S_{nk - ni.+1} (drop ni.+1 A') + u2Z ([prev ]_ s `>> 31) = \S_{nk - ni.+1} (drop ni.+1 A) /\
  [tmp]_s = A' `32_ ni /\
  [next]_s = (A' `32_ ni) `& one32).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 Htmp]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite Htmp zext_Z2u.

(** srl tmp tmp one5; *)

apply hoare_srl with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 * \S_{nk - ni.+1} (drop ni.+1 A') + u2Z ([prev ]_ s `>> 31) = \S_{nk - ni.+1} (drop ni.+1 A) /\
  [tmp]_s = (A' `32_ ni) `>> 1 /\
  [next]_s = (A' `32_ ni) `& one32).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite Htmp Z2uK.

(** cmd_or tmp tmp prev; *)

apply hoare_or with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 * \S_{nk - ni.+1} (drop ni.+1 A') + u2Z ([prev ]_ s `>> 31) = \S_{nk - ni.+1} (drop ni.+1 A) /\
  [tmp]_s = ((A' `32_ ni) `>> 1) `|` [prev]_s /\
  [next]_s = (A' `32_ ni) `& one32).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite Htmp.

(** addiu prev next zero16; *)

apply hoare_addiu with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = one32) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 ^^ 33 * \S_{nk - ni.+1} (drop ni.+1 A') + 2 * u2Z ([tmp]_s) + u2Z ([prev ]_ s) = \S_{ nk - ni } (drop ni A) /\
  [tmp]_s `% 31 = ((A' `32_ ni) `>> 1) `% 31 /\
  [next]_s = (A' `32_ ni) `& one32).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
rewrite /wp_addiu; exists A', ni; repeat Reg_upd; repeat (split; trivial).
- rewrite sext_0 addi0 Hnext.
  case: (Zeven_odd_dec (u2Z (A' `32_ ni))).
  + move/int_even_and_1; by left.
  + move/int_odd_and_1; by right.
- by Assert_upd.
- rewrite (@drop_nth _ zero32 ni) ; last by rewrite HA.
  rewrite (_ : nk - ni = (nk - ni.+1).+1)%nat; last by rewrite -subSn.
  rewrite lSum_S Hnext Htmp.
  have -> : 2 * u2Z ((A' `32_ ni `>> 1) `|` [prev ]_ s) =
    2 * u2Z (A' `32_ ni `>> 1) + 2 * u2Z ([prev ]_ s).
    case: Hprev => Hprev.
    - by rewrite Hprev Z2uK // mulZ0 addZ0 int_or_0 //.
    - rewrite int_orC (@or_concat 32 _ _ 31 Logic.eq_refl); last 2 first.
        by move: (shrl_lt (A' `32_ ni) 1).
        apply u2Z_inj.
        move: (@u2Z_rem'' _ ([prev ]_ s) 30 1).
        rewrite {1}Hprev Z2uK // => -> //; by rewrite Z2uK.
      rewrite /cast_subnK u2Z_cast u2Z_concat u2Z_shr_shrink' //.
      rewrite Hprev !Z2uK // rem_Zpower // !Z2uK //.
      ring_simplify.
      rewrite u2Z_rem' //.
      by move: (shrl_lt (A' `32_ ni) 1).
  have -> : u2Z (A `32_ ni) = 2 * u2Z (A' `32_ ni `>> 1) + u2Z (A' `32_ ni `& one32).
    rewrite -(@u2Z_shrl 32 _ 1); last by repeat constructor.
    rewrite [_ ^^ _]/=.
    ring_simplify.
    rewrite (take_nth zero32) in Hinv1; last by rewrite HlenA'.
    rewrite (take_nth zero32) in Hinv1; last by rewrite HA.
    move/eqP : Hinv1.
    rewrite eqseq_rcons => /andP [/eqP Hinv' /eqP Hinv''].
    by rewrite /nth' Hinv'' int_and_rem_1.
  rewrite -Hinv2.
  suff -> : 2 * u2Z ([prev ]_ s) = 2 ^^ 32 * u2Z ([prev ]_ s `>> 31).
    rewrite mulZDr ZpowerS sext_0 addi0; ring.
- case: Hprev => Hprev.
  + by rewrite Hprev Z2uK // mulZ0 shrl_Z2u_0 Z2uK.
  + by rewrite Hprev Z2uK // shrl_Zpower // ssrnat.subnn Z2uK.
- rewrite Htmp.
  case: Hprev => ->.
  + by rewrite int_or_0.
  + by rewrite rem_distr_or rem_Zpower // int_or_0.

(** sll prev prev thirtyone5; *)

apply hoare_sll with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 ^^ 33 * \S_{nk - ni.+1} (drop ni.+1 A') + 2 * u2Z ([tmp]_s) + u2Z ([prev]_ s `>> 31) =
  \S_{ nk - ni} (drop ni A) /\
  [tmp]_s `% 31 = ((A' `32_ ni) `>> 1) `% 31 /\
  [next]_s = (A' `32_ ni) `& one32).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
- case : Hprev => ->.
  + rewrite shl_zero; by left.
  + rewrite Z2uK // shl_1 //; by right.
- by Assert_upd.
- case : Hprev => Hprev.
  + by rewrite Hprev shl_zero shrl_Z2u_0 Z2uK // -Hinv2 Hprev Z2uK.
  + rewrite Z2uK // (_ : '|31| = 31%nat) //.
    by rewrite Hprev (@shl_1 32 31 erefl) shrl_Zpower // -Hinv2 ssrnat.subnn [2 ^^ 0]/= Hprev.

(** sll next i two5; *)

apply hoare_sll with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2^^31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 ^^ 33 * \S_{nk - ni.+1} (drop ni.+1 A') + 2 * u2Z ([tmp]_s) + u2Z ([prev]_ s `>> 31) =
  \S_{ nk - ni } (drop ni A) /\
  [tmp]_s `% 31 = (A' `32_ ni `>> 1) `% 31 /\
  u2Z [next]_s = 4 * Z_of_nat ni).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite Z2uK // (_ : '| 2 | = 2%nat) // (@u2Z_shl 2 _ _ 30) //.
- by rewrite Hri [_ ^^ _]/= mulZC.
- rewrite (_ : \B^1 = 4 * 2 ^^ 30) in Hna; last by rewrite Zbeta1E.
  move: (min_u2Z va) => ?; ssromega.

(** addu next a next; *)

apply hoare_addu with (fun s h => exists A' ni, size A' = nk /\
  [a ]_ s = va /\ u2Z [k]_s = Z_of_nat nk /\
  u2Z [i ]_ s = Z_of_nat ni /\
  ([prev]_s = zero32 \/ [prev]_s = Z2u 32 (2 ^^ 31)) /\
  (ni < nk)%nat /\
  (var_e a |--> A') s h /\
  take ni.+1 A' = take ni.+1 A /\
  2 ^^ 33 * \S_{nk - ni.+1} (drop ni.+1 A') + 2 * u2Z ([tmp]_s) + u2Z ([prev]_ s `>> 31) =
  \S_{ nk - ni } (drop ni A) /\
  [tmp]_s `% 31 = (A' `32_ ni `>> 1) `% 31 /\
  u2Z [next]_s = u2Z va + 4 * Z_of_nat ni).

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Htmp Hnext]]]]]]]]]]]].
exists A', ni; repeat Reg_upd; repeat (split; trivial).
- by Assert_upd.
- rewrite u2Z_add.
  + rewrite Hra Hnext; ring.
  + rewrite (_ : \B^1 = 4 * 2 ^^ 30) in Hna; last by rewrite Zbeta1E.
    rewrite (_ : 2 ^^ 32 = 4 * 2 ^^ 30) // Hnext Hra; ssromega.

(** sw tmp zero16 next *)

apply hoare_sw_back'.

move=> s h [A' [ni [HlenA' [Hra [Hrk [Hri [Hprev [Hik [Hmem [Hinv1 [Hinv2 [Hrtmp Hrnext]]]]]]]]]]]].

have Htmp : [ var_e next \+ int_e (sext 16 zero16) ]e_ s = [ var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * ni))) ]e_ s.
  rewrite /= sext_0 addi0.
  apply u2Z_inj.
  rewrite u2Z_add_Z_of_nat.
  rewrite inj_mult Hra Hrnext //; ring.
  rewrite inj_mult -Zbeta1E Hra; simpl Z_of_nat; ssromega.

Decompose_32 A' ni A'1 A'2 HlenA1 HA'; last by rewrite HlenA'.
rewrite HA' (decompose_equiv _ _ _ _ _ HlenA1) in Hmem.
rewrite conCE !conAE in Hmem.
exists (int_e (A' `32_ ni)).
move: Hmem; apply monotony => ht.
exact: mapsto_ext.
apply currying => h' H'; simpl app in H'.
exists (upd_nth A' ni [tmp]_s), ni.
repeat (split; trivial).
- by apply size_upd_nth.
- by apply ltnW.
- rewrite HA' upd_nth_cat HlenA1 // (_ : (ni - ni = 0)%nat); last by rewrite subnn.
  rewrite /= (decompose_equiv _ _ _ _ _ HlenA1).
  rewrite cat0s in H'.
  assoc_comm H'.
  move: H'; by apply mapsto_ext.
- rewrite HA' upd_nth_cat; last by rewrite HlenA1.
  rewrite take_size_cat //.
  rewrite (take_nth zero32) in Hinv1; last by rewrite HlenA'.
  rewrite (take_nth zero32) in Hinv1; last by rewrite HA.
  move/eqP : Hinv1.
  rewrite eqseq_rcons => /andP [/eqP <- _].
  by rewrite HA' take_size_cat.
- rewrite -Hinv2.
  f_equal.
  rewrite HA' upd_nth_cat; last by rewrite HlenA1.
  rewrite drop_size_cat // HlenA1 subnn [upd_nth _ _ _]/=.
  have -> : (nk - ni = (nk - ni.+1).+1)%nat by rewrite -subSn.
  rewrite lSum_S -cat1s catA drop_size_cat; last by rewrite size_cat /= HlenA1 addnC.
  by ring_simplify.
Qed.