Require Import Coq.Init.Nat.
Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import compcert.lib.Integers.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import WhileDB.SetsDomain.
Require Import WhileDB.RelDomain.
Require Import WhileDB.BWFix.
Require Import WhileDB.Lang.

Local Open Scope list.
Local Open Scope bool.
Local Open Scope Z.
Local Open Scope sets.

  (*证明三元关系和subseteq构成一个偏序关系*)
  #[export] Instance R_while_fin {A B C: Type}: Order (A -> B -> C -> Prop) :=
  Sets.included.
#[export] Instance Equiv_while_fin {A B C: Type}: Equiv (A -> B -> C -> Prop) :=
  Sets.equiv.
#[export] Instance PO_while_fin {A B C: Type}: PartialOrder_Setoid (A -> B -> C -> Prop).
Proof.
  split.
  + unfold Reflexive_Setoid.
    unfold equiv, order_rel, R_while_fin, Equiv_while_fin; simpl.
    sets_unfold; intros a b H x y z H0.
    specialize (H x y z). unfold iff in H;destruct H;auto.
  + unfold Transitive.
    unfold equiv, order_rel, R_while_fin, Equiv_while_fin; simpl.
    sets_unfold; intros a b c H H0 x y z.
    specialize (H x y z);specialize (H0 x y z).
    tauto.
  + unfold AntiSymmetric_Setoid.
    unfold equiv, order_rel, R_while_fin, Equiv_while_fin; simpl.
    sets_unfold; intros a b H H0 x y z.
    specialize (H x y z);specialize (H0 x y z).
    tauto.
Qed.
(** 下面再定义上确界计算函数与完备偏序集中的最小值。*)
#[export] Instance oLub_while_fin {A B C: Type}: OmegaLub (A -> B -> C-> Prop) :=
  Sets.omega_union.

#[export] Instance Bot_while_fin {A B C: Type}: Bot (A -> B-> C-> Prop) :=
  ∅: A -> B -> C-> Prop.

(** 下面证明这构成一个Omega完备偏序集。*)
#[export] Instance oCPO_while_fin {A B C: Type}:
  OmegaCompletePartialOrder_Setoid (A -> B -> C-> Prop).
Proof.
  split.
  + apply PO_while_fin.
  + unfold increasing, is_omega_lub, is_omega_ub, is_lb.
    unfold omega_lub, order_rel, R_while_fin, oLub_while_fin; simpl.
    sets_unfold; intros T H.
    split.
    - intros n x y z; intros.
      exists n.
      tauto.
    - intros a H0 x y z H1.
      destruct H1 as [n ?].
      specialize (H0 n x y z).
      tauto.
  + unfold is_least.
    unfold bot, order_rel, R_while_fin, Bot_while_fin; simpl.
    sets_unfold; intros a.
    tauto.
Qed.

(** 额外需要补充一点：_[Equiv_while_fin]_确实是一个等价关系。先前Bourbaki-Witt不
    动点定理的证明中用到了这一前提。证明可见SetsDomain.v*)
#[export] Instance Equiv_equiv_while_fin {A B C: Type}:
  Equivalence (@equiv (A -> B -> C-> Prop) _).
Proof.
  (*Print Sets_equiv_equiv.*)
  apply Sets_equiv_equiv.
Qed.

Print Rels.
(*https://www.cis.upenn.edu/~plclub/blog/2020-05-15-Rewriting-in-Coq/*)

#[export] Instance TriRel_concat_included_congr :
forall (R S T : Type) (W: Rels.RELS R S T)         {_SETS_R: Sets.SETS R}
        {_SETS_S: Sets.SETS S}
        {_SETS_T: Sets.SETS T}
        {_RELS_Properties: RELS_Properties R S T}
        {_SETS_Properties_R: SETS_Properties R}
        {_SETS_Properties_S: SETS_Properties S}
        {_SETS_Properties_T: SETS_Properties T}
        ,
Proper
      (Sets.equiv ==> Sets.equiv ==> Sets.equiv)
      (@Rels.concat R S T W).
Proof.
  Compute Rels.concat.
  Print Rels.concat.
  intros.
  Compute @Rels.concat R S T W.
  Compute @Rels.concat R S T W.
  Compute R->S->T .
  Compute concat.
  Search concat.
  unfold Proper, respectful. intros.
  apply Sets_equiv_Sets_included. split.
  + apply Rel_concat_mono.
    - rewrite H; reflexivity.
    - rewrite H0; reflexivity.
  + apply Rel_concat_mono.
    - rewrite H; reflexivity.
    - rewrite H0; reflexivity.
Qed.

Lemma Rels_concat_left_mono:
  forall (A B C D: Type) (Y: A -> list B -> C-> Prop),
    mono (fun X: C -> list B -> D-> Prop => Y ∘ X).
Proof.
  intros.
  unfold mono.
  unfold order_rel, R_while_fin.
  intros.
  Compute Rels.concat Y a1.
  pose proof TriRel_concat_included_congr.
  rel_unfold.
  sets_unfold.
  intros. destruct H1 as [? [? [? [? [ ? ?]]]]].
  exists x.
  exists x0. exists x1.
  repeat split;auto.
  revert H. sets_unfold.
  intros. specialize (H x x1 a3). auto.
Qed.

Lemma Rels_concat_left_continuous:
forall (A B C D: Type) (Y: A ->list B -> C-> Prop),
    continuous (fun X: C -> list B -> D -> Prop => Y ∘ X).
Proof.
  intros.
  unfold continuous.
  unfold increasing, omega_lub, order_rel, equiv,
         oLub_while_fin, R_while_fin, Equiv_while_fin, iff.
  sets_unfold; rel_unfold.
  unfold iff.
  intros. split;intros.
  +  destruct H0 as [? [? [? [? [? [? ?]]]]]]. exists x2; exists x; exists x0; exists x1. auto.
  +  destruct H0 as [? [? [? [? [? [? ?]]]]]]. exists x0; exists x1; exists x2. repeat split; try auto. exists x. auto.
Qed.

Lemma Rels_concat_left_mono_and_continuous:
  forall
    (A B C D: Type)
    (Y: A -> list B -> C -> Prop)
    (f: (A -> list B -> C -> Prop) -> (C -> list B -> D -> Prop)),
  mono f /\ continuous f ->
  mono (fun X => Y ∘ f X) /\ continuous (fun X => Y ∘ f X).
Proof.
  intros.
  destruct H.
  pose proof Rels_concat_left_mono A B C D Y.
  pose proof Rels_concat_left_continuous A B C D Y.
  split.
  + exact (compose_mono f _ H H1).
  + exact (compose_continuous f _ H H1 H0 H2).
Qed.

(** 下面证明前面提到的步骤(3)：如果_[F]_是单调连续的，那么_[G(X) = Y ∘ F(X)]_也
    是单调连续的。主结论为_[union_right2_mono_and_continuous]_，其用到了两条下面
    的辅助引理以及前面证明过的复合函数单调连续性定理。*)

Lemma union_right2_mono:
  forall (A B C: Type) (Y: A -> list B -> C-> Prop),
    mono (fun X => X ∪ Y).
Proof.
  intros.
  unfold mono.
  unfold order_rel, R_while_fin.
  sets_unfold.
  intros.
  specialize (H a a0 a3).
  tauto.
Qed.

Lemma union_right2_continuous:
  forall (A B C: Type) (Y: A -> list  B -> C-> Prop),
    continuous (fun X => X ∪ Y).
Proof.
  intros.
  unfold continuous.
  unfold increasing, omega_lub, order_rel, equiv,
         oLub_while_fin, R_while_fin, Equiv_while_fin.
  sets_unfold.
  intros. split;intros.
  + destruct H0 as [[? ?] |?].
    - exists x; auto.
    - exists O. right;auto.
  + destruct H0 as [n [? | ? ] ].
    2:{  right;auto. }
    { left. exists n. auto.  }
Qed.

Lemma union_right2_mono_and_continuous:
  forall
    (A B C D: Type)
    (Y: C -> list B -> D-> Prop)
    (f: (A -> list B -> C -> Prop) -> (C ->list  B -> D-> Prop)),
  mono f /\ continuous f ->
  mono (fun X => f X ∪ Y) /\ continuous (fun X => f X ∪ Y).
Proof.
  intros.
  destruct H.
  pose proof union_right2_mono _ _ _ Y.
  pose proof union_right2_continuous _ _ _ Y.
  split.
  + exact (compose_mono f _ H H1).
  + exact (compose_continuous f _ H H1 H0 H2).
Qed.

(* ===================== Prepare for err ==========================*)


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Crypto.Bedrock.Field.Synthesis.Generic.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Synthesis.Specialized.WordByWordMontgomery.
Require Import Crypto.Bedrock.Field.Translation.Parameters.Defaults64.
Local Open Scope Z_scope.

Local Definition m := 2^224 - 2^96 + 1.
Local Existing Instances default_parameters default_parameters_ok.
Local Definition prefix := "p224_"%string. (* placed before function names *)

Instance names : names_of_operations.
  make_names_of_operations prefix. Defined.

Definition ops : wbwmontgomery_reified_ops m.
  make_reified_ops. Time Defined.

Instance p224_bedrock2_funcs : bedrock2_wbwmontgomery_funcs.
funcs_from_ops ops. Defined.

Instance p224_bedrock2_specs : bedrock2_wbwmontgomery_specs.
Proof. specs_from_ops ops m. Defined.

Instance p224_bedrock2_correctness : bedrock2_wbwmontgomery_correctness.
Proof. prove_correctness ops m. Qed.

(*
Require Import bedrock2.NotationsCustomEntry.
Require Import bedrock2.NotationsInConstr.
Require Import bedrock2.Syntax.
Coercion expr.var : string >-> Syntax.expr.
Local Open Scope bedrock_expr.
Eval cbv [add p224_bedrock2_funcs] in add.
Eval cbv [spec_of_add p224_bedrock2_specs] in spec_of_add.
*)


Section group_morphism.

(* An example with default canonical structures *)

Variable A B : Type.
Variable plusA : A -> A -> A.
Variable plusB : B -> B -> B.
Variable zeroA : A.
Variable zeroB : B.
Variable eqA : A -> A -> Prop.
Variable eqB : B -> B -> Prop.
Variable phi : A -> B.

Record img := {
  ia : A;
  ib :> B;
  prf : phi ia = ib
}.

Parameter eq_img : forall (i1:img) (i2:img),
  eqB (ib i1) (ib i2) -> eqA (ia i1) (ia i2).

Lemma phi_img (a:A) : img.
  exists  a (phi a).
  refine ( refl_equal _).
Defined.
Canonical Structure phi_img.

Lemma zero_img : img.
  exists zeroA zeroB.
  admit.
Defined.
Canonical Structure zero_img.

Lemma plus_img : img -> img -> img.
intros i1 i2.
exists (plusA (ia i1) (ia i2)) (plusB (ib i1) (ib i2)).
admit.
Defined.
Canonical Structure plus_img.

(* Print Canonical Projections. *)

Goal forall a1 a2, eqA (plusA a1 zeroA) a2.
  intros a1 a2.
  refine  (eq_img _ _  _).
change (eqB (plusB (phi a1) zeroB) (phi a2)).
Admitted.

End group_morphism.

Open Scope type_scope.

Section type_reification.

Inductive term :Type :=
   Fun : term -> term -> term
 | Prod : term -> term -> term
 | Bool : term
 | SET :term
 | PROP :term
 | TYPE :term
 | Var : Type -> term.

Fixpoint interp (t:term) :=
  match t with
    Bool => bool
  | SET => Set
  | PROP => Prop
  | TYPE => Type
  | Fun a b => interp a -> interp b
  | Prod a b => interp a * interp b
  | Var x => x
end.

Record interp_pair :Type :=
  { repr:>term;
    abs:>Type;
    link: abs = interp repr }.

Lemma prod_interp :forall (a b:interp_pair),a * b = interp (Prod a b) .
proof.
let a:interp_pair,b:interp_pair.
reconsider thesis as (a * b = interp a * interp b).
thus thesis by (link a),(link b).
end proof.
Qed.

Lemma fun_interp :forall (a b:interp_pair), (a -> b) = interp (Fun a b).
proof.
let a:interp_pair,b:interp_pair.
reconsider thesis as ((a -> b) = (interp a -> interp b)).
thus thesis using rewrite (link a);rewrite (link b);reflexivity.
end proof.
Qed.

Canonical Structure ProdCan (a b:interp_pair) :=
  Build_interp_pair (Prod a b) (a * b) (prod_interp a b).

Canonical Structure FunCan (a b:interp_pair) :=
  Build_interp_pair (Fun a b) (a -> b) (fun_interp a b).

Canonical Structure BoolCan :=
  Build_interp_pair Bool bool (refl_equal _).

Canonical Structure VarCan (x:Type) :=
  Build_interp_pair (Var x) x (refl_equal _).

Canonical Structure SetCan :=
  Build_interp_pair SET Set (refl_equal _).

Canonical Structure PropCan :=
  Build_interp_pair PROP Prop (refl_equal _).

Canonical Structure TypeCan :=
  Build_interp_pair TYPE Type (refl_equal _).

(* Print Canonical Projections. *)

Variable A:Type.

Variable Inhabited: term -> Prop.

Variable Inhabited_correct: forall p, Inhabited (repr p)  -> abs p.

Lemma L : Prop * A -> bool * (Type -> Set) .
refine (Inhabited_correct _ _).
change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))).
Admitted.

Check L : abs _ .

End type_reification.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Inverse_Image.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Author: Bruno Barras *)

Section Inverse_Image.

  Variables A B : Type.
  Variable R : B -> B -> Prop.
  Variable f : A -> B.

  Let Rof (x y:A) : Prop := R (f x) (f y).

  Remark Acc_lemma : forall y:B, Acc R y -> forall x:A, y = f x -> Acc Rof x.
  Proof.
    induction 1 as [y _ IHAcc]; intros x H.
    apply Acc_intro; intros y0 H1.
    apply (IHAcc (f y0)); try trivial.
    rewrite H; trivial.
  Qed.

  Lemma Acc_inverse_image : forall x:A, Acc R (f x) -> Acc Rof x.
  Proof.
    intros; apply (Acc_lemma (f x)); trivial.
  Qed.

  Theorem wf_inverse_image : well_founded R -> well_founded Rof.
  Proof.
    red in |- *; intros; apply Acc_inverse_image; auto.
  Qed.

  Variable F : A -> B -> Prop.
  Let RoF (x y:A) : Prop :=
    exists2 b : B, F x b & (forall c:B, F y c -> R b c).

  Lemma Acc_inverse_rel : forall b:B, Acc R b -> forall x:A, F x b -> Acc RoF x.
  Proof.
    induction 1 as [x _ IHAcc]; intros x0 H2.
    constructor; intros y H3.
    destruct H3.
    apply (IHAcc x1); auto.
  Qed.

  Theorem wf_inverse_rel : well_founded R -> well_founded RoF.
  Proof.
    red in |- *; constructor; intros.
    case H0; intros.
    apply (Acc_inverse_rel x); auto.
  Qed.

End Inverse_Image.


From Equations Require Import Equations DepElimDec HSets.
(* Set Universe Polymorphism. *)
(** Can we define NoConfusion in SProp (squashing equalities of arguments)?
    Would not allow to show equivalence to (x = y) for non-strict sets. *)

Unset Equations WithK.
Inductive fin : nat -> Set :=
| fin0 n : fin (S n)
| finS n : fin n -> fin (S n).
Derive Signature for fin.

Arguments fin0 {_}.
Arguments finS {_} _.

Inductive fin_param : forall n, fin n -> Set :=
| finS_param : forall n (f : fin n),
                  fin_param n f ->
                  fin_param (S n) (finS f).
Derive Signature for fin_param.

(* Derive NoConfusion for ℕ. *)
Derive NoConfusion for fin.
Derive NoConfusion for fin_param.
Import Sigma_Notations.
Open Scope equations_scope.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
   equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = f_equal f (eissect x)
}.
Arguments eisretr {A B}%type_scope {f%function_scope} {_} _.
Arguments eissect {A B}%type_scope {f%function_scope} {_} _.
Arguments eisadj {A B}%type_scope {f%function_scope} {_} _.
Arguments IsEquiv {A B}%type_scope f%function_scope.

Polymorphic Record Equiv (A B : Type) := { equiv :> A -> B ; is_equiv :> IsEquiv equiv }.
Arguments equiv {A B} e.

Polymorphic Instance Equiv_IsEquiv {A B} (e : Equiv A B) : IsEquiv (equiv e).
Proof. apply is_equiv. Defined.

Definition inv_equiv {A B} (E: Equiv A B) : B -> A :=
  equiv_inv (IsEquiv:=is_equiv _ _ E).

Polymorphic Definition equiv_inv_equiv {A B} {E: Equiv A B} (x : A) : inv_equiv _ (equiv E x) = x :=
  eissect x.
Definition inv_equiv_equiv {A B} {E: Equiv A B} (x : B) : equiv E (inv_equiv _ x) = x := eisretr x.
Definition equiv_adj {A B} {E: Equiv A B} (x : A)
  : inv_equiv_equiv (equiv E x) = f_equal (equiv E) (equiv_inv_equiv x)
  := eisadj x.

Notation " 'rew' H 'in' c " := (@eq_rect _ _ _ c _ H) (at level 20).

Require Import Utf8.

Notation " X <~> Y " := (Equiv X Y) (at level 90, no associativity, Y at next level).

Lemma apply_equiv_dom {A B} (P : A -> Type) (e : Equiv A B) :
  (forall x : B, P (inv_equiv e x)) -> forall x : A, P x.
Proof.
  intros. specialize (X (equiv e x)).
  rewrite equiv_inv_equiv in X. exact X.
Defined.

Equations noConf_fin {n} (v v' : fin n) : Prop :=
noConf_fin fin0 fin0 := True;
noConf_fin (finS f) (finS f') := f = f';
noConf_fin _ _ := False.
Transparent noConf_fin.
Print Assumptions noConf_fin_elim.

(* Next Obligation. *)
(* Proof. *)
(*   depelim v. *)
(*   generalize_eqs_sig v'. destruct v'. *)
(*   simplify ?. *)
(*   refine (eq_simplification_sigma1_dep _ _ _ _ _). destruct v'; *)
(*   simplify *. constructor. *)
(*   generalize_eqs_sig v'. *)
(*   refine (eq_simplification_sigma1_dep _ _ _ _ _). destruct v'; *)
(*   simplify *; constructor. *)
(*   generalize_eqs_sig v'. *)
(*   refine (eq_simplification_sigma1_dep _ _ _ _ _). destruct v'; *)
(*                                                      simplify *; constructor. *)
(* Defined. *)

Definition noConf_fin_eq {n} (v v' : fin n) : v = v' -> noConf_fin v v'.
Proof.
  intros ->. destruct v'; constructor.
Defined.

Definition noConf_fin_eq_inv {n} (v v' : fin n) : noConf_fin v v' -> v = v'.
Proof.
  funelim (noConf_fin v v'); try simplify *; constructor.
  (* refine (@f_equal _ _ (fun x => cons x.1 x.2) _ _). *)
  (* simplify ?. *)
  (* simplify ?. *)
  (* refine (@f_equal _ _ (fun x => cons' x) _ _). *)
Defined.

Lemma noConf_fin_eq_eq_inv {n} (v v' : fin n) (e : v = v') :
  noConf_fin_eq_inv _ _ (noConf_fin_eq _ _ e) = e.
Proof.
  destruct e. destruct v; reflexivity.
Defined.

Lemma noConf_fin_refl {n} (v : fin n) : noConf_fin v v.
Proof. destruct v; reflexivity. Defined.

Lemma noConf_fin_eq_inv_eq_refl {n} (v : fin n) :
  noConf_fin_eq _ _ (noConf_fin_eq_inv v v (noConf_fin_refl v)) = (noConf_fin_refl v).
Proof.
  destruct v; reflexivity.
Defined.

Lemma noConf_fin_eq_inv_eq {n} (v v' : fin n) (e : noConf_fin v v') :
  noConf_fin_eq _ _ (noConf_fin_eq_inv _ _ e) = e.
Proof.
  destruct v; revert e; depelim v'; simplify *; reflexivity.
Defined.

Lemma noConf_fin_hom_equiv : forall n, NoConfusionPackage (fin n).
Proof.
  unshelve econstructor.
  refine noConf_fin.
  apply noConf_fin_eq.
  apply noConf_fin_eq_inv.
  apply noConf_fin_eq_eq_inv.
Defined.
Existing Instances noConf_fin_hom_equiv.

Definition noConf_fin_equiv {n} (v v' : fin n) : Equiv (v = v') (noConf_fin v v').
Proof.
  refine {| equiv := noConf_fin_eq v v' |}.
  unshelve refine {| equiv_inv := noConf_fin_eq_inv v v' |}.
  red. intros.
  apply noConf_fin_eq_inv_eq.
  red; intros.
  apply noConf_fin_eq_eq_inv.
  simplify *. destruct v'; reflexivity.
Defined.

(* Definition NoConfVec {E A n} (v v' : Vec E A n) : Prop := *)
(*   match v in Vec _ _ n return Vec E A n -> Prop with *)
(*   | nil => fun v' => *)
(*              match v' in Vec _ _ O return Prop with *)
(*              | nil => True *)
(*              | _ => False *)
(*              end *)
(*   | @cons _ _ n' x xs => *)
(*     fun v' => *)
(*       match v' in Vec _ _ (S n'') return Vec E A n'' -> Prop with *)
(*       | @cons _ _ n'' x' xs' => fun xs => {| pr1 := x; pr2 := xs |} = {| pr1 := x'; pr2 := xs' |} *)
(*       | cons' _ => fun _ => False *)
(*       end xs *)
(*   | @cons' _ _ n' x => *)
(*     fun v' => *)
(*       match v' in Vec _ _ (S n'') return Prop with *)
(*       | nil => False *)
(*       | @cons' _ _ n'' x' => x = x' *)
(*       | cons _ _ => False *)
(*       end *)
(*   end v'. *)

(* Definition noConfVec_eq {E A n} (v v' : Vec E A n) : v = v' -> NoConfVec v v'. *)
(* Proof. *)
(*   intros ->. destruct v'. constructor. simpl. constructor. simpl. constructor. *)
(* Defined. *)

(* Definition idx0_elim {E A} (P : Vec E A O -> Type) (H : P nil) : forall v, P v := *)
(*   fun v => match v in Vec _ _ O return P v with *)
(*            | nil => H *)
(*            end. *)

(* Definition idxS_elim {E A} (P : forall n, Vec E A (S n) -> Type) *)
(*            (H : forall n a (v' : Vec E A n), P n (cons a v')) *)
(*            (H' : forall n a, P n (cons' a)) *)
(*            n v : P n v := *)
(*   match v in Vec _ _ (S n') with *)
(*   | cons a v' => H _ a v' *)
(*   | cons' a => H' _ a *)
(*   end. *)

(* (* refine (match v as v' in Vec _ _ n' return *) *)
(* (*                 match n' as n'' return Vec E A n'' -> Type with *) *)
(* (*                 | O => fun _ => True *) *)
(* (*                 | S n' => fun v => P _ v *) *)
(* (*                 | raise _ _ => fun _ => True *) *)
(* (*                 end v' *) *)
(* (*           with *) *)
(* (*           | nil => I *) *)
(* (*           | cons a v' => H _ a v' *) *)
(* (*           | cons' a => H' _ a *) *)
(* (*           end). *) *)

(* Definition isNil {E A n} (v : Vec E A n) := *)
(*   match v with *)
(*   | nil => True *)
(*   | _ => False *)
(*   end. *)

(* Lemma eq_simplification_sigma1_dep@{i j} {A : Type@{i}} {P : A -> Type@{i}} {B : Type@{j}} *)
(*   (p q : A) (x : P p) (y : P q) : *)
(*   (forall e : p = q, (@eq_rect A p P x q e) = y -> B) -> *)
(*   (sigmaI P p x = sigmaI P q y -> B). *)
(* Proof. *)
(*   intros. revert X. *)
(*   change p with (pr1 &(p& x)). *)
(*   change q with (pr1 &(q & y)). *)
(*   change x with (pr2 &(p& x)) at 3. *)
(*   change y with (pr2 &(q & y)) at 4. *)
(*   destruct H. *)
(*   intros X. eapply (X eq_refl). apply eq_refl. *)
(* Defined. *)

(* (* Definition isNil_eq {E A } (v : Vec E A O) : isNil v -> v = nil. *) *)
(* (* Proof. destruct v. *) *)
(* (*   match v with *) *)
(* (*   | nil => True *) *)
(* (*   | _ => False *) *)
(* (*   end. *) *)
(* Set Printing Universes. *)
(* Definition noConfVec_eq_inv {E A n} (v v' : Vec E A n) : NoConfVec v v' -> v = v'. *)
(* Proof. *)
(*   destruct v. *)
(*   generalize_eqs_sig v'. *)
(*   refine (eq_simplification_sigma1_dep _ _ _ _ _). destruct v'. *)
(*   simplify ?. simplify ?. simplify ?. simpl. reflexivity. *)
(*   simplify ?. *)
(*   simplify ?. *)
(*   simpl. simplify ?. simplify ?. *)
(*   intros. *)
(*   generalize_eqs_sig v'. destruct v'. *)
(*   simplify ?. *)
(*   simplify ?. *)
(*   simpl in H. apply (f_equal (fun x => cons x.1 x.2)) in H. apply H. *)
(*   simplify ?. simpl in H. *)
(*   elim H. *)
(*   generalize_eqs_sig v'. destruct v'. *)
(*   simplify *. *)
(*   simplify *. *)
(*   simplify *. reflexivity. *)
(*   (* revert v'. refine (idx0_elim _ _). intros. constructor. *) *)
(*   (* revert n v' v. refine (idxS_elim _ _ _). *) *)
(*   (* simpl. intros. change a with (&(a & v').1). change v' with (&(a & v').2) at 2. *) *)
(*   (* destruct H. reflexivity. simpl. intros. elim H. *) *)
(*   (* revert n v'. refine (idxS_elim _ _ _). simpl. intros. elim H. *) *)
(*   (* simpl. intros n a H. destruct H; reflexivity. *) *)
(* Defined. *)

(* Lemma noConfVec_eq_eq_inv {E A n} (v v' : Vec E A n) (e : v = v') : *)
(*   noConfVec_eq_inv _ _ (noConfVec_eq _ _ e) = e. *)
(* Proof. *)
(*   destruct e. destruct v; reflexivity. *)
(* Defined. *)

(* Lemma noConfVec_refl {E A n} (v : Vec E A n) : NoConfVec v v. *)
(* Proof. destruct v; reflexivity. Defined. *)

(* Lemma noConfVec_eq_inv_eq_refl {E A n} (v : Vec E A n) : *)
(*   noConfVec_eq _ _ (noConfVec_eq_inv v v (noConfVec_refl v)) = (noConfVec_refl v). *)
(* Proof. *)
(*   destruct v; reflexivity. *)
(* Defined. *)

(* Lemma noConfVec_eq_inv_eq {E A n} (v v' : Vec E A n) (e : NoConfVec v v') : *)
(*   noConfVec_eq _ _ (noConfVec_eq_inv _ _ e) = e. *)
(* Proof. *)
(*   destruct v. revert e. *)
(*   generalize_eqs_vars_sig v'. destruct v'. intros v'. *)
(*   refine (eq_simplification_sigma1_dep _ _ _ _ _). simplify ?. *)
(*   simplify ?. simplify ?. simplify ?. reflexivity. *)
(*   intro. simplify *. *)
(*   intro. simplify *. *)

(*   depelim v'. simpl in e. *)
(*   revert e. simplify *. simpl. reflexivity. *)
(*   simpl. intros. elim e. *)
(*   depelim v'. simpl in e. *)
(*   revert e. simplify *. *)
(*   revert e. simplify *. reflexivity. *)
(* Defined. *)

(* (*   destruct v. revert v' e. refine (idx0_elim _ _). simpl. destruct e. reflexivity. *) *)
(* (*   revert n v' v e. refine (idxS_elim _ _ _). intros. *) *)
(* (*   simpl in e. *) *)
(* (*   revert e. simplify *. simpl. reflexivity. *) *)
(* (*   simpl. intros. elim e. *) *)
(* (*   revert n v' e. refine (idxS_elim _ _ _). intros. elim e. *) *)
(* (*   intros ??. simplify *. simpl. reflexivity. *) *)
(* (* Defined. *) *)

Equations param_fin_finS (n : nat) (f : fin n)
          (X : fin_param (S n) (finS f)) : fin_param n f :=
  param_fin_finS _ _ (finS_param f) := f.
Transparent param_fin_finS.
Print Assumptions param_fin_finS.


(** This file defines the term algebra [TermAlgebra], also referred to as the absolutely free algebra.

    We show that term algebra forms an adjoint functor from the category of hset carriers

    <<
      {C : Carrier σ | forall s, IsHSet (C s)}
    >>

    to the category of algebras (without equations) [Algebra σ], where [Carriers σ] is notation for [Sort σ -> Type].  See [ump_term_algebra].

    There is a similar construction for algebras with equations, the free algebra [FreeAlgebra]. The free algebra is defined in another file. *)

Require Export HoTT.Algebra.Universal.Algebra.

Require Import
  HoTT.HSet
  HoTT.Classes.interfaces.canonical_names
  HoTT.Algebra.Universal.Homomorphism
  HoTT.Algebra.Universal.Congruence.

Unset Elimination Schemes.

Local Open Scope Algebra_scope.

(** The term algebra carriers are generated by [C : Carriers σ], with an element for each element of [C s], and an operation for each operation symbol [u : Symbol σ]. *)

Inductive CarriersTermAlgebra {σ} (C : Carriers σ) : Carriers σ :=
  | var_term_algebra : forall s, C s -> CarriersTermAlgebra C s
  | ops_term_algebra : forall (u : Symbol σ),
      DomOperation (CarriersTermAlgebra C) (σ u) ->
      CarriersTermAlgebra C (sort_cod (σ u)).

Scheme CarriersTermAlgebra_ind := Elimination for CarriersTermAlgebra Sort Type.
Arguments CarriersTermAlgebra_ind {σ}.

Definition CarriersTermAlgebra_rect {σ} := @CarriersTermAlgebra_ind σ.

Definition CarriersTermAlgebra_rec {σ : Signature} (C : Carriers σ)
  (P : Sort σ -> Type) (vs : forall (s : Sort σ), C s -> P s)
  (os : forall (u : Symbol σ) (c : DomOperation (CarriersTermAlgebra C) (σ u)),
        (forall i : Arity (σ u), P (sorts_dom (σ u) i)) -> P (sort_cod (σ u)))
  (s : Sort σ) (T : CarriersTermAlgebra C s)
  : P s
  := CarriersTermAlgebra_ind C (fun s _ => P s) vs os s T.

(** A family of relations [R : forall s, Relation (C s)] can be extended to a family of relations on the term algebra carriers,

    <<
      forall s, Relation (CarriersTermAlgebra C s)
    >>

    See [ExtendDRelTermAlgebra] and [ExtendRelTermAlgebra] below. *)

Fixpoint ExtendDRelTermAlgebra {σ : Signature} {C : Carriers σ}
  (R : forall s, Relation (C s)) {s1 s2 : Sort σ}
  (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2)
  : Type
  := match S, T with
     | var_term_algebra s1 x, var_term_algebra s2 y =>
        {p : s1 = s2 | R s2 (p # x) y}
     | ops_term_algebra u1 a, ops_term_algebra u2 b =>
        { p : u1 = u2 |
          forall i : Arity (σ u1),
          ExtendDRelTermAlgebra
            R (a i) (b (transport (fun v => Arity (σ v)) p i))}
     | _, _ => Empty
     end.

Definition ExtendRelTermAlgebra {σ : Signature} {C : Carriers σ}
  (R : forall s, Relation (C s)) {s : Sort σ}
  : CarriersTermAlgebra C s -> CarriersTermAlgebra C s -> Type
  := ExtendDRelTermAlgebra R.

(** The next section shows, in particular, the following: If [R : forall s, Relation (C s)] is a family of mere equivalence relations, then [@ExtendRelTermAlgebra σ C R] is a family of mere equivalence eqlations. *)

Section extend_rel_term_algebra.
  Context `{Funext} {σ : Signature} {C : Carriers σ}
    (R : forall s, Relation (C s))
    `{!forall s, is_mere_relation (C s) (R s)}.

  Global Instance hprop_extend_drel_term_algebra {s1 s2 : Sort σ}
    (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2)
    : IsHProp (ExtendDRelTermAlgebra R S T).
  Proof.
    generalize dependent s2.
    induction S; intros s2 T; destruct T; exact _.
  Qed.

  Global Instance reflexive_extend_rel_term_algebra
    `{!forall s, Reflexive (R s)} {s : Sort σ}
    : Reflexive (@ExtendRelTermAlgebra σ C R s).
  Proof.
    intro S. induction S as [| u c h].
    - by exists idpath.
    - exists idpath. intro i. apply h.
  Qed.

  Lemma symmetric_extend_drel_term_algebra
    `{!forall s, Symmetric (R s)} {s1 s2 : Sort σ}
    (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2)
    (h : ExtendDRelTermAlgebra R S T)
    : ExtendDRelTermAlgebra R T S.
  Proof.
    generalize dependent s2.
    induction S as [| u c h]; intros s2 [] p.
    - destruct p as [p1 p2].
      induction p1. exists idpath. by symmetry.
    - elim p.
    - elim p.
    - destruct p as [p f].
      induction p. exists idpath. intro i. apply h. apply f.
  Qed.

  Global Instance symmetric_extend_rel_term_algebra
    `{!forall s, Symmetric (R s)} {s : Sort σ}
    : Symmetric (@ExtendRelTermAlgebra σ C R s).
  Proof.
    intros S T. apply symmetric_extend_drel_term_algebra.
  Defined.

  Lemma transitive_extend_drel_term_algebra
    `{!forall s, Transitive (R s)} {s1 s2 s3 : Sort σ}
    (S : CarriersTermAlgebra C s1)
    (T : CarriersTermAlgebra C s2)
    (U : CarriersTermAlgebra C s3)
    (h1 : ExtendDRelTermAlgebra R S T)
    (h2 : ExtendDRelTermAlgebra R T U)
    : ExtendDRelTermAlgebra R S U.
  Proof.
    generalize dependent s3.
    generalize dependent s2.
    induction S as [| u c h];
      intros s2 [? d | ? d] h2 s3 [] h3;
      destruct h2 as [p2 P2], h3 as [p3 P3] || by (elim h2 || elim h3).
    - exists (p2 @ p3).
      rewrite transport_pp.
      induction p2, p3.
      by transitivity d.
    - exists (p2 @ p3).
      intro i.
      induction p2.
      apply (h i _ (d i)).
      + apply P2.
      + rewrite concat_1p. apply P3.
  Qed.

  Global Instance transitive_extend_rel_term_algebra
    `{!forall s, Transitive (R s)} {s : Sort σ}
    : Transitive (@ExtendRelTermAlgebra σ C R s).
  Proof.
    intros S T U. apply transitive_extend_drel_term_algebra.
  Defined.

  Global Instance equivrel_extend_rel_term_algebra
    `{!forall s, EquivRel (R s)} (s : Sort σ)
    : EquivRel (@ExtendRelTermAlgebra σ C R s).
  Proof.
    constructor; exact _.
  Qed.

End extend_rel_term_algebra.

(** By using path (propositional equality) as equivalence relation for [ExtendRelTermAlgebra], we obtain an equivalent notion of equality of term algebra carriers, [equiv_path_extend_path_term_algebra]. The reason for introducing [ExtendRelTermAlgebra] is to have a notion of equality which works well together with induction on term algebras. *)

Section extend_path_term_algebra.
  Context `{Funext} {σ} {C : Carriers σ} `{!forall s, IsHSet (C s)}.

  Definition ExtendPathTermAlgebra {s : Sort σ}
    (S : CarriersTermAlgebra C s) (T : CarriersTermAlgebra C s)
    : Type
    := ExtendRelTermAlgebra (fun s => paths) S T.

  Global Instance reflexive_extend_path_term_algebra
    : forall s : Sort σ, Reflexive (@ExtendPathTermAlgebra s).
  Proof.
    by apply reflexive_extend_rel_term_algebra.
  Defined.

  Lemma reflexive_extend_path_term_algebra_path {s : Sort σ}
    {S T : CarriersTermAlgebra C s} (p : S = T)
    : ExtendPathTermAlgebra S T.
  Proof.
    induction p. apply reflexive_extend_path_term_algebra.
  Defined.

  Global Instance symmetric_extend_path_term_algebra
    : forall s : Sort σ, Symmetric (@ExtendPathTermAlgebra s).
  Proof.
    apply symmetric_extend_rel_term_algebra. intros s x y. apply inverse.
  Defined.

  Global Instance transitive_extend_path_term_algebra
    : forall s : Sort σ, Transitive (@ExtendPathTermAlgebra s).
  Proof.
    apply transitive_extend_rel_term_algebra. intros s x y z. apply concat.
  Defined.

  Global Instance equivrel_extend_path_term_algebra
    : forall s : Sort σ, EquivRel (@ExtendPathTermAlgebra s).
  Proof.
    constructor; exact _.
  Qed.

  Global Instance hprop_extend_path_term_algebra (s : Sort σ)
    : is_mere_relation (CarriersTermAlgebra C s) ExtendPathTermAlgebra.
  Proof.
    intros S T. exact _.
  Defined.

  Lemma dependent_path_extend_path_term_algebra {s1 s2 : Sort σ}
    (S : CarriersTermAlgebra C s1) (T : CarriersTermAlgebra C s2)
    (e : ExtendDRelTermAlgebra (fun s => paths) S T)
    : {p : s1 = s2 | p # S = T}.
  Proof.
    generalize dependent s2.
    induction S as [| u c h];
        intros s2 [? d | ? d] e;
        solve [elim e] || destruct e as [p e].
    - exists p. by induction p, e.
    - induction p. exists idpath. cbn. f_ap. funext a.
      destruct (h a _ (d a) (e a)) as [p q].
      by induction (hset_path2 idpath p).
  Defined.

  Lemma path_extend_path_term_algebra {s : Sort σ}
    (S T : CarriersTermAlgebra C s) (e : ExtendPathTermAlgebra S T)
    : S = T.
  Proof.
    destruct (dependent_path_extend_path_term_algebra S T e) as [p q].
    by induction (hset_path2 idpath p).
  Defined.

  Global Instance hset_carriers_term_algebra (s : Sort σ)
    : IsHSet (CarriersTermAlgebra C s).
  Proof.
    apply (@ishset_hrel_subpaths _ ExtendPathTermAlgebra).
    - apply reflexive_extend_path_term_algebra.
    - apply hprop_extend_path_term_algebra; exact _.
    - apply path_extend_path_term_algebra.
  Defined.

  Definition equiv_path_extend_path_term_algebra {s : Sort σ}
    (S T : CarriersTermAlgebra C s)
    : ExtendPathTermAlgebra S T <~> (S = T)
    := equiv_iff_hprop
        (path_extend_path_term_algebra S T)
        reflexive_extend_path_term_algebra_path.

End extend_path_term_algebra.

(** At this point we can define the term algebra. *)

Definition TermAlgebra `{Funext} {σ : Signature}
  (C : Carriers σ) `{!forall s, IsHSet (C s)}
  : Algebra σ
  := Build_Algebra (CarriersTermAlgebra C) (@ops_term_algebra _ C).

Lemma isinj_var_term_algebra {σ} (C : Carriers σ) (s : Sort σ) (x y : C s)
  : var_term_algebra C s x = var_term_algebra C s y -> x = y.
Proof.
  intro p.
  apply reflexive_extend_path_term_algebra_path in p.
  destruct p as [p1 p2].
  by destruct (hset_path2 p1 idpath)^.
Qed.

Lemma isinj_ops_term_algebra `{Funext} {σ} (C : Carriers σ)
  (u : Symbol σ) (a b : DomOperation (CarriersTermAlgebra C) (σ u))
  : ops_term_algebra C u a = ops_term_algebra C u b -> a = b.
Proof.
  intro p.
  apply reflexive_extend_path_term_algebra_path in p.
  destruct p as [p1 p2].
  destruct (hset_path2 p1 idpath)^.
  funext i.
  apply path_extend_path_term_algebra.
  apply p2.
Qed.

(** The extension [ExtendRelTermAlgebra R], of a family of mere
    equivalence relations [R], is a congruence. *)

Global Instance is_congruence_extend_rel_term_algebra
  `{Funext} {σ} (C : Carriers σ) `{!forall s, IsHSet (C s)}
  (R : forall s, Relation (C s)) `{!forall s, EquivRel (R s)}
  `{!forall s, is_mere_relation (C s) (R s)}
  : IsCongruence (TermAlgebra C) (@ExtendRelTermAlgebra σ C R).
Proof.
  constructor.
  - intros. exact _.
  - intros. exact _.
  - intros u a b c. exists idpath. intro i. apply c.
Defined.

(** Given and family of functions [f : forall s, C s -> A s], we can extend it to a [TermAlgebra C $-> A], as shown in the next section. *)

Section hom_term_algebra.
  Context
    `{Funext} {σ} {C : Carriers σ} `{!forall s, IsHSet (C s)}
    (A : Algebra σ) (f : forall s, C s -> A s).

  Definition map_term_algebra {σ} {C : Carriers σ} (A : Algebra σ)
    (f : forall s, C s -> A s) (s : Sort σ) (T : CarriersTermAlgebra C s)
    : A s
    := CarriersTermAlgebra_rec C A f (fun u _ r => u.#A r) s T.

  Global Instance is_homomorphism_map_term_algebra
    : @IsHomomorphism σ (TermAlgebra C) A (map_term_algebra A f).
  Proof.
    intros u a. by refine (ap u.#A _).
  Qed.

  Definition hom_term_algebra : TermAlgebra C $-> A
    := @Build_Homomorphism σ (TermAlgebra C) A (map_term_algebra A f) _.

End hom_term_algebra.

(** The next section proves the universal property of the term algebra,
    that [TermAlgebra] is a left adjoint functor

    >>
      {C : Carriers σ | forall s, IsHSet (C s)} -> Algebra σ,
    <<

    with right adjoint the forgetful functor. This is stated below as
    an equivalence

    >>
      Homomorphism (TermAlgebra C) A <~> (forall s, C s -> A s),
    <<

    given by precomposition with

    >>
      var_term_algebra C s : C s -> TermAlgebra C s.
    << *)

Section ump_term_algebra.
  Context
    `{Funext} {σ} (C : Carriers σ) `{forall s, IsHSet (C s)} (A : Algebra σ).

  (** By precomposing [Homomorphism (TermAlgebra C) A] with
      [var_term_algebra], we obtain a family [forall s, C s -> A s]. *)

  Definition precomp_var_term_algebra (f : TermAlgebra C $-> A)
    : forall s, C s -> A s
    := fun s x => f s (var_term_algebra C s x).

  Lemma path_precomp_var_term_algebra_to_hom_term_algebra
    : forall (f : TermAlgebra C $-> A),
      hom_term_algebra A (precomp_var_term_algebra f) = f.
  Proof.
    intro f.
    apply path_homomorphism.
    funext s T.
    induction T as [|u c h].
    - reflexivity.
    - refine (_ @ (is_homomorphism f u c)^).
      refine (ap u.#A _). funext i. apply h.
  Defined.

  Lemma path_hom_term_algebra_to_precomp_var_term_algebra
    : forall (f : forall s, C s -> A s),
      precomp_var_term_algebra (hom_term_algebra A f) = f.
  Proof.
    intro f. by funext s a.
  Defined.

  (** Precomposition with [var_term_algebra] is an equivalence *)

  Global Instance isequiv_precomp_var_term_algebra
    : IsEquiv precomp_var_term_algebra.
  Proof.
    srapply isequiv_adjointify.
    - apply hom_term_algebra.
    - intro. apply path_hom_term_algebra_to_precomp_var_term_algebra.
    - intro. apply path_precomp_var_term_algebra_to_hom_term_algebra.
  Defined.

  (** The universal property of the term algebra: The [TermAlgebra]
      is a left adjoint functor.
      Notice [isequiv_precomp_var_term_algebra] above. *)

  Theorem ump_term_algebra
    : (TermAlgebra C $-> A) <~> (forall s, C s -> A s).
  Proof.
    exact (Build_Equiv _ _ precomp_var_term_algebra _).
  Defined.

End ump_term_algebra.


(**
_AUTHOR_

<<
Zhi Zhang
Department of Computer and Information Sciences
Kansas State University
zhangzhi@ksu.edu
>>
*)

Require Export rt_opt.

Scheme expression_ind := Induction for exp Sort Prop
                         with name_ind := Induction for name Sort Prop.

Scheme expression_x_ind := Induction for expRT Sort Prop
                         with name_x_ind := Induction for nameRT Sort Prop.

(** * Helper Lemmas for RT-OPT *)

(** ** in_bound Lemmas *)

Lemma In_Bound_Refl: forall v,
  in_bound v (Interval v v) true.
Proof.
  intros; constructor;
  specialize (Z.le_refl v). intros H0.
  specialize (Zle_imp_le_bool _ _ H0);
    intros H1; rewrite H1; auto.
Qed.

Lemma in_bound_conflict: forall v bound,
  in_bound v bound true ->
    in_bound v bound false ->
      False.
Proof.
  intros.
  inversion H; inversion H0; smack.
Qed.

Ltac apply_in_bound_conflict :=
  match goal with
  | [H1: in_bound ?v ?bound true,
     H2: in_bound ?v ?bound false |- _] => specialize (in_bound_conflict _ _ H1 H2)
  end.

(** l <= v <= u, l' <= l <= u', l' <= u <= u' => l' <= v <= u', where vBound = (l', u') *)
Lemma In_Bound_Trans: forall v l u vBound,
  in_bound v (Interval l u) true ->
    in_bound l vBound true ->
      in_bound u vBound true ->
        in_bound v vBound true.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  repeat progress match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  constructor; apply andb_true_iff; split.
- specialize (Z.le_trans _ _ _ H3 H0); intros HZ1;
  specialize (Zle_imp_le_bool _ _ HZ1); auto.
- specialize (Z.le_trans _ _ _ H1 H5); intros HZ1;
  specialize (Zle_imp_le_bool _ _ HZ1); auto.
Qed.

Ltac apply_In_Bound_Trans :=
  match goal with
  | [H1: in_bound ?v (Interval ?l ?u) true,
     H2: in_bound ?l _ true,
     H3: in_bound ?u _ true |- _ ] =>
      specialize (In_Bound_Trans _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma In_Bound_SubBound_Trans: forall v vBound vBound',
  in_bound v vBound true ->
    sub_bound vBound vBound' true ->
      in_bound v vBound' true.
Proof.
  intros;
  inversion H0; subst;
  apply_In_Bound_Trans; auto.
Qed.

Ltac apply_In_Bound_SubBound_Trans :=
  match goal with
  | [H1: in_bound _ ?b true,
     H2: sub_bound ?b _ true |- _] =>
      specialize (In_Bound_SubBound_Trans _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma In_Bound_Two: forall v l u l' u',
  in_bound v (Interval l u) true ->
    in_bound v (Interval l' u') true ->
      in_bound v (Interval (Z.max l l') (Z.min u u')) true.
Proof.
  intros.
  inversion H; inversion H0; subst; clear H H0.
  constructor; auto.
  specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H3); intro HZ1.
  specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H7); intro HZ2.
  destruct HZ1 as [HZ1a HZ1b]. destruct HZ2 as [HZ2a HZ2b].
  specialize (Z.max_lub _ _ _ HZ1a HZ2a); intro HZ3.
  specialize (Z.min_glb _ _ _ HZ1b HZ2b); intro HZ4.
  clear HZ1a HZ1b HZ2a HZ2b.
  repeat progress match goal with
  | [H: (?l <= ?v)%Z |- _] =>
      specialize (Zle_imp_le_bool _ _ H); clear H; let HZ := fresh "HZ" in intro HZ
  end; smack.
Qed.

Ltac apply_In_Bound_Two :=
  match goal with
  | [H1: in_bound ?v (Interval ?l ?u) true,
     H2: in_bound ?v (Interval ?l' ?u') true |- _ ] =>
      specialize (In_Bound_Two _ _ _ _ _ H1 H2); let HZ := fresh "HZ" in intro HZ
  end.

Lemma modulus_in_int32_bound: forall v1 v2,
  in_bound v2 int32_bound true ->
    in_bound (v1 mod v2) int32_bound true.
Proof.
  intros.
  destruct v2; constructor; smack.
 - rewrite Zmod_0_r. smack.
 - assert(HA1: ((Z.pos p) > 0)%Z). smack.
   specialize (Z_mod_lt v1 _ HA1); intro HZ2.
   destruct HZ2 as [HZ2a HZ2b].
   assert(HZ3a: (0 <=? v1 mod Z.pos p)%Z = true).
     apply Zleb_le; auto.
   assert(HZ3b: (v1 mod Z.pos p <? Z.pos p)%Z = true).
     apply Zltb_lt; auto.

   inversion H; subst.
   remember ((min_signed <=? Z.pos p)%Z) as HZ4a.
   remember ((Z.pos p <=? max_signed)%Z) as HZ4b.
   destruct HZ4a, HZ4b; inversion H2.
   assert(HC1: (min_signed <=? v1 mod Z.pos p)%Z = true).
     apply Zle_bool_trans with (m := 0%Z); smack.
   assert(HC2: (v1 mod Z.pos p <=? max_signed)%Z = true).
     apply Zltb_leb_trans_leb with (Z.pos p); smack.
   smack.
 - assert(HA1: ((Z.neg p) < 0)%Z). constructor; auto.
   specialize (Z_mod_neg v1 _ HA1); intro HZ2.
   destruct HZ2 as [HZ2a HZ2b].
   assert(HZ3a: (Z.neg p <? v1 mod Z.neg p)%Z = true).
     apply Zltb_lt; auto.
   assert(HZ3b: (v1 mod Z.neg p <=? 0)%Z = true).
     apply Zleb_le; auto.

   inversion H; subst.
   remember ((min_signed <=? Z.neg p)%Z) as HZ4a.
   remember ((Z.neg p <=? max_signed)%Z) as HZ4b.
   destruct HZ4a, HZ4b; inversion H2.
   assert(HC1: (min_signed <=? v1 mod Z.neg p)%Z = true).
     apply Zleb_ltb_trans_leb with (Z.neg p); smack.
   assert(HC2: (v1 mod Z.neg p <=? max_signed)%Z = true).
     apply Zleb_ltb_trans_leb with (0%Z); smack.
   rewrite HC1, HC2; auto.
Qed.

Lemma modulus_in_bound_trans: forall v1 v2 bound,
  sub_bound bound int32_bound true ->
    in_bound v2 bound true ->
      in_bound (v1 mod v2) int32_bound true.
Proof.
  intros.
  apply_In_Bound_SubBound_Trans.
  apply modulus_in_int32_bound; auto.
Qed.

(** l1 <= v1 <= u1, l2 <= v2 <= u2 => (l1+l2) <= (v1+v2) <= (u1+u2) *)
Lemma In_Bound_Plus_Compat: forall v1 l1 u1 v2 l2 u2,
  in_bound v1 (Interval l1 u1) true ->
    in_bound v2 (Interval l2 u2) true ->
      in_bound (v1+v2) (Interval (l1+l2) (u1+u2)) true.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  repeat progress match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  constructor; apply andb_true_iff; split.
- specialize (Zplus_le_compat _ _ _ _ H0 H2); intros HZ1;
  specialize (Zle_imp_le_bool _ _ HZ1); auto.
- specialize (Zplus_le_compat _ _ _ _ H1 H3); intros HZ1;
  specialize (Zle_imp_le_bool _ _ HZ1); auto.
Qed.

Ltac apply_In_Bound_Plus_Compat :=
  match goal with
  | [H1: in_bound ?v1 _ true,
     H2: in_bound ?v2 _ true |- _] =>
      specialize (In_Bound_Plus_Compat _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

(** l1 <= v1 <= u1, l2 <= v2 <= u2 => (l1-u2) <= (v1-v2) <= (u1-l2) *)
Lemma In_Bound_Minus_Compat: forall v1 l1 u1 v2 l2 u2,
  in_bound v1 (Interval l1 u1) true ->
    in_bound v2 (Interval l2 u2) true ->
      in_bound (v1-v2) (Interval (l1-u2) (u1-l2)) true.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  repeat progress match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  constructor; apply andb_true_iff; split.
- specialize (Le_Neg_Ge _ _ H3); intros HZ1;
  specialize (Zplus_le_compat _ _ _ _ H0 HZ1); intros HZ2;
  specialize (Zle_imp_le_bool _ _ HZ2); auto.
- specialize (Le_Neg_Ge _ _ H2); intros HZ1;
  specialize (Zplus_le_compat _ _ _ _ H1 HZ1); intros HZ2;
  specialize (Zle_imp_le_bool _ _ HZ2); auto.
Qed.

Ltac apply_In_Bound_Minus_Compat :=
  match goal with
  | [H1: in_bound ?v1 _ true,
     H2: in_bound ?v2 _ true |- _] =>
      specialize (In_Bound_Minus_Compat _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma Sub_Bound_Plus_Compat: forall v1 l1 u1 v2 l2 u2 vBound,
  in_bound v1 (Interval l1 u1) true ->
    in_bound v2 (Interval l2 u2) true ->
      in_bound (v1+v2) vBound false ->
        sub_bound (Interval (l1 + l2) (u1 + u2)) vBound false.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  repeat progress match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  match goal with
  | [H: _ && _ = false |- _] => specialize (Zlele_Bool_Imp_LeLe_F _ _ _ H); clear H; smack
  end;
  constructor.
- specialize (Zplus_le_compat _ _ _ _ H0 H3); intros HZ1.
  specialize (Z.le_lt_trans _ _ _ HZ1 H2); intros HZ2.
  left. constructor.
  apply andb_false_iff; left.
  apply Lt_Le_Bool_False; auto.
- specialize (Zplus_le_compat _ _ _ _ H1 H4); intros HZ1.
  specialize (Z.lt_le_trans  _ _ _ H2 HZ1); intros HZ2.
  right; constructor.
  apply andb_false_iff; right.
  apply Lt_Le_Bool_False; auto.
Qed.

Ltac apply_Sub_Bound_Plus_Compat :=
  match goal with
  | [H1: in_bound ?v1 _ true,
     H2: in_bound ?v2 _ true,
     H3: in_bound (?v1+?v2) _ false |- _] =>
      specialize (Sub_Bound_Plus_Compat _ _ _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma Sub_Bound_Minus_Compat: forall v1 l1 u1 v2 l2 u2 vBound,
  in_bound v1 (Interval l1 u1) true ->
    in_bound v2 (Interval l2 u2) true ->
      in_bound (v1-v2) vBound false ->
        sub_bound (Interval (l1 - u2) (u1 - l2)) vBound false.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  repeat progress match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  match goal with
  | [H: _ && _ = false |- _] => specialize (Zlele_Bool_Imp_LeLe_F _ _ _ H); clear H; smack
  end;
  constructor.
- specialize (Le_Neg_Ge _ _ H4); intros HZ1;
  specialize (Zplus_le_compat _ _ _ _ H0 HZ1); intros HZ2;
  specialize (Z.le_lt_trans _ _ _ HZ2 H2); intros HZ3;
  left; constructor;
  apply andb_false_iff; left;
  apply Lt_Le_Bool_False; auto.
- specialize (Le_Neg_Ge _ _ H3); intros HZ1;
  specialize (Zplus_le_compat _ _ _ _ H1 HZ1); intros HZ2;
  specialize (Z.lt_le_trans  _ _ _ H2 HZ2); intros HZ3;
  right; constructor;
  apply andb_false_iff; right;
  apply Lt_Le_Bool_False; auto.
Qed.

Ltac apply_Sub_Bound_Minus_Compat :=
  match goal with
  | [H1: in_bound ?v1 _ true,
     H2: in_bound ?v2 _ true,
     H3: in_bound (?v1-?v2) _ false |- _] =>
      specialize (Sub_Bound_Minus_Compat _ _ _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma Sub_Bound_Unary_Minus_Compat: forall v l u vBound,
  in_bound v (Interval l u) true ->
    in_bound (- v) vBound false ->
      sub_bound (Interval (- u) (- l)) vBound false.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
 match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  match goal with
  | [H: _ && _ = false |- _] => specialize (Zlele_Bool_Imp_LeLe_F _ _ _ H); clear H; smack
  end;
  constructor;
  [left | right];
  constructor.
- apply andb_false_iff; left;
  specialize (Le_Neg_Ge _ _ H2); intros HZ1;
  specialize (Z.le_lt_trans _ _ _ HZ1 H1); intros HZ2;
  apply Lt_Le_Bool_False; auto.
- apply andb_false_iff; right;
  specialize (Le_Neg_Ge _ _ H0); intros HZ1;
  specialize (Z.lt_le_trans _ _ _ H1 HZ1); intros HZ2;
  apply Lt_Le_Bool_False; auto.
Qed.

Ltac apply_Sub_Bound_Unary_Minus_Compat :=
  match goal with
  | [H1: in_bound ?v _ true,
     H2: in_bound (- ?v) _ false |- _] =>
      specialize (Sub_Bound_Unary_Minus_Compat _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma In_Bound_Unary_Minus_Compat: forall v l u,
  in_bound v (Interval l u) true ->
    in_bound (- v) (Interval (- u) (- l)) true.
Proof.
  intros.
  inversion H; clear H; subst.
  constructor.
  specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H2); smack.
  specialize (Le_Neg_Ge _ _ H0); intros HZ1.
  specialize (Le_Neg_Ge _ _ H1); intros HZ2.
  specialize (Zle_imp_le_bool  _ _ HZ1); intros HZ3.
  specialize (Zle_imp_le_bool  _ _ HZ2); intros HZ4.
  smack.
Qed.

Lemma in_bound_value_neq_zero: forall v vBound,
  in_bound v vBound true ->
    in_bound 0 vBound false ->
      Zeq_bool v 0 = false.
Proof.
  intros;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; subst
  end;
  match goal with
  | [H: _ && _ = true |- _] => specialize (Zlele_Bool_Imp_LeLe_T _ _ _ H); clear H; smack
  end;
  match goal with
  | [H: _ && _ = false |- _] => specialize (Zlele_Bool_Imp_LeLe_F _ _ _ H); clear H; smack
  end;
  [ specialize (Z.lt_le_trans _ _ _ H1 H0); intros HZ1 |
    specialize (Z.le_lt_trans _ _ _ H2 H1); intros HZ1
  ];
  unfold Zeq_bool;
  destruct v; smack.
Qed.

Ltac apply_in_bound_value_neq_zero :=
  match goal with
  | [H1: in_bound ?v ?b true,
     H2: in_bound 0 ?b false |- _] =>
      specialize (in_bound_value_neq_zero _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

(********************************************************************)
(********************************************************************)

(** ** run-time erasion Lemmas *)

Lemma removed_check_flag_notin: forall ck cks cks',
 remove_check_flag ck cks = cks' ->
   ~(List.In ck cks').
Proof.
  induction cks; smack.
  remember (beq_check_flag ck a) as b;
  destruct b; smack.
  destruct ck; smack.
Qed.

Ltac apply_removed_check_flag_notin :=
  match goal with
  | [H: remove_check_flag _ _ = _ |- _] =>
      specialize (removed_check_flag_notin _ _ _ H);
      let HZ := fresh "HZ" in intros HZ
  | [H: _ = remove_check_flag _ _ |- _] =>
      symmetry in H; specialize (removed_check_flag_notin _ _ _ H);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma remove_notin_check_flag: forall ck cks,
  ~(List.In ck cks) ->
    remove_check_flag ck cks = cks.
Proof.
  induction cks; smack.
  remember (beq_check_flag ck a) as b;
  destruct b; smack.
  destruct a; destruct ck; smack.
Qed.

Ltac apply_remove_notin_check_flag :=
  match goal with
  | [H: ~(List.In _ _) |- _] =>
      specialize (remove_notin_check_flag _ _ H); let HZ := fresh "HZ" in intros HZ
  | [H: List.In _ _ -> False |- _] =>
      specialize (remove_notin_check_flag _ _ H); let HZ := fresh "HZ" in intros HZ
  end.

Lemma check_flag_in_reserve: forall ck ck' cks,
  beq_check_flag ck ck' = false ->
    List.In ck (remove_check_flag ck' cks) ->
      List.In ck cks.
Proof.
  induction cks; smack.
  remember (beq_check_flag ck' a) as b;
  destruct b; smack.
Qed.

Ltac apply_check_flag_in_reserve :=
  match goal with
  | [H1: beq_check_flag ?ck ?ck' = false,
     H2: List.In ?ck (remove_check_flag ?ck' _) |- _] =>
      specialize (check_flag_in_reserve _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma check_flag_in_reserve2: forall ck ck' cks,
  beq_check_flag ck ck' = false ->
    List.In ck cks ->
      List.In ck (remove_check_flag ck' cks).
Proof.
  induction cks; smack.
  remember (beq_check_flag ck' ck) as b; destruct b; smack.
  destruct ck; destruct ck'; smack.
  remember (beq_check_flag ck' a) as b; destruct b; smack.
Qed.

Ltac apply_check_flag_in_reserve2 :=
  match goal with
  | [ H1: beq_check_flag ?ck _ = false,
      H2: List.In ?ck _ |- _] =>
      specialize (check_flag_in_reserve2 _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

(********************************************************************)
(********************************************************************)

Lemma in_bound_unique: forall v vBound b1 b2,
  in_bound v vBound b1 ->
    in_bound v vBound b2 ->
      b1 = b2.
Proof.
  intros;
  inversion H; inversion H0; smack.
Qed.

Ltac apply_in_bound_unique :=
  match goal with
  | [H1: in_bound ?v _ _,
     H2: in_bound ?v _ _ |- _] =>
      specialize (in_bound_unique _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ; inversion HZ
  end.

Lemma sub_bound_unique: forall bound1 bound2 b1 b2,
  sub_bound bound1 bound2 b1 ->
    sub_bound bound1 bound2 b2 ->
      b1 = b2.
Proof.
  intros;
  inversion H; inversion H0; smack;
  apply_in_bound_unique.
Qed.

Ltac apply_sub_bound_unique :=
  match goal with
  | [H1: sub_bound ?bound1 _ _,
     H2: sub_bound ?bound1 _ _ |- _] =>
      specialize (sub_bound_unique _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ; inversion HZ
  end.

(********************************************************************)
(********************************************************************)

(** ** RT-OPT exterior checks Lemmas *)

Lemma optimize_name_ast_num_eq: forall st n n' nBound,
  optName st n (n', nBound) ->
    fetch_exp_type_rt (name_astnum_rt n) st = fetch_exp_type_rt (name_astnum_rt n') st.
Proof.
  intros;
  inversion H; smack.
Qed.

Ltac apply_optimize_name_ast_num_eq :=
  match goal with
  | [H: optName _ _ _ |- _] =>
      specialize (optimize_name_ast_num_eq _ _ _ _ H);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma optimize_exp_ex_cks_eq: forall st e e' eBound,
  optExp st e (e', eBound) ->
    exp_exterior_checks e' = exp_exterior_checks e.
Proof.
  intros;
  inversion H; smack;
  match goal with
  | [H: optName _ _ _ |- _] => inversion H; smack
  end.
Qed.

Ltac apply_optimize_exp_ex_cks_eq :=
  match goal with
  | [H: optExp _ _ _ |- _] =>
      specialize (optimize_exp_ex_cks_eq _ _ _ _ H);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma optimize_name_ex_cks_eq: forall st n n' nBound,
  optName st n (n', nBound) ->
    name_exterior_checks n' = name_exterior_checks n.
Proof.
  intros;
  inversion H; smack.
Qed.

Ltac apply_optimize_name_ex_cks_eq :=
  match goal with
  | [H: optName _ _ _ |- _] =>
      specialize (optimize_name_ex_cks_eq _ _ _ _ H);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma range_check_on_copyout_preserve: forall n ast_num ast_num' nBound nBound' n',
  name_exterior_checks n = RangeCheck :: RangeCheckOnReturn :: nil ->
    optimize_range_check (NameRT ast_num n) nBound nBound' (NameRT ast_num' n') ->
      ~ List.In RangeCheckOnReturn (name_exterior_checks n') ->
        False.
Proof.
  intros.
  inversion H0; subst.
  simpl in H4; smack.
  rewrite H in H1; rewrite name_updated_exterior_checks in H1; smack.
  rewrite H in H1; smack.
Qed.

Ltac apply_range_check_on_copyout_preserve :=
  match goal with
  | [H1: name_exterior_checks ?n = RangeCheck :: RangeCheckOnReturn :: nil,
     H2: optimize_range_check (NameRT ?ast_num ?n) ?nBound ?nBound' (NameRT ?ast_num' ?n'),
     H3: ~ List.In RangeCheckOnReturn (name_exterior_checks ?n') |- _ ] =>
      specialize (range_check_on_copyout_preserve _ _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma range_check_opt_subBound_true: forall e e' eBound eBound',
  exp_exterior_checks e = RangeCheck :: nil ->
    optimize_range_check e eBound eBound' e' ->
      exp_exterior_checks e' = nil ->
        sub_bound eBound eBound' true.
Proof.
  intros.
  inversion H0; subst; rewrite H in *; smack.
Qed.

Ltac apply_range_check_opt_subBound_true :=
  match goal with
  | [H1: exp_exterior_checks ?e = RangeCheck :: nil,
     H2: optimize_range_check ?e ?eBound ?eBound' ?e',
     H3: exp_exterior_checks ?e' = nil |- _] =>
    specialize (range_check_opt_subBound_true _ _ _ _ H1 H2 H3); let HZ := fresh "HZ" in intro HZ
  end.

(** ** Other Lemmas *)

Lemma eval_expr_value_reserve: forall e eBound rBound e' st s v,
  optimize_range_check e eBound rBound e' ->
    evalExpRT st s e v ->
      evalExpRT st s e' v.
Proof.
  intros;
  inversion H; subst; auto;
  apply eval_exp_ex_cks_added; auto.
Qed.

Ltac apply_eval_expr_value_reserve :=
  match goal with
  | [H1: optimize_range_check ?e _ _ _,
     H2: evalExpRT _ _ ?e _ |- _] =>
      specialize (eval_expr_value_reserve _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma eval_expr_value_reserve_backward: forall e eBound rBound e' st s v,
  optimize_range_check e eBound rBound e' ->
    evalExpRT st s e' v ->
      evalExpRT st s e v.
Proof.
  intros;
  inversion H; subst; auto;
  eapply eval_exp_ex_cks_stripped; smack.
Qed.

Ltac apply_eval_expr_value_reserve_backward :=
  match goal with
  | [H1: optimize_range_check ?e _ _ ?e',
     H2: evalExpRT _ _ ?e' _ |- _] =>
      specialize (eval_expr_value_reserve_backward _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma eval_expr_value_copy_out_opt_reserve: forall e eBound rBound e' st s v,
  optimize_range_check_on_copy_out e eBound rBound e' ->
    evalExpRT st s e v ->
      evalExpRT st s e' v.
Proof.
  intros;
  inversion H; subst; auto;
  apply eval_exp_ex_cks_added; auto.
Qed.

Ltac apply_eval_expr_value_copy_out_opt_reserve :=
  match goal with
  | [H1: optimize_range_check_on_copy_out ?e _ _ _,
     H2: evalExpRT _ _ ?e _ |- _] =>
      specialize (eval_expr_value_copy_out_opt_reserve _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma eval_expr_value_copy_out_opt_reserve_backward: forall e eBound rBound e' st s v,
  optimize_range_check_on_copy_out e eBound rBound e' ->
    evalExpRT st s e' v ->
      evalExpRT st s e v.
Proof.
  intros;
  inversion H; subst; auto;
  eapply eval_exp_ex_cks_stripped; smack.
Qed.

Ltac apply_eval_expr_value_copy_out_opt_reserve_backward :=
  match goal with
  | [H1: optimize_range_check_on_copy_out ?e _ _ ?e',
     H2: evalExpRT _ _ ?e' _ |- _] =>
      specialize (eval_expr_value_copy_out_opt_reserve_backward _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma optimize_range_check_preserve: forall st s ast_num n n' n'' v eBound eBound' eBound'',
  optimize_range_check (NameRT ast_num n) eBound eBound' n' ->
    optimize_range_check_on_copy_out n' eBound' eBound'' n'' ->
      evalNameRT st s n v ->
        evalExpRT st s n'' v /\ exists n1, n'' = NameRT ast_num n1.
Proof.
  intros; constructor.
- apply eval_expr_value_copy_out_opt_reserve with (e:=n') (eBound:=eBound') (rBound:=eBound''); auto.
  apply eval_expr_value_reserve with (e:=(NameRT ast_num n)) (eBound:=eBound) (rBound:=eBound'); auto.
  constructor; auto.
- inversion H; subst; inversion H0; subst; simpl; smack.
Qed.

Ltac apply_optimize_range_check_preserve :=
  match goal with
  [H1: optimize_range_check (NameRT ?ast_num ?n) ?eBound ?eBound' ?n',
   H2: optimize_range_check_on_copy_out ?n' ?eBound' ?eBound'' ?n'',
   H3: evalNameRT ?st ?s ?n ?v |- _] =>
    specialize (optimize_range_check_preserve _ _ _ _ _ _ _ _ _ _ H1 H2 H3);
    let HA := fresh "HA" in
    let HA1 := fresh "HA" in
    let HA2 := fresh "HA" in
    intros HA; destruct HA as [HA1 HA2]; destruct HA2; subst
  end.

Lemma optimize_range_check_preserve_backward: forall st s ast_num n n' n'' v eBound eBound' eBound'',
  optimize_range_check (NameRT ast_num n) eBound eBound' n' ->
    optimize_range_check_on_copy_out n' eBound' eBound'' n'' ->
      evalExpRT st s n'' v ->
        evalNameRT st s n v /\ exists n1, n'' = NameRT ast_num n1.
Proof.
  intros; constructor.
- specialize (eval_expr_value_copy_out_opt_reserve_backward _ _ _ _ _ _ _ H0 H1); intros HZ1.
  specialize (eval_expr_value_reserve_backward _ _ _ _ _ _ _ H HZ1); intros HZ2.
  inversion HZ2; auto.
- inversion H; subst; inversion H0; subst; simpl; smack.
Qed.

Ltac apply_optimize_range_check_preserve_backward :=
  match goal with
  [H1: optimize_range_check (NameRT ?ast_num ?n) ?eBound ?eBound' ?n',
   H2: optimize_range_check_on_copy_out ?n' ?eBound' ?eBound'' ?n'',
   H3: evalExpRT ?st ?s ?n'' ?v |- _] =>
    specialize (optimize_range_check_preserve_backward _ _ _ _ _ _ _ _ _ _ H1 H2 H3);
    let HA := fresh "HA" in
    let HA1 := fresh "HA" in
    let HA2 := fresh "HA" in
    intros HA; destruct HA as [HA1 HA2]; destruct HA2; subst
  end.

(*******************************************************************)

Lemma remove_check_on_binop_reserve: forall cks op v1 v2 v ck,
  evalBinOpRTS cks op v1 v2 (OK v) ->
    evalBinOpRTS (remove_check_flag ck cks) op v1 v2 (OK v).
Proof.
  intros;
  induction cks; smack;
  match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [|- context[beq_check_flag _ OverflowCheck]] => destruct (beq_check_flag ck OverflowCheck); auto
  | [|- context[beq_check_flag _ DivCheck]] => destruct (beq_check_flag ck DivCheck); auto
  end;
  apply ChecksBinOp with (v:=v4); smack.
Qed.

Lemma safe_remove_binop_check: forall cks op v1 v2 v ck v',
  evalBinOpRTS cks op v1 v2 v ->
    evalBinOpRT ck op v1 v2 (OK v') ->
      evalBinOpRTS (remove_check_flag ck cks) op v1 v2 v.
Proof.
  induction cks; smack;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalBinOpRT ?a _ _ _ _ |- context[?a]] => destruct a; inversion H; smack
  end;
  match goal with
  | [H1: ?x = _, H2: ?x = _ |- _] => rewrite H1 in H2; inversion H2; smack
  | _ => idtac
  end;
  match goal with
  | [H1: overflowCheck _ _,
     H2: overflowCheck _ _ |- _] => inversion H1; inversion H2; clear H1 H2; subst; apply_in_bound_unique
  | [H1: divCheck _ _ _ _,
     H2: divCheck _ _ _ _ |- _] => inversion H1; inversion H2; clear H1 H2; smack
  | _ => idtac
  end;
  solve
  [ apply ChecksBinOpRTE; auto |
    apply ChecksBinOp with (v:=v5); smack |
    apply ChecksBinOp with (v:=v4); smack
  ].
Qed.

Ltac apply_safe_remove_binop_check :=
  match goal with
  | [H1: evalBinOpRTS _ ?op ?v1 ?v2 _,
     H2: evalBinOpRT _ ?op ?v1 ?v2 (OK _) |- _] =>
      specialize (safe_remove_binop_check _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ; inversion HZ
  end.

Lemma remove_check_on_unop_reserve: forall cks op v v' ck,
  evalUnOpRTS cks op v (OK v') ->
    evalUnOpRTS (remove_check_flag ck cks) op v (OK v').
Proof.
  intros;
  induction cks; smack;
  match goal with
  | [H: evalUnOpRTS _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalUnOpRT _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [|- context[beq_check_flag _ OverflowCheck]] => destruct (beq_check_flag ck OverflowCheck); auto
  end;
  apply Do_Checks_Unop with (v':=v'0); smack.
Qed.

Lemma safe_remove_unop_check: forall cks op v v' ck v'',
  evalUnOpRTS cks op v v' ->
    evalUnOpRT ck op v (OK v'') ->
      evalUnOpRTS (remove_check_flag ck cks) op v v'.
Proof.
  induction cks; smack;
  match goal with
  | [H: evalUnOpRT _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalUnOpRTS _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: evalUnOpRT ?a _ _ _ |- context[?a]] => destruct a; inversion H; smack
  end.
  match goal with
  | [H1: Math.unary_minus _ = _, H2: Math.unary_minus _ = _ |- _] => rewrite H1 in H2; inversion H2; subst
  end;
  match goal with
  | [H1: overflowCheck _ _,
     H2: overflowCheck _ _ |- _] => inversion H1; inversion H2; clear H1 H2; subst; apply_in_bound_unique
  end.
Qed .

Ltac apply_safe_remove_unop_check :=
  match goal with
  | [H1: evalUnOpRTS _ ?op ?v _,
     H2: evalUnOpRT _ ?op ?v (OK _) |- _] =>
      specialize (safe_remove_unop_check _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ; inversion HZ
  end.

Lemma do_overflow_checks_reserve: forall v cks v' ck,
  in_bound v int32_bound true ->
    overflowChecks cks v v' ->
      overflowChecks (remove_check_flag ck cks) v v'.
Proof.
  intros; inversion H0; smack;
  inversion H1; smack.
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; smack
  end.
  match goal with
  | [|- context[beq_check_flag _ OverflowCheck]] => destruct (beq_check_flag ck OverflowCheck); auto
  end;
  constructor.
Qed.

Lemma do_range_checks_reserve: forall cks v l u ck,
  rangeChecks cks v l u (OK (Int v)) ->
    rangeChecks (remove_check_flag ck cks) v l u (OK (Int v)).
Proof.
  intros;
  inversion H; smack;
  match goal with
  | [|- context[beq_check_flag _ RangeCheck]] => destruct (beq_check_flag ck RangeCheck); auto
  end;
  constructor.
Qed.

Lemma do_range_check_same_result: forall e eBound rBound e' v l u,
  optimize_range_check e eBound rBound e' ->
    rangeChecks (exp_exterior_checks e) v l u (OK (Int v)) ->
      rangeChecks (exp_exterior_checks e') v l u (OK (Int v)).
Proof.
  intros;
  inversion H; smack;
  rewrite exp_updated_exterior_checks;
  apply do_range_checks_reserve; auto.
Qed.

Ltac apply_do_range_check_same_result :=
  match goal with
  | [H1: optimize_range_check ?e _ _ ?e',
     H2: rangeChecks (exp_exterior_checks ?e) _ _ _ (OK _) |- _] =>
      specialize (do_range_check_same_result _ _ _ _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma optimize_range_check_backward: forall v u0 v0 u' v' e e',
  in_bound v (Interval u0 v0) true ->
    optimize_range_check e (Interval u0 v0) (Interval u' v') e' ->
      exp_exterior_checks e = RangeCheck :: nil ->
        rangeChecks (exp_exterior_checks e') v u' v' (OK (Int v)) ->
          rangeChecks (RangeCheck :: nil) v u' v' (OK (Int v)).
Proof.
  intros;
  inversion H0; subst;
  rewrite H1 in *; smack;
  rewrite exp_updated_exterior_checks in H2;
  apply_In_Bound_SubBound_Trans; auto;
  constructor; auto; constructor; auto.
Qed.

Ltac apply_optimize_range_check_backward :=
 match goal with
 | [H1: in_bound ?v (Interval ?u0 ?v0) true,
    H2: optimize_range_check ?e (Interval ?u0 ?v0) (Interval ?u' ?v') ?e',
    H3: exp_exterior_checks ?e = RangeCheck :: nil,
    H4: rangeChecks (exp_exterior_checks ?e') ?v ?u' ?v' (OK (Int ?v)) |- _
   ] =>
   specialize (optimize_range_check_backward _ _ _ _ _ _ _ H1 H2 H3 H4);
   let HZ := fresh "HZ" in
   intro HZ
 end.

(*
Lemma optimize_range_check_subBound: forall e u v u' v' e',
  optimize_range_check e (Interval u v) (Interval u' v') e' ->
    List.In RangeCheck (exp_exterior_checks e) ->
      ~(List.In RangeCheck (exp_exterior_checks e')) ->
        sub_bound (Interval u v) (Interval u' v') true.

Lemma optimize_range_check_on_copy_out_subBound: forall v u0 v0 u' v' e e',
  optimize_range_check_on_copy_out e (Interval u v) (Interval u' v') e' ->
    List.In RangeCheck (exp_exterior_checks e) ->
      ~(List.In RangeCheck (exp_exterior_checks e')) ->
        sub_bound (Interval u v) (Interval u' v').
*)

(********************************************************************)
(********************************************************************)

Lemma optimize_overflow_check_reserve: forall vBound cks retBound cks',
  sub_bound vBound int32_bound false ->
    optimize_overflow_check vBound cks (retBound, cks') ->
      cks = cks'.
Proof.
  intros;
  inversion H0; smack;
  apply_sub_bound_unique; smack.
Qed.

Ltac apply_optimize_overflow_check_reserve :=
  match goal with
  | [H1: sub_bound ?b _ false,
     H2: optimize_overflow_check ?b _ _ |- _] =>
      specialize ( optimize_overflow_check_reserve _ _ _ _ H1 H2);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma optimize_range_check_reserve: forall v vBound vBound' e e',
  in_bound v vBound true ->
    in_bound v vBound' false ->
      optimize_range_check e vBound vBound' e' ->
        e' = e.
Proof.
  intros;
  match goal with
  | [H: optimize_range_check _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: sub_bound _ _ _ |- _] => inversion H; smack
  end;
  apply_In_Bound_Trans; smack;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; smack
  end.
Qed.

Ltac apply_optimize_range_check_reserve :=
  match goal with
  | [H1: in_bound ?v ?eBound true,
     H2: in_bound ?v ?eBound' false,
     H3: optimize_range_check _ ?eBound ?eBound' _ |- _] =>
      specialize (optimize_range_check_reserve _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma optimize_range_check_on_copy_out_reserve: forall v vBound vBound' e e',
  in_bound v vBound true ->
    in_bound v vBound' false ->
      optimize_range_check_on_copy_out e vBound vBound' e' ->
        e' = e.
Proof.
  intros;
  match goal with
  | [H: optimize_range_check_on_copy_out _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: sub_bound _ _ _ |- _] => inversion H; smack
  end;
  apply_In_Bound_Trans; smack;
  repeat progress match goal with
  | [H: in_bound _ _ _ |- _] => inversion H; clear H; smack
  end.
Qed.

Ltac apply_optimize_range_check_on_copy_out_reserve :=
  match goal with
  | [H1: in_bound ?v ?vBound true,
     H2: in_bound ?v ?vBound' false,
     H3: optimize_range_check_on_copy_out _ ?vBound ?vBound' _ |- _] =>
      specialize (optimize_range_check_on_copy_out_reserve _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

(********************************************************************)
(********************************************************************)

Lemma do_flagged_checks_on_divide_reserve: forall v1 v1Bound v2 v2Bound bound1 cks' v,
  in_bound v1 v1Bound true ->
    in_bound v2 v2Bound true ->
      optimize_rtc_binop Divide v1Bound v2Bound (DivCheck :: OverflowCheck :: nil) (bound1, cks') ->
        evalBinOpRTS (DivCheck :: OverflowCheck :: nil) Divide (Int v1) (Int v2) v ->
          evalBinOpRTS cks' Divide (Int v1) (Int v2) v.
Proof.
  intros;
  match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end.
  (*case 1*)
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; subst; smack
  end;
  constructor; smack.
  (*case 2: conflict*)
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: divCheck _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end;
  apply_in_bound_value_neq_zero;
  match goal with
  | [H1: Zeq_bool ?v2 0 = true, H2: Zeq_bool ?v2 0 = false |- _] => rewrite H1 in H2; inversion H2
  end.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end.

  (*case 1*)
  match goal with
  | [H: divCheck _ _ _ _ |- _] => inversion H; subst; smack
  end.
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; subst; smack
  end.

  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); auto.
  repeat progress match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end.
  apply_divide_in_bound.
  match goal with
  | [H: overflowCheck _ _ |- _] => inversion H; clear H; subst
  end.
  apply_In_Bound_SubBound_Trans.
  apply_in_bound_conflict; smack.

  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); auto.

  (* case 2 *)
  match goal with
  | [H: divCheck _ _ _ _ |- _] => inversion H; subst; smack
  end.
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; subst; smack
  end.
  repeat progress match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end.
  apply_divide_in_bound.
  match goal with
  | [H: overflowCheck _ _ |- _] => inversion H; clear H; subst
  end.
  apply_In_Bound_SubBound_Trans.
  apply_in_bound_conflict; smack.
Qed.

Ltac apply_do_flagged_checks_on_divide_reserve :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: optimize_rtc_binop Divide ?v1Bound ?v2Bound (DivCheck :: OverflowCheck :: nil) (?bound1, ?cks'),
     H4: evalBinOpRTS (DivCheck :: OverflowCheck :: nil) Divide (Int ?v1) (Int ?v2) ?v |- _ ] =>
      specialize (do_flagged_checks_on_divide_reserve _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma do_flagged_checks_on_modulus_reserve: forall v1 v1Bound v2 v2Bound bound1 cks' v,
  in_bound v1 v1Bound true ->
    in_bound v2 v2Bound true ->
      optimize_rtc_binop Modulus v1Bound v2Bound (DivCheck :: nil) (bound1, cks') ->
        evalBinOpRTS (DivCheck :: nil) Modulus (Int v1) (Int v2) v ->
          evalBinOpRTS cks' Modulus (Int v1) (Int v2) v.
Proof.
  intros;
  match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end.
  (*case 1*)
  constructor; smack.
  (*case 2: conflict*)
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: divCheck _ _ _ _ |- _] => inversion H; clear H; subst; smack
  end;
  apply_in_bound_value_neq_zero;
  match goal with
  | [H1: Zeq_bool ?v2 0 = true, H2: Zeq_bool ?v2 0 = false |- _] => rewrite H1 in H2; inversion H2
  end.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: divCheck _ _ _ _ |- _] => inversion H; subst; smack
  end;
  apply ChecksBinOp with (v:=(Int (v1 mod v2))); auto.
Qed.

Ltac apply_do_flagged_checks_on_modulus_reserve :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: optimize_rtc_binop Modulus ?v1Bound ?v2Bound (DivCheck :: nil) _,
     H4: evalBinOpRTS (DivCheck :: nil) Modulus (Int ?v1) (Int ?v2) ?v |- _ ] =>
      specialize (do_flagged_checks_on_modulus_reserve _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma do_flagged_checks_on_plus_reserve: forall v1 v1Bound v2 v2Bound bound1 cks' op v,
  op = Plus \/ op = Minus \/ op = Multiply ->
    in_bound v1 v1Bound true ->
    in_bound v2 v2Bound true ->
      optimize_rtc_binop op v1Bound v2Bound (OverflowCheck :: nil) (bound1, cks') ->
        evalBinOpRTS (OverflowCheck :: nil) op (Int v1) (Int v2) v ->
          evalBinOpRTS cks' op (Int v1) (Int v2) v.
Proof.
  intros;
  match goal with
  | [H: evalBinOpRTS _ _ _ _ _ |- _] => inversion H; subst; auto
  end.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; clear H; smack
  | _ => idtac
  end;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: overflowCheck _ _ |- _] => inversion H; subst
  | [H: divCheck _ _ _ _ |- _] => inversion H; subst
  end.
  (** case 1: Plus *)
  apply_Sub_Bound_Plus_Compat.
  apply_sub_bound_unique; smack.
  (** case 2: minus *)
  apply_Sub_Bound_Minus_Compat.
  apply_sub_bound_unique; smack.
  (** case 3: Multiply *)
  specialize (multiply_in_bound _ _ _ _ _ _ H0 H1); let HZ := fresh "HZ" in intro HZ.
  apply_In_Bound_SubBound_Trans.
  apply_in_bound_conflict; smack.
- match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; clear H; smack
  | _ => idtac
  end;
  match goal with
  | [H: evalBinOpRT _ _ _ _ _ |- _] => inversion H; subst; smack
  end;
  match goal with
  | [H: overflowCheck _ _ |- _] => inversion H; subst
  | [H: divCheck _ _ _ _ |- _] => inversion H; subst
  end.
Qed.

Ltac apply_do_flagged_checks_on_plus_reserve :=
  match goal with
  | [H1: ?op = Plus \/ ?op = Minus \/ ?op = Multiply,
     H2: in_bound ?v1 ?v1Bound true,
     H3: in_bound ?v2 ?v2Bound true,
     H4: optimize_rtc_binop ?op ?v1Bound ?v2Bound (OverflowCheck :: nil) _,
     H5: evalBinOpRTS (OverflowCheck :: nil) ?op (Int ?v1) (Int ?v2) ?v |- _] =>
      specialize (do_flagged_checks_on_plus_reserve _ _ _ _ _ _ _ _ H1 H2 H3 H4 H5);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma evalUnOpRTS_reserve: forall v vBound op cks bound1 cks' v',
  in_bound v vBound true ->
    optimize_rtc_unop op vBound cks (bound1, cks') ->
      evalUnOpRTS cks op (Int v) v' ->
        evalUnOpRTS cks' op (Int v) v'.
Proof.
  intros;
  match goal with
  | [H: evalUnOpRTS _ _ _ _ |- _] => inversion H; smack
  end.
- match goal with
  | [H: optimize_rtc_unop _ _ _ _ |- _] => inversion H; clear H; smack
  end;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; clear H; smack
  | _ => idtac
  end; constructor; auto.
- match goal with
  | [H: evalUnOpRT _ _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: optimize_rtc_unop _ _ _ _ |- _] => inversion H; clear H; smack
  end;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; subst
  end;
  match goal with
  | [H: overflowCheck _ _ |- _] => inversion H; subst
  end;
  [ apply_Sub_Bound_Unary_Minus_Compat; apply_sub_bound_unique |
    apply Do_Checks_Unop_RTE; auto
  ].
- match goal with
  | [H: optimize_rtc_unop _ _ _ _ |- _] => inversion H; clear H; smack
  end;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; clear H; smack
  end;
  destruct ck;
  match goal with
  | [H: evalUnOpRT _ _ _ _ |- _] => inversion H; smack
  end;
  apply_safe_remove_unop_check; smack.
Qed.

Ltac apply_evalUnOpRTS_reserve :=
  match goal with
  | [H1: in_bound ?v ?bound1 true,
     H2: optimize_rtc_unop _ ?bound1 _ _,
     H3: evalUnOpRTS _ _ (Int ?v) _ |- _] =>
      specialize (evalUnOpRTS_reserve _ _ _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

(********************************************************************)
(********************************************************************)
(*binop_arithm_in_bound*)
Lemma plus_result_in_bound: forall op v1 v2 v v1Bound v2Bound vBound in_cks,
  op = Plus \/ op = Minus \/ op = Multiply ->
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  evalBinOpRTS (OverflowCheck :: nil) op (Int v1) (Int v2) (OK (Int v)) ->
  optimize_rtc_binop op v1Bound v2Bound (OverflowCheck :: nil) (vBound, in_cks) ->
  in_bound v vBound true.
Proof.
  intros.
  match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; clear H; smack
  end.
- inversion H12; clear H12; subst;
  inversion H2; clear H2; subst;
  inversion H5; clear H5; subst;
  inversion H11; clear H11; subst.
  + inversion H6; subst.
    specialize (In_Bound_Plus_Compat _ _ _ _ _ _ H0 H1); auto.
  + rewrite H7 in H2; inversion H2; subst.
    inversion H4; subst.
    inversion H7; subst.
    apply In_Bound_Two; smack.
    specialize (In_Bound_Plus_Compat _ _ _ _ _ _ H0 H1); auto.
- inversion H12; clear H12; subst;
  inversion H2; clear H2; subst;
  inversion H5; clear H5; subst;
  inversion H11; clear H11; subst.
  + inversion H6; subst.
    specialize (In_Bound_Minus_Compat _ _ _ _ _ _ H0 H1); auto.
  + rewrite H7 in H3; inversion H3; subst.
    inversion H4; subst.
    inversion H7; subst.
    apply In_Bound_Two; smack.
    specialize (In_Bound_Minus_Compat _ _ _ _ _ _ H0 H1); auto.
- specialize (multiply_in_bound _ _ _ _ _ _ H0 H1); let HZ := fresh "HZ" in intro HZ.
  inversion H9; clear H9; subst;
  inversion H2; clear H2; subst;
  inversion H5; clear H5; subst;
  inversion H11; clear H11; subst.
  + inversion H6; subst; auto.
  + rewrite H7 in H3; inversion H3; subst.
    inversion H4; subst.
    inversion H7; subst.
    apply In_Bound_Two; smack.
Qed.

Ltac apply_plus_result_in_bound :=
  match goal with
  | [H1: ?op' = Plus \/ ?op' = Minus \/ ?op' = Multiply,
     H2: in_bound ?v1' ?bound1' true,
     H3: in_bound ?v2' ?bound2' true,
     H4: evalBinOpRTS (OverflowCheck :: nil) ?op' (Int ?v1') (Int ?v2') (OK (Int _)),
     H5: optimize_rtc_binop ?op' ?bound1' ?bound2' (OverflowCheck :: nil) _ |- _] =>
      specialize (plus_result_in_bound _ _ _ _ _ _ _ _ H1 H2 H3 H4 H5);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma modulus_result_in_bound: forall v1 v2 v v1Bound v2Bound vBound in_cks,
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  evalBinOpRTS (DivCheck :: nil) Modulus (Int v1) (Int v2) (OK (Int v)) ->
  optimize_rtc_binop Modulus v1Bound v2Bound (DivCheck :: nil) (vBound, in_cks) ->
  in_bound v vBound true.
Proof.
  intros;
  match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; clear H; smack
  end;
  inversion H1; clear H1; subst;
  inversion H4; clear H4; subst;
  inversion H7; clear H7; subst;
  inversion H11; clear H11; subst;
  apply_modulus_in_bound;
  inversion H2; smack.
Qed.

Ltac apply_modulus_result_in_bound :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: evalBinOpRTS (DivCheck :: nil) Modulus (Int ?v1) (Int ?v2) (OK (Int ?v)),
     H4: optimize_rtc_binop Modulus ?v1Bound ?v2Bound (DivCheck :: nil) _ |- _] =>
      specialize (modulus_result_in_bound _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma divide_result_in_bound: forall v1 v2 v v1Bound v2Bound vBound in_cks,
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  evalBinOpRTS (DivCheck :: OverflowCheck :: nil) Divide (Int v1) (Int v2) (OK (Int v)) ->
  optimize_rtc_binop Divide v1Bound v2Bound (DivCheck :: OverflowCheck :: nil) (vBound, in_cks) ->
  in_bound v vBound true.
Proof.
  intros;
  match goal with
  | [H: optimize_rtc_binop _ _ _ _ _ |- _] => inversion H; subst; clear H; smack
  end.
- inversion H10; clear H10; subst;
  inversion H1; clear H1; subst;
  inversion H4; clear H4; subst;
  inversion H9; clear H9; subst;
  inversion H12; clear H12; subst;
  inversion H15; clear H15; subst;
  inversion H9; clear H9; subst;
  apply_divide_in_bound; smack.

  apply In_Bound_Two; auto.
  inversion H11; subst.
  inversion H8; subst; auto.
- inversion H11; clear H11; subst;
  inversion H1; clear H1; subst;
  inversion H4; clear H4; subst;
  inversion H9; clear H9; subst;
  inversion H12; clear H12; subst;
  inversion H15; clear H15; subst;
  inversion H9; clear H9; subst;
  apply_divide_in_bound; smack.

  apply In_Bound_Two; auto.
  inversion H11; subst.
  inversion H8; subst; auto.
Qed.

Ltac apply_divide_result_in_bound :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: evalBinOpRTS (DivCheck :: OverflowCheck :: nil) Divide (Int ?v1) (Int ?v2) (OK (Int ?v)),
     H4: optimize_rtc_binop Divide ?v1Bound ?v2Bound (DivCheck :: OverflowCheck :: nil) (?vBound, ?in_cks) |- _] =>
      specialize (divide_result_in_bound _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

(* binop_arithm_in_bound1 *)
Lemma plus_result_in_bound_backward: forall op v1 v2 v v1Bound v2Bound vBound in_cks,
  op = Plus \/ op = Minus \/ op = Multiply ->
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  optimize_rtc_binop op v1Bound v2Bound (OverflowCheck :: nil) (vBound, in_cks) ->
  evalBinOpRTS in_cks op (Int v1) (Int v2) v ->
  evalBinOpRTS (OverflowCheck :: nil) op (Int v1) (Int v2) v.
Proof.
  intros.
  inversion H2; clear H2; subst; smack.
- inversion H12; clear H12; smack.
  inversion H3; smack.
  apply ChecksBinOp with (v := Int (v1+v2)); auto.
  eapply OverflowCheckBinop; smack.
  constructor.
  specialize (In_Bound_Plus_Compat _ _ _ _ _ _ H0 H1); intros.
  apply_In_Bound_SubBound_Trans; auto.
- inversion H12; clear H12; smack.
  inversion H3; smack.
  apply ChecksBinOp with (v := Int (v1-v2)); auto.
  eapply OverflowCheckBinop; smack.
  constructor.
  specialize (In_Bound_Minus_Compat _ _ _ _ _ _ H0 H1); intros.
  apply_In_Bound_SubBound_Trans; auto.
- (** Multiply *)
  inversion H9; clear H9; smack.
  inversion H3; smack.
  apply ChecksBinOp with (v := Int (v1*v2)); auto.
  eapply OverflowCheckBinop; smack.
  constructor.
  specialize (multiply_in_bound _ _ _ _ _ _ H0 H1); intro.
  apply_In_Bound_SubBound_Trans; auto.
Qed.

Ltac apply_plus_result_in_bound_backward :=
  match goal with
  | [H1: ?op' = Plus \/ ?op' = Minus \/ ?op' = Multiply,
     H2: in_bound ?v1' ?bound1' true,
     H3: in_bound ?v2' ?bound2' true,
     H4: optimize_rtc_binop ?op' ?bound1' ?bound2' (OverflowCheck :: nil) (?vBound, ?in_cks),
     H5: evalBinOpRTS ?in_cks ?op' (Int ?v1') (Int ?v2') _ |- _] =>
      specialize (plus_result_in_bound_backward _ _ _ _ _ _ _ _ H1 H2 H3 H4 H5);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma modulus_result_in_bound_backward: forall v1 v2 v v1Bound v2Bound vBound in_cks,
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  optimize_rtc_binop Modulus v1Bound v2Bound (DivCheck :: nil) (vBound, in_cks) ->
  evalBinOpRTS in_cks Modulus (Int v1) (Int v2) v ->
  evalBinOpRTS (DivCheck :: nil) Modulus (Int v1) (Int v2) v.
Proof.
  intros.
  inversion H1; clear H1; subst; smack.
  inversion H2; clear H2; smack.
  specialize (in_bound_value_neq_zero _ _ H0 H5); intro HZ.
  apply_modulus_in_bound.
  apply ChecksBinOp with (v := Int (v1 mod v2)); auto;
  constructor; auto.
  constructor; auto.
Qed.

Ltac apply_modulus_result_in_bound_backward :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: optimize_rtc_binop Modulus ?v1Bound ?v2Bound (DivCheck :: nil) (?vBound, ?in_cks),
     H4: evalBinOpRTS ?in_cks Modulus (Int ?v1) (Int ?v2) ?v |- _] =>
      specialize (modulus_result_in_bound_backward _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma divide_result_in_bound_backward: forall v1 v2 v v1Bound v2Bound vBound in_cks,
  in_bound v1 v1Bound true ->
  in_bound v2 v2Bound true ->
  optimize_rtc_binop Divide v1Bound v2Bound (DivCheck :: OverflowCheck :: nil) (vBound, in_cks) ->
  evalBinOpRTS in_cks Divide (Int v1) (Int v2) v ->
  evalBinOpRTS (DivCheck :: OverflowCheck :: nil) Divide (Int v1) (Int v2) v.
Proof.
  intros.
  inversion H1; clear H1; subst; smack.
- inversion H10; clear H10; smack.
  match goal with
  | [H1: evalBinOpRTS (DivCheck :: _) Divide _ _ _ |- _] =>
      inversion H1; subst
  end.
  (*case 1*)
  apply ChecksBinOpRTE; auto.
  (*case 2*)
  repeat progress match goal with
  | [H1: evalBinOpRT DivCheck _ _ _ _ |- _] => inversion H1; subst; clear H1
  | [H1: divCheck ?op ?v0 ?v3 _ |- _ ] => inversion H1; subst; clear H1
  end.
  inversion H12; subst.
  inversion H1; subst.
  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); auto.
  constructor; auto. constructor; auto.

  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); auto.
  apply OverflowCheckBinop with (v:=(v1 ÷ v2)%Z); auto.
  constructor; auto.
  apply_divide_in_bound.
  apply_In_Bound_SubBound_Trans; auto.
- apply_in_bound_value_neq_zero; auto.
  apply_divide_in_bound.
  inversion H11; clear H11; smack;
  match goal with
  | [H1: evalBinOpRTS _ _ _ _ _ |- _] => inversion H1; subst; clear H1
  end.

  (* case 1 *)
  inversion H1; subst.
  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); smack.
  constructor; auto. constructor; smack.

  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); smack.
  apply OverflowCheckBinop with (v:=(v1 ÷ v2)%Z); auto.
  constructor; auto.
  apply_In_Bound_SubBound_Trans; auto.
  constructor; auto.

  (* case 2 *)
  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); smack;
  constructor; auto.
  constructor; auto.

  (* case 3 *)
  inversion H12; subst.
  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); smack.
  constructor; auto.
  constructor; auto.

  inversion H4; subst.
  inversion H2; subst.
  inversion H3; subst.
  apply ChecksBinOp with (v:=(Int (v1 ÷ v2))); smack.
Qed.

Ltac apply_divide_result_in_bound_backward :=
  match goal with
  | [H1: in_bound ?v1 ?v1Bound true,
     H2: in_bound ?v2 ?v2Bound true,
     H3: optimize_rtc_binop Divide ?v1Bound ?v2Bound (DivCheck :: OverflowCheck :: nil) (?vBound, ?in_cks),
     H4: evalBinOpRTS ?in_cks Divide (Int ?v1) (Int ?v2) ?v |- _] =>
      specialize (divide_result_in_bound_backward _ _ _ _ _ _ _ H1 H2 H3 H4);
      let HZ := fresh "HZ" in intro HZ
  end.

Lemma unop_arithm_in_bound: forall v v' vBound vBound' in_cks,
  in_bound v vBound true ->
  evalUnOpRTS (OverflowCheck :: nil) Unary_Minus (Int v) (OK (Int v')) ->
  optimize_rtc_unop Unary_Minus vBound (OverflowCheck :: nil) (vBound', in_cks) ->
  in_bound v' vBound' true.
Proof.
  intros.
  inversion H0; clear H0; subst.
  inversion H4; clear H4; subst.
  inversion H8; clear H8; subst.
  unfold Math.unary_operation in H4.
  rewrite H4 in H0; inversion H0; subst.
  inversion H4; subst.

  inversion H1; clear H1; smack.
  inversion H10; smack.
- apply In_Bound_Unary_Minus_Compat; auto.
- inversion H2; smack.
  specialize (In_Bound_Unary_Minus_Compat _ _ _ H); intro HZ.
  unfold int32_bound in H5.
  apply_In_Bound_Two; auto.
Qed.

Ltac apply_unop_arithm_in_bound :=
  match goal with
  | [H1: in_bound ?v ?bound true,
     H2: evalUnOpRTS (OverflowCheck :: nil) Unary_Minus (Int ?v) (OK (Int ?v')),
     H3: optimize_rtc_unop Unary_Minus ?bound (OverflowCheck :: nil) _ |- _] =>
      specialize (unop_arithm_in_bound _ _ _ _ _ H1 H2 H3);
      let HZ := fresh "HZ" in intros HZ
  end.

Lemma literal_checks_optimization_soundness: forall cks l v lBound cks',
  evalLiteralRT cks l v ->
    optLiteral l cks (lBound, cks') ->
      evalLiteralRT cks' l v.
Proof.
  intros;
  inversion H; inversion H0; smack;
  constructor;
  match goal with
  | [H: optimize_overflow_check _ _ _ |- _] => inversion H; smack
  end;
  match goal with
  | [H: sub_bound _ _ _ |- _] => inversion H; clear H; smack
  end;
  specialize (do_overflow_checks_reserve _ _ _ OverflowCheck H5 H1); auto.
Qed.

Ltac apply_literal_checks_optimization_soundness :=
  match goal with
  | [H1: evalLiteralRT _ ?c _,
     H2: optLiteral ?c _ _ |- _] =>
      specialize (literal_checks_optimization_soundness _ _ _ _ _ H1 H2); auto
  end.

Lemma optimize_exp_ex_cks_stripped: forall e e' st cks vBound,
  optExp st (update_exterior_checks_exp e cks) (e', vBound) ->
    optExp st e (update_exterior_checks_exp e' (exp_exterior_checks e), vBound).
Proof.
  apply (expression_x_ind
    (fun e: expRT =>
       forall (e' : expRT) (st : symTabRT) (cks : exterior_checks) (vBound : bound),
      optExp st (update_exterior_checks_exp e cks) (e', vBound) ->
      optExp st e (update_exterior_checks_exp e' (exp_exterior_checks e), vBound))
    (fun n: nameRT =>
       forall (n' : nameRT) (st : symTabRT) (cks : exterior_checks) (vBound : bound),
      optName st (update_exterior_checks_name n cks) (n', vBound) ->
      optName st n (update_exterior_checks_name n' (name_exterior_checks n), vBound))
    ); intros;
  match goal with
  | [H: optExp _ _ _ |- _] => inversion H; subst
  | [H: optName _ _ _ |- _] => inversion H; subst
  end.
- constructor; auto.
- constructor.
  specialize (H _ _ _ _ H3); auto.
- apply O_BinOp with (e1Bound := e1Bound) (e2Bound := e2Bound); auto.
- apply O_UnOp with (eBound := eBound); auto.
- apply O_Identifier with (t := t); auto.
- apply O_IndexedComponent with (xBound := xBound) (e' := e') (u := u) (v := v)
                                (t := t) (u' := u') (v' := v'); auto.
- apply O_SelectedComponent with (x' := x') (xBound := xBound) (t := t); auto.
Qed.

Lemma optimize_name_ex_cks_stripped: forall n n' st cks vBound,
  optName st (update_exterior_checks_name n cks) (n', vBound) ->
    optName st n (update_exterior_checks_name n' (name_exterior_checks n), vBound).
Proof.
  induction n; intros;
  inversion H; subst; simpl.
- apply O_Identifier with (t := t); auto.
- apply O_IndexedComponent with (xBound := xBound) (e':=e') (u:=u) (v:=v) (t:=t) (u':=u') (v':=v'); auto.
- apply O_SelectedComponent with (x':=x') (xBound:=xBound) (t:=t); auto.
Qed.


Require Export Syntax.
Require Export Static.

Inductive wf_msg (H : heap) (L : list loc) : expr -> Prop :=
  | WF_Msg :
      forall x e,
        (exists t, extend empty x TPas |- e \in t) ->
        (forall l, In l (freeLocs e) -> In l L) ->
        (forall id, In id (freeIds e) -> id < length H) ->
        (forall l id,
           In (l, id) (freeBIds e) ->
           id < length H /\
           (forall L', LH H id = Some L' -> In l L')) ->
        wf_msg H L (ELam x TPas e)
.

Definition wf_queue (H : heap) (L : list loc) (Q : list expr) : Prop :=
    (forall msg, In msg Q -> wf_msg H L msg)
.

Inductive wf_actor (H : heap) : (loc * list loc * list expr * expr) -> Prop :=
  | WF_Actor :
      forall l L Q e,
        In l L ->
        wf_queue H L Q ->
        (exists t, empty |- e \in t) ->
        (forall l', In l' (freeLocs e) -> In l' L) ->
        (forall id, In id (freeIds e) -> id < length H) ->
        (forall l' id,
           In (l', id) (freeBIds e) ->
           id < length H /\
           (forall L, LH H id = Some L -> In l' L)) ->
        wf_actor H (l, L, Q, e)
.

Inductive wf_heap (H : heap) : Prop :=
  | WF_Heap :
      (forall id1 id2 L1 L2,
         id1 <> id2 ->
         LH H id1 = Some L1 ->
         LH H id2 = Some L2 ->
         (forall l, In l L1 -> ~ In l L2))
      ->
      (forall id a,
          heapLookup H id = Some a ->
          wf_actor H a) ->
      wf_heap H
.

Inductive wf_cfg : configuration -> Prop :=
  | WF_Cfg :
      forall H n,
        wf_heap H ->
        (forall L id, LH H id = Some L -> Forall (fun l => l < n) L) ->
        wf_cfg (H, n)
.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e216m2e108m1_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.