Require Import memory.
Require Import language.
Require Import join_lib.
Require Import join_tactics.

Import veg.

Lemma mem_join_disjoint_merge' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    disjoint m3 m4 ->
    join (merge m1 m4) m2 (merge m3 m4).
  hy.
Qed.

Lemma mem_join_disjoint_merge :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    disjoint m3 m4 ->
    join (merge m1 m4) m2 (merge m3 m4).
Proof.
  intros.
  eapply mem_join_disjoint_merge'; ica.
Qed.

Lemma mem_sub_disjoint_sub_merge' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3,
    Maps.sub m1 m2 ->
    disjoint m2 m3 ->
    Maps.sub m1 (merge m2 m3).
  hy.
Qed.

Lemma mem_sub_disjoint_sub_merge :
  forall (m1:mem) m2 m3,
    Maps.sub m1 m2 ->
    disjoint m2 m3 ->
    Maps.sub m1 (merge m2 m3).
Proof.
  intros.
  eapply mem_sub_disjoint_sub_merge'; ica.
Qed.

Lemma osabst_join_disjoint_merge' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = false ->
    join m1 m2 m3 ->
    disjoint m3 m4 ->
    join (merge m1 m4) m2 (merge m3 m4).
  hy.
Qed.

Lemma osabst_join_disjoint_merge :
  forall (m1:osabst) m2 m3 m4,
    join m1 m2 m3 ->
    disjoint m3 m4 ->
    join (merge m1 m4) m2 (merge m3 m4).
Proof.
  intros.
  eapply osabst_join_disjoint_merge'; ica.
Qed.

Lemma osabst_join_disjoint_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m12 m3,
    join m1 m2 m12 ->
    disjoint m12 m3 ->
    disjoint m1 m3.
  hy.
Qed.

Lemma osabst_join_disjoint_disjoint :
  forall (m1:osabst) m2 m12 m3,
    join m1 m2 m12 ->
    disjoint m12 m3 ->
    disjoint m1 m3.
Proof.
  intros.
  eapply osabst_join_disjoint_disjoint'; eauto.
Qed.

Lemma mem_join_join_merge_eq' :
  forall (A B T : Type) (MC : PermMap A B T) M1 M2 M3 M4 M,
    join M1 M2 M ->
    join M3 M4 M2 ->
    M = merge M3 (merge M1 M4).
  hy.
Qed.

Lemma mem_join_join_merge_eq :
  forall (M1:mem) M2 M3 M4 M,
    join M1 M2 M ->
    join M3 M4 M2 ->
    M = merge M3 (merge M1 M4).
Proof.
  intros.
  eapply mem_join_join_merge_eq'; eauto.
Qed.

Lemma mem_disj_join_disjmerge':
  forall (A B T : Type) (MC : PermMap A B T) M M' M1 M2,
    disjoint M M' ->
    join M1 M2 M' ->
    disjoint (merge M2 M) M1.
  hy.
Qed.

Lemma mem_disj_join_disjmerge:
  forall (M:mem) M' M1 M2,
    disjoint M M' ->
    join M1 M2 M' ->
    disjoint (merge M2 M) M1.
Proof.
  intros.
  eapply mem_disj_join_disjmerge'; eauto.
Qed.

Lemma osabst_sub_merge_minus_eq' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2,
    usePerm = false ->
    Maps.sub o1 o2 ->
    merge o1 (minus o2 o1) = o2.
  hy.
Qed.

Lemma osabst_sub_merge_minus_eq :
  forall (o1:osabst) o2,
    Maps.sub o1 o2 ->
    merge o1 (minus o2 o1) = o2.
Proof.
  intros.
  eapply osabst_sub_merge_minus_eq'; eauto.
Qed.

Lemma osabst_join_eq_merge' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3,
    usePerm = false ->
    join m1 m2 m3 ->
    m3 = merge m1 m2.
  hy.
Qed.

Lemma osabst_join_eq_merge :
  forall (m1:osabst) m2 m3,
    join m1 m2 m3 ->
    m3 = merge m1 m2.
Proof.
  intros.
  eapply osabst_join_eq_merge'; ica.
Qed.

Lemma osabst_join_minus_eq' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    join o1 o2 o3 ->
    minus o3 o1 = o2.
Proof.
  hy.
Qed.

Lemma osabst_join_minus_eq :
  forall (o1:osabst) o2 o3,
    join o1 o2 o3 ->
    minus o3 o1 = o2.
Proof.
  intros.
  eapply osabst_join_minus_eq'; ica.
Qed.

Lemma osabst_join_disjoint_minus_disjoint_minus' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4 o5,
    usePerm = false ->
    join o1 o2 o3 ->
    disjoint o4 (minus o3 o5) ->
    disjoint o4 (minus o2 o5).
  hy.
Qed.

Lemma osabst_join_disjoint_minus_disjoint_minus :
  forall (o1:osabst) o2 o3 o4 o5,
    join o1 o2 o3 ->
    disjoint o4 (minus o3 o5) ->
    disjoint o4 (minus o2 o5).
Proof.
  intros.
  eapply osabst_join_disjoint_minus_disjoint_minus'; ica.
Qed.

Lemma osabst_join_disjoint_minus_join' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    join o1 o2 o3 ->
    disjoint o1 o4 ->
    join o1 (minus o2 o4) (minus o3 o4).
  hy.
Qed.

Lemma osabst_join_disjoint_minus_join :
  forall (o1:osabst) o2 o3 o4,
    join o1 o2 o3 ->
    disjoint o1 o4 ->
    join o1 (minus o2 o4) (minus o3 o4).
Proof.
  intros.
  eapply osabst_join_disjoint_minus_join'; ica.
Qed.

Lemma osabst_disjoint_minus_join_disjoint_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4 o5,
    usePerm = false ->
    disjoint o1 (minus o2 o3) ->
    join o4 o5 o2 ->
    disjoint o4 o3 ->
    disjoint o1 o4.
  hy.
Qed.

Lemma osabst_disjoint_minus_join_disjoint_disjoint :
  forall (o1:osabst) o2 o3 o4 o5,
    disjoint o1 (minus o2 o3) ->
    join o4 o5 o2 ->
    disjoint o4 o3 ->
    disjoint o1 o4.
Proof.
  intros.
  eapply osabst_disjoint_minus_join_disjoint_disjoint'; ica.
Qed.

Lemma osabst_join_disjoint_merge1' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    join o1 o2 o3 ->
    disjoint o4 o1 ->
    join o1 (merge o4 o2) (merge o4 o3).
  hy.
Qed.

Lemma osabst_join_disjoint_merge1 :
  forall (o1:osabst) o2 o3 o4,
    join o1 o2 o3 ->
    disjoint o4 o1 ->
    join o1 (merge o4 o2) (merge o4 o3).
Proof.
  intros.
  eapply osabst_join_disjoint_merge1'; ica.
Qed.

(* Lemma mem_join_disjoint_minus' : *)
(*   forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4, *)
(*     usePerm = true -> *)
(*     join m1 m2 m3 -> *)
(*     disjoint m1 m4 -> *)
(*     join m1 (minus m2 m4) (minus m3 m4). *)
(*   hy. *)
(* Qed. *)

(** error! **)
(* Lemma mem_join_disjoint_minus : *)
(*   forall (m1:mem) m2 m3 m4, *)
(*     join m1 m2 m3 -> *)
(*     disjoint m1 m4 -> *)
(*     join m1 (minus m2 m4) (minus m3 m4). *)
(* Proof. *)
(*   intros. *)
(*   eapply mem_join_disjoint_minus'; ica. *)
(* Qed. *)

Lemma mem_sub_join_minus_join' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m1 ->
    join (minus m1 m4) m2 (minus m3 m4).
  hy.
Qed.

Lemma mem_sub_join_minus_join :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m1 ->
    join (minus m1 m4) m2 (minus m3 m4).
Proof.
  intros.
  eapply mem_sub_join_minus_join'; ica.
Qed.

Lemma mem_disjoint_sub_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3,
    usePerm = true ->
    Maps.sub m1 m2 ->
    disjoint m2 m3 ->
    disjoint m1 m3.
  hy.
Qed.

Lemma mem_disjoint_sub_disjoint :
  forall (m1:mem) m2 m3,
    Maps.sub m1 m2 ->
    disjoint m2 m3 ->
    disjoint m1 m3.
Proof.
  intros.
  eapply mem_disjoint_sub_disjoint'; ica.
Qed.

Lemma osabst_join_sub_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    join o1 o2 o3 ->
    Maps.sub o4 o2 ->
    disjoint o1 o4.
  hy.
Qed.

Lemma osabst_join_sub_disjoint :
  forall (o1:osabst) o2 o3 o4,
    join o1 o2 o3 ->
    Maps.sub o4 o2 ->
    disjoint o1 o4.
Proof.
  intros.
  eapply osabst_join_sub_disjoint'; ica.
Qed.

Lemma osabst_join_sub_join_minus' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    join o1 o2 o3 ->
    Maps.sub o4 o2 ->
    join o1 (minus o2 o4) (minus o3 o4).
  hy.
Qed.

Lemma osabst_join_sub_join_minus :
  forall (o1:osabst) o2 o3 o4,
    join o1 o2 o3 ->
    Maps.sub o4 o2 ->
    join o1 (minus o2 o4) (minus o3 o4).
Proof.
  intros.
  eapply osabst_join_sub_join_minus'; ica.
Qed.

Lemma osabst_join_minus1' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    join o1 o2 o3 ->
    minus o3 o1 = o2.
  hy.
Qed.

Lemma osabst_join_minus1 :
  forall (o1:osabst) o2 o3,
    join o1 o2 o3 ->
    minus o3 o1 = o2.
Proof.
  intros.
  eapply osabst_join_minus1'; ica.
Qed.

Lemma mem_join_sub_join_minus' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    join m1 (minus m2 m4) (minus m3 m4).
  hy.
Qed.

Lemma mem_join_sub_join_minus :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    join m1 (minus m2 m4) (minus m3 m4).
Proof.
  intros.
  eapply mem_join_sub_join_minus'; ica.
Qed.

Lemma mem_join_minus1' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3,
    usePerm = true ->
    join m1 m2 m3 ->
    minus m3 m1 = m2.
  hy.
Qed.

Lemma mem_join_minus1 :
  forall (m1:mem) m2 m3,
    join m1 m2 m3 ->
    minus m3 m1 = m2.
Proof.
  intros.
  eapply mem_join_minus1'; ica.
Qed.

Lemma osabst_sub_disjoint_sub_minus' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    Maps.sub o1 o2 ->
    disjoint o1 o3 ->
    Maps.sub o1 (minus o2 o3).
  hy.
Qed.

Lemma osabst_sub_disjoint_sub_minus :
  forall (o1:osabst) o2 o3,
    Maps.sub o1 o2 ->
    disjoint o1 o3 ->
    Maps.sub o1 (minus o2 o3).
Proof.
  intros.
  eapply osabst_sub_disjoint_sub_minus'; ica.
Qed.

Lemma osabst_disjoint_minus_minus_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    disjoint o1 (minus o2 o3) ->
    disjoint o1 (minus (minus o2 o4) o3).
  hy.
Qed.

Lemma osabst_disjoint_minus_minus_disjoint :
  forall (o1:osabst) o2 o3 o4,
    disjoint o1 (minus o2 o3) ->
    disjoint o1 (minus (minus o2 o4) o3).
Proof.
  intros.
  eapply osabst_disjoint_minus_minus_disjoint'; ica.
Qed.

Lemma osabst_disjoint_merge_disjoint2' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    disjoint (merge o1 o2) o3 ->
    disjoint o2 o3.
  hy.
Qed.

Lemma osabst_disjoint_merge_disjoint2 :
  forall (o1:osabst) o2 o3,
    disjoint (merge o1 o2) o3 ->
    disjoint o2 o3.
Proof.
  intros.
  eapply osabst_disjoint_merge_disjoint2'; ica.
Qed.

Lemma osabst_disjoint_minus_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    disjoint o1 o2 ->
    disjoint o1 (minus o2 o3).
  hy.
Qed.

Lemma osabst_disjoint_minus_disjoint :
  forall (o1:osabst) o2 o3,
    disjoint o1 o2 ->
    disjoint o1 (minus o2 o3).
Proof.
  intros.
  eapply osabst_disjoint_minus_disjoint'; ica.
Qed.

Lemma osabst_disjoint_disjoint_merge_distribute' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3 o4,
    usePerm = false ->
    disjoint o1 o2 ->
    disjoint (merge o1 o2) o3 ->
    Maps.sub o4 o3 ->
    join (merge o4 o1) (merge o2 (minus o3 o4)) (merge (merge o1 o2) o3).
  hy.
Qed.

Lemma osabst_disjoint_disjoint_merge_distribute :
  forall (o1:osabst) o2 o3 o4,
    disjoint o1 o2 ->
    disjoint (merge o1 o2) o3 ->
    Maps.sub o4 o3 ->
    join (merge o4 o1) (merge o2 (minus o3 o4)) (merge (merge o1 o2) o3).
Proof.
  intros.
  eapply osabst_disjoint_disjoint_merge_distribute'; ica.
Qed.

Lemma osabst_disjoint_minus_comm' :
  forall (A B T : Type) (MC : PermMap A B T) o1 o2 o3,
    usePerm = false ->
    disjoint o2 o3 ->
    minus (minus o1 o2) o3 = minus (minus o1 o3) o2.
  hy.
Qed.

Lemma osabst_disjoint_minus_comm :
  forall (o1:osabst) o2 o3,
    disjoint o2 o3 ->
    minus (minus o1 o2) o3 = minus (minus o1 o3) o2.
Proof.
  intros.
  eapply osabst_disjoint_minus_comm'; ica.
Qed.

Lemma sub_join_sub :
  forall
    {A B T:Type} {MC:PermMap A B T}
    m1 m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub m4 m3.
Proof.
  hy.
Qed.

Lemma mem_sub_join_sub' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub m4 m3.
  hy.
Qed.

Lemma mem_sub_join_sub :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub m4 m3.
Proof.
  intros.
  eapply mem_sub_join_sub'; ica.
Qed.

Lemma mem_join_sub_disjoint' :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    disjoint m1 m4.
  hy.
Qed.

Lemma mem_join_sub_disjoint :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    disjoint m1 m4.
Proof.
  intros.
  eapply mem_join_sub_disjoint'; ica.
Qed.

Lemma mem_join_sub_sub_merge_a :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m1 m4) m3.
  hy.
Qed.

Lemma mem_join_sub_sub_merge :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m1 m4) m3.
Proof.
  intros; eapply mem_join_sub_sub_merge_a; ica.
Qed.

Lemma mem_join_sub_sub_merge'_auto :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3 m4,
    usePerm = true ->
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m4 m1) m3.
  hy.
Qed.

Lemma mem_join_sub_sub_merge' :
  forall (m1:mem) m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m4 m1) m3.
Proof.
  intros; eapply mem_join_sub_sub_merge'_auto; ica.
Qed.

Lemma join_sub_sub_merge :
  forall {A B T:Type} {MC:PermMap A B T}
         m1 m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m1 m4) m3.
Proof.
  hy.
Qed.

Lemma join_sub_sub_merge' :
  forall {A B T:Type} {MC:PermMap A B T}
         m1 m2 m3 m4,
    join m1 m2 m3 ->
    Maps.sub m4 m2 ->
    Maps.sub (merge m4 m1) m3.
Proof.
  hy.
Qed.

Lemma mem_join_minus_auto :
  forall (A B T : Type) (MC : PermMap A B T) m1 m2 m3,
    usePerm = true ->
    join m1 m2 m3 ->
    m1 = minus m3 m2.
  hy.
Qed.

Lemma mem_join_minus :
  forall (m1:mem) m2 m3,
    join m1 m2 m3 ->
    m1 = minus m3 m2.
Proof.
  intros; eapply mem_join_minus_auto; ica.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

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

End FOFProblem.


Require Export Program CoqCommon.HList.
Set Implicit Arguments.
Definition FreeFunction := { T : Type & T -> Type }.
Definition InterpretFF (ff : FreeFunction) : Type := forall A : projT1 ff, (projT2 ff) A.
Section CompCoq.
  Variable l : list FreeFunction.
  Variable ff : hlist (fun x => (InterpretFF x * nat)%type) l.
  Inductive CompCoq : forall (T : Type) (F : T -> Type) (C : T -> nat), Type :=
  | CompId T : @CompCoq T (const T) (const 0)
  | CompApp T F (G : forall t, F t -> Type) m (M : member (existT _ T F) l) :
      (forall (t : T), @CompCoq (F t) (G t) (m t)) ->
      @CompCoq
        T
        (fun x => G x (fst (hget M ff) x))
        (fun x => snd (hget M ff) + m x (fst (hget M ff) x)).
  Definition Yank T F C (CC : @CompCoq T F C) t : F t.
    induction CC; intros; simpl in *; auto.
  Defined.
End CompCoq.


(*
abhishek@brixpro:~/parametricity/reflective-paramcoq/test-suite$ ./coqid.sh indFunArg
*)

Require Import SquiggleEq.terms.

Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.PIWNew.

Require Import Template.Template.

(* Inductive nat : Set :=  O : nat | S : forall ns:nat, nat. *)

Run TemplateProgram (genParamIndAll [] "Coq.Init.Datatypes.nat").

Run TemplateProgram (mkIndEnv "indTransEnv" ["Coq.Init.Datatypes.nat"]).
Run TemplateProgram (genWrappers indTransEnv).

(*
Set Printing All.

Run TemplateProgram (genParamIndTotAll [] true "Coq.Init.Datatypes.nat").

Run TemplateProgram (genParamIso [] "Coq.Init.Datatypes.nat").
*)

(* functions wont work until we fully produce the goodness of inductives *)


(* Proving the correctness of generating RTL from RTLblock *)

Require Import common.
Require Import monad.
Require Import monad_impl.
Require Import Errors.
Require Import RTL.
Require Import RTLblock.
Require Import IR.
Require Import flattenRTL.
Require Import customSmallstep.
Require Import internal_simulations.
Require Import sem_properties.
Require Import backend.
Require Import Globalenvs.
Require Import Values.
Require Import Integers.

(** * Simple lemmas *)
Lemma same_id:
  forall rtlb rtl,
    flatten rtlb = OK rtl ->
    prtl_id (Some (inr rtlb)) = prtl_id (Some (inl rtl)).
Proof.
  destruct rtlb as  (((fid, code), entry), ci).
  unfold flatten; intros rtl Hf.
  do_ok.
  destruct p; inv H0.
  reflexivity.
Qed.

Lemma same_cont_idx:
  forall i c e cont_ind i' c' e' cont_ind',
    flatten (i, c, e, cont_ind) = OK (i', c', e', cont_ind') ->
    cont_ind = cont_ind'.
Proof.
  intros i c e cont_ind i' c' e' cont_ind' H. unfold flatten in H.
  repeat do_ok. destruct p. inv H1. auto.
Qed.

Lemma same_entry:
  forall i c e cont_ind i' c' e' cont_ind',
    flatten (i, c, e, cont_ind) = OK (i', c', e', cont_ind') ->
    e = e'.
Proof.
  intros i c e cont_ind i' c' e' cont_ind' H. unfold flatten in H.
  repeat do_ok. destruct p. inv H1. auto.
Qed.

(** * Positive arithmetic  *)
Lemma inv_lt:
  forall p,
    (p < p)%positive -> False.
Proof.
  intros p H. eapply Pos.lt_irrefl. eauto.
Qed.

Lemma inv_succ:
  forall p,
    (Pos.succ p <= p)%positive -> False.
Proof.
  intros p H. rewrite Pos.le_succ_l in H. eapply inv_lt; eauto.
Qed.

Lemma succ_le:
  forall p l,
    (Pos.succ p <= l)%positive ->
    (p <= l)%positive.
Proof.
  intros p l H. eapply Pos.le_trans; eauto. apply Pos.lt_le_incl. apply Pos.lt_succ_diag_r.
Qed.

Lemma le_succ:
  forall p l,
    (p <= l)%positive ->
    (p <= Pos.succ l)%positive.
Proof.
  intros p l H. eapply Pos.le_trans; eauto. apply Pos.lt_le_incl. apply Pos.lt_succ_diag_r.
Qed.

Lemma lt_succ:
  forall p l,
    (p < l)%positive ->
    (p < Pos.succ l)%positive.
Proof.
  intros p l H. eapply Pos.lt_trans; eauto. apply Pos.lt_succ_diag_r.
Qed.

Lemma succ_lt:
  forall p l,
    (Pos.succ p < l)%positive ->
    (p < l)%positive.
Proof.
  intros p l H. eapply Pos.lt_trans; eauto. apply Pos.lt_succ_diag_r.
Qed.

Lemma lt_le:
  forall p1 p2,
    (p1 < p2)%positive ->
    (p2 <= p1)%positive ->
    False.
Proof.
  intros p1 p2 H H0. assert (p1 < p1)%positive.
  { eapply Pos.lt_le_trans; eauto. }
  eapply inv_lt; eauto.
Qed.

(** * BLOCK Representation  *)
(* representing that some blocks have been unfolded in the rtl code *)

(* expressing that some list of instructions is in rtlc at label pc, ending on next *)
Inductive unf_list: RTL.code -> list block_instr -> positive -> positive -> Prop :=
| unf_nil: forall rtlc pc,
    unf_list rtlc nil pc pc
| unf_cons: forall rtlc pc next bi l (i:RTL.instruction)
              (TRANSF_INSTR: basic_transf_block_instr bi (Pos.succ pc) = i)
              (FIRST: rtlc # pc = Some i)
              (NEXT: unf_list rtlc l (Pos.succ pc) next),
    unf_list rtlc (bi::l) pc next.

(* Expressing that some basic block is in rtlc at label pc *)
Inductive unf_bb: RTL.code -> basic_block -> positive -> Prop :=
| unf_basic: forall rtlc pc next li exiti e
               (LIST: unf_list rtlc li pc next)
               (TRANSF_EXIT: basic_transf_exit_instr exiti = e)
               (EXIT: rtlc # next = Some e),
    unf_bb rtlc (li, exiti) pc.

(* Expressing that some block is in rtlc at label pc *)
Inductive unf_block: RTL.code -> RTLblock.block -> positive -> Prop :=
| unf_bblock: forall rtlc pc bb next
                (BB: unf_bb rtlc bb next)
                (NOP: rtlc # pc = Some (Inop next)),
    unf_block rtlc (Bblock bb) pc
| unf_cblock: forall rtlc pc op args iftrue bb next
                (BB: unf_bb rtlc bb next)
                (COND: rtlc # pc = Some (Icond op args next iftrue)),
    unf_block rtlc (Cblock op args iftrue bb) pc.

(** * Code Generation Invariants  *)
(* Everything above the fresh label is undefined *)
Definition fresh (fsh:positive) (rtlc:RTL.code) :=
  forall l, (fsh <= l)%positive -> rtlc # l = None.

(* basic inclusion, for what's above the fresh label *)
Definition included (rtlc1 rtlc2:RTL.code) :=
  forall pc i, rtlc1 # pc = Some i -> rtlc2 # pc = Some i.

(* preservation of what's under the fresh label *)
Definition preserved (rtlc1 rtlc2:RTL.code) (fsh:positive) :=
  forall x, (x < fsh)%positive -> rtlc1 # x = rtlc2 # x.

(* When doing the PTree.fold, everything under fresh is set 1 by 1, only changing the current pc *)
Definition preserved_but (rtlc1 rtlc2:RTL.code) (fsh pc:positive) :=
  forall x, (x < fsh)%positive ->
       x <> pc ->
       rtlc1 # x = rtlc2 # x.

(* invariants lemmas *)
Lemma preserved_refl:
  forall r f,
    preserved r r f.
Proof.
  unfold preserved. intros r f x H. auto.
Qed.

Lemma unf_list_set:
  forall rtlc li pc next pcset i,
    unf_list rtlc li pc next ->
    fresh pcset rtlc ->
    unf_list (rtlc # pcset <- i) li pc next.
Proof.
  intros rtlc li pc next pcset i H H0. induction H.
  - constructor.
  - econstructor; eauto. rewrite PTree.gso; auto.
    intros EQ. subst. specialize (H0 _ (Pos.le_refl pcset)). rewrite FIRST in H0. inv H0.
Qed.

Lemma included_refl:
  forall rtlc, included rtlc rtlc.
Proof.
  unfold included. intros rtlc pc i H. auto.
Qed.

Lemma included_trans:
  forall r1 r2 r3,
    included r1 r2 -> included r2 r3 -> included r1 r3.
Proof.
  unfold included. intros r1 r2 r3 H H0 pc i H1. eapply H0. eapply H. auto.
Qed.

Lemma included_set:
  forall pc r i,
    fresh pc r ->
    included r (r # pc <- i).
Proof.
  unfold included, fresh. intros pc r i H pc0 i0 H0. rewrite PTree.gso. auto.
  intros EQ. subst. specialize (H _ (Pos.le_refl pc)). rewrite H in H0. inv H0.
Qed.

Lemma unf_list_inc:
  forall r1 li pc next r2,
    included r1 r2 ->
    unf_list r1 li pc next ->
    unf_list r2 li pc next.
Proof.
  intros r1 li pc next r2 H H0. induction H0.
  - constructor.
  - econstructor; eauto.
Qed.

Lemma unf_bb_inc:
  forall r1 bb pc r2,
    included r1 r2 ->
    unf_bb r1 bb pc ->
    unf_bb r2 bb pc.
Proof.
  intros r1 bb pc r2 H H0. inv H0. econstructor; eauto.
  eapply unf_list_inc; eauto.
Qed.

Lemma unf_block_inc:
  forall r1 b pc r2,
    included r1 r2 ->
    unf_block r1 b pc ->
    unf_block r2 b pc.
Proof.
  intros r1 b pc r2 H H0. inv H0.
  - econstructor; eauto. eapply unf_bb_inc; eauto.
  - econstructor; eauto. eapply unf_bb_inc; eauto.
Qed.

(** * Initial correctness of the transformations  *)
Lemma tbb_init_ok:
  forall r1 bb r2,
    transf_basic_block r1 bb = OK r2 ->
    exists rtlc1 pc, r1 = OK (rtlc1, pc).
Proof.
  intros r1 bb r2 H. unfold transf_basic_block in H. destruct bb.
  generalize dependent r1. induction l; intros.
  - inv H. unfold transf_exit_instr in H1. repeat do_ok. destruct p. inv H0. eauto.
  - simpl in H. apply IHl in H as [rtlc1 [pc H]]. unfold transf_block_instr in H. repeat do_ok.
    destruct p. inv H1. eauto.
Qed.

Lemma tei_init_ok:
  forall r1 ei r2,
    transf_exit_instr r1 ei = OK r2 ->
    exists rtlc1 pc, r1 = OK (rtlc1, pc).
Proof.
  intros r1 ei r2 H. unfold transf_exit_instr in H. repeat do_ok. destruct p. inv H1. eauto.
Qed.

Lemma tb_init_ok:
  forall r1 pc b r2,
    transf_block r1 pc b = OK r2 ->
    exists rtlc1 pc, r1 = OK (rtlc1, pc).
Proof.
  intros r1 pc b r2 H. unfold transf_block in H. destruct b.
  - repeat do_ok. destruct p. apply tbb_init_ok in H1 as H'. destruct H' as [r1 [l INIT]].
    inv INIT. eauto.
  - repeat do_ok. destruct p. apply tbb_init_ok in H1 as H'. destruct H' as [r1 [l' INIT]].
    inv INIT. eauto.
Qed.

Lemma fold_left_init_ok:
  forall l r1 r2,
    fold_left (fun a p => transf_block a (fst p) (snd p)) l r1 = OK (r2) ->
    exists rtlc1 pc, r1 = OK (rtlc1, pc).
Proof.
  intros l. induction l; intros.
  - simpl in H. inv H. destruct r2. eauto.
  - simpl in H. apply IHl in H as H'. destruct H' as [rtlc1 [p1 INIT]].
    apply tb_init_ok in INIT as H'. destruct H' as [rtlc' [p' INIT']]. eauto.
Qed.

(** * Incremental specifications of the transformations  *)
Lemma list_fold_ok:
  forall li rtlc1 fsh rtlc2 next,
    fold_left transf_block_instr li (OK (rtlc1, fsh)) = OK (rtlc2, next) ->
    fresh fsh rtlc1 ->
    fresh next rtlc2 /\
    (fsh <= next)%positive /\
    included rtlc1 rtlc2 /\
    preserved rtlc1 rtlc2 fsh /\
    unf_list rtlc2 li fsh next.
Proof.
  intros li. induction li; intros.
  - simpl in H. inv H. split; auto. split. apply Pos.le_refl. split.
    apply included_refl. split. apply preserved_refl. constructor.
  - simpl in H. apply IHli in H as H'. destruct H' as [FRESH [LT [INCL [PRES UNF]]]].
    + repeat try split; auto.
      * apply succ_le. auto.
      * eapply included_trans; eauto. apply included_set; auto.
      * unfold preserved in *. intros x H1. apply lt_succ in H1 as H2. apply PRES in H2.
        rewrite PTree.gso in H2. 2: { intros EQ. subst. eapply inv_lt. eauto. } auto.
      * econstructor; eauto. apply INCL. rewrite PTree.gss. auto.
    + unfold fresh. intros l H1. rewrite PTree.gso.
      2: { intros EQ. subst. eapply inv_succ; eauto. }
      apply H0. apply succ_le. auto.
Qed.

Lemma tbb_ok:
  forall rtlc1 fsh rtlc2 next bb,
    transf_basic_block (OK (rtlc1, fsh)) bb = OK (rtlc2, next) ->
    fresh fsh rtlc1 ->
    fresh next rtlc2 /\
    (fsh <= next)%positive /\
    included rtlc1 rtlc2 /\
    preserved rtlc1 rtlc2 fsh /\
    unf_bb rtlc2 bb fsh.
Proof.
  intros rtlc1 pc rtlc2 next bb H H0. destruct bb as [li ei]. unfold transf_basic_block in H.
  apply tei_init_ok in H as H'. destruct H' as [rtlc1' [pc' FOLD]]. rewrite FOLD in H.
  apply list_fold_ok in FOLD as H'; auto. destruct H' as [FRESH [LT [INCL [PRES UNF]]]].
  unfold transf_exit_instr in H. repeat do_ok. inv HDO. inv H2. repeat try split; auto.
  - unfold fresh. intros l H. rewrite PTree.gso; auto.
    + apply FRESH. apply succ_le. auto.
    + intros EQ. subst. eapply inv_succ; eauto.
  - apply le_succ. auto.
  - eapply included_trans; eauto. apply included_set; auto.
  - unfold preserved in *. intros x H. apply PRES in H as H'.
    rewrite PTree.gso; auto. intros EQ. subst. eapply lt_le; eauto.
  - eapply unf_basic with (next:=pc'); eauto.
    + apply unf_list_set; auto.
    + rewrite PTree.gss. auto.
Qed.

Lemma tb_ok:
  forall rtlc1 fsh pc rtlc2 next b,
    transf_block (OK (rtlc1, fsh)) pc b = OK (rtlc2, next) ->
    fresh fsh rtlc1 ->
    (pc < fsh)%positive ->
    rtlc1 # pc = None ->
    fresh next rtlc2 /\
    (fsh <= next)%positive /\
    included rtlc1 rtlc2 /\
    preserved_but rtlc1 rtlc2 fsh pc /\
    unf_block rtlc2 b pc.
Proof.
  intros rtlc1 fsh pc rtlc2 next b H H0 H1 H2. destruct b.
  - apply tbb_ok in H as H'. destruct H' as [FRESH [LT [INCL [PRES UNF]]]].
    2: { unfold fresh; intros. rewrite PTree.gso. apply H0. auto.
         intros EQ. subst. eapply lt_le; eauto. }
    repeat try split; auto.
    + eapply included_trans; eauto. unfold included.
      intros pc0 i H3. rewrite PTree.gso; auto. intros EQ. subst. rewrite H2 in H3. inv H3.
    + unfold preserved_but. intros x H3 H4. apply PRES in H3 as H'. rewrite PTree.gso in H'; auto.
    + eapply unf_bblock; eauto. apply INCL. rewrite PTree.gss. auto.
  - apply tbb_ok in H as H'. destruct H' as [FRESH [LT [INCL [PRES UNF]]]].
    2: { unfold fresh; intros. rewrite PTree.gso. apply H0. auto.
         intros EQ. subst. eapply lt_le; eauto. }
    repeat try split; auto.
    + eapply included_trans; eauto. unfold included.
      intros pc0 i H3. rewrite PTree.gso; auto. intros EQ. subst. rewrite H2 in H3. inv H3.
    + unfold preserved_but. intros x H3 H4. apply PRES in H3 as H'. rewrite PTree.gso in H'; auto.
    + eapply unf_cblock; eauto. apply INCL. rewrite PTree.gss. auto.
Qed.

Lemma flatten_fold_ok:
  forall l rtlc1 rtlc2 fsh next,
    list_norepet (map fst l) ->
    fold_left (fun a p => transf_block a (fst p) (snd p)) l (OK (rtlc1, fsh)) = OK (rtlc2, next) ->
    fresh fsh rtlc1 ->
    (forall x, In x (map fst l) -> (x < fsh)%positive) ->
    (forall x, In x (map fst l) -> rtlc1 # x = None) ->
    fresh next rtlc2 /\
    (fsh <= next)%positive /\
    included rtlc1 rtlc2 /\
    forall pc blk, In (pc, blk) l -> unf_block rtlc2 blk pc.
Proof.
  intros l. induction l; intros.
  - simpl in H0. inv H0. split; try split; try split; auto.
    + apply Pos.le_refl.
    + apply included_refl.
    + intros pc blk H0. inv H0.
  - inv H. destruct a as [pc blk]. simpl in *.
    apply fold_left_init_ok in H0 as H'. destruct H' as [rtlc' [fsh' INIT]].
    apply tb_ok in INIT as H'; auto. destruct H' as [FRESH [LT [INCL [PRES UNF]]]].
    rewrite INIT in H0. apply IHl in H0 as H'; auto. destruct H' as [FRESH' [LT' [INCL' UNF']]].
    2: { intros x H. eapply Pos.lt_le_trans; eauto. }
    2: { intros y H. rewrite <- PRES; auto. intros EQ. subst. apply H6. apply H. }
    split; try split; try split; auto.
    + eapply Pos.le_trans; eauto.
    + eapply included_trans; eauto.
    + intros pc0 blk0 H. destruct H.
      * inv H. eapply unf_block_inc; eauto.
      * apply UNF'. auto.
Qed.

Lemma in_map:
  forall X Y l (x:X),
    In x (map fst l) ->
    exists (y:Y), In (x,y) l.
Proof.
  intros X Y l x H. induction l; inv H.
  - destruct a. exists y. simpl. left. auto.
  - apply IHl in H0. destruct H0. exists x0. simpl. right. auto.
Qed.

(** * Final code preservation theorem  *)
Lemma flatten_ok:
  forall id entry cont blkc rtlc pc blk,
    flatten (id, blkc, entry, cont) = OK (id, rtlc, entry, cont) ->
    blkc # pc = Some blk ->
    unf_block rtlc blk pc.
Proof.
  intros id entry cont blkc rtlc pc blk H H0. unfold flatten in H. repeat do_ok.
  rewrite PTree.fold_spec in HDO. destruct p as [blkc' next]. inv H2.
  apply flatten_fold_ok in HDO as H'. destruct H' as [FRESH [LT [INCL BLK]]].
  - apply BLK. apply PTree.elements_correct. auto.
  - apply PTree.elements_keys_norepet.
  - unfold fresh. intros. rewrite PTree.gempty. auto.
  - intros. unfold fresh_label, max_label.
    apply in_map in H. destruct H as [y IN].
    apply PTree.elements_complete in IN.
    apply max_pos_correct in IN.
    eapply Pos.le_lt_trans; eauto. apply Pos.lt_succ_diag_r.
  - intros x H. rewrite PTree.gempty. auto.
Qed.

(** * Simulation Invariant, order, index  *)

Definition match_states_is_refl (s:synchro_state) : Prop :=
  match s with
  | Halt_RTL _ _ | Halt_Block _ => False
  | _ => True
  end.

(* The index holds the current entry  *)
(* This can be the entry point of a continuation, so it changes along the simulation *)
(* We also include a boolean for the stuttering step of the Cblock *)

Inductive stutter : Type :=
| ONE: stutter
| ZERO: stutter.
Definition index : Type := (positive * stutter).

Inductive order: index -> index -> Prop :=
| stut: forall i,
    order (i, ZERO) (i, ONE).

Lemma order_wf:
  well_founded order.
Proof.
  unfold well_founded. intros a. constructor. intros y H. inv H. constructor. intros y H. inv H.
Qed.

Inductive match_states (p:program) (rtlc:RTL.code): index -> mixed_sem.mixed_state -> mixed_sem.mixed_state -> Prop :=
| ms_refl s m entry: match_states_is_refl s -> match_states p rtlc (entry,ONE) (s, m) (s,m)
| ms_block f stk pc mrtl ge m lbi exb rs next entry
    (GE: ge = Globalenvs.Genv.globalenv (make_prog rtlc entry))
    (FUN: f = make_fun rtlc entry)
    (UNF: unf_list rtlc lbi pc next)
    (EXIT: rtlc # next = Some (basic_transf_exit_instr exb)):
  match_states p rtlc (entry, ONE) (Halt_Block (BState (Bblock (lbi, exb)) rs), m)
                                   (Halt_RTL ge (State nil f (Vptr stk Ptrofs.zero) pc rs mrtl), m)
| ms_cblock f stk pc mrtl ge m rs next entry deoptbb cond args iftrue
    (GE: ge = Globalenvs.Genv.globalenv (make_prog rtlc entry))
    (FUN: f = make_fun rtlc entry)
    (COND: rtlc # pc = Some (Icond cond args next iftrue))
    (UNF: unf_bb rtlc deoptbb next):
    match_states p rtlc (entry, ZERO) (Halt_Block (BState (Cblock cond args iftrue deoptbb) rs), m)
                                      (Halt_RTL ge (State nil f (Vptr stk Ptrofs.zero) pc rs mrtl), m)
| ms_bpf f stk pc mrtl ge m rs entry
  (GE: ge = Globalenvs.Genv.globalenv (make_prog rtlc entry))
  (FUN: f = make_fun rtlc entry):
  match_states p rtlc (entry, ONE)  (Halt_Block (BPF pc rs), m)
                                    (Halt_RTL ge (State nil f (Vptr stk Ptrofs.zero) pc rs mrtl), m)
| ms_final r mrtl ge m entry
  (GE: ge = Globalenvs.Genv.globalenv (make_prog rtlc entry)):
  match_states p rtlc (entry, ONE) (Halt_Block (BFinal r), m)
                                   (Halt_RTL ge (Returnstate nil (Vint r) mrtl), m).

Require Import mixed_sem.

Lemma simul_one_step_is_sufficient :
  forall L,
  forall Order:Prop,
  forall match_states: state L -> state L -> Prop,
  forall s t s0,
    (exists s', (Step L s t s' /\ match_states s0 s')) ->
    exists s',
      (SPlus L s t s' \/ (Star L s t s' /\ Order)) /\ match_states s0 s'.
Proof.
  intros L Order ms s t s0 (s', (T1, T2)).
  exists s'; split; auto.
  left.
  constructor 1 with t s' nil; simpl; eauto.
  - constructor 1.
  - unfold Events.Eapp.
    rewrite app_nil_r.
    reflexivity.
Qed.

Ltac inv_not_true:=
  match goal with
  | [H: ~ True |- _] => exfalso; apply H; auto
  end.

(** * Axiomatization of existing initial states for the functions we generate *)
(* There exists an initial memory where the globals (the JIT primitive and the main function) have been *)
(* installed. In practice, this is not in the memory handled by CompCert, but CompCert has no view of *)
(* the external memory *)
Axiom external_in_memory:
  forall rtlc entry,
  exists initm,
    Genv.alloc_globals (Genv.globalenv (make_prog rtlc entry)) Memory.Mem.empty
                       (AST.prog_defs (make_prog rtlc entry)) = Some initm.

Lemma initial_rtl_exists:
  forall rtlc entry,
    exists r, RTL.initial_state (backend.make_prog rtlc entry) r.
Proof.
  intros rtlc entry.
  specialize (external_in_memory rtlc entry) as [initm INITMEM].
  econstructor. eapply initial_state_intro with (b:=backend.main_id) (m0:=initm); unfold backend.make_prog; simpl.
  - unfold Globalenvs.Genv.init_mem. auto.
  - unfold Globalenvs.Genv.find_symbol. simpl. eauto.
  - unfold Globalenvs.Genv.find_funct_ptr. simpl. eauto.
  - simpl. auto.
Qed.

Lemma block_eval_condition_exists_eval_condition mrtl c args b:
  block_eval_condition c args = Some b ->
  Op.eval_condition c args mrtl = Some b.
Proof.
  unfold block_eval_condition.
  destruct c; try congruence;
    repeat (destruct args; try congruence);
    simpl; auto.
Qed.

(** *  Globalenv lemmas *)
Lemma find_ex_prim:
  forall rtlc entry prim rs,
    find_function (Globalenvs.Genv.globalenv (make_prog rtlc entry)) (inr (primitives.EF_ident prim)) rs
    = Some (AST.External (AST.EF_runtime (primitives.EF_name prim) (primitives.EF_sig prim))).
Proof.
  intros rtlc entry prim rs.
  unfold make_prog, Globalenvs.Genv.globalenv. simpl.
  unfold Genv.find_symbol. unfold Genv.genv_symb, Genv.find_funct_ptr. simpl.
  destruct prim; simpl; eauto.
Qed.

Lemma find_main:
  forall rtlc entry b f,
    Genv.find_symbol (Genv.globalenv (make_prog rtlc entry)) main_id = Some b ->
    Genv.find_funct_ptr (Genv.globalenv (make_prog rtlc entry)) b = Some f ->
    f = AST.Internal (make_fun rtlc entry).
Proof.
  unfold make_prog. intros rtlc entry b f H H0.
  unfold Genv.find_symbol, Genv.genv_symb, Genv.globalenv in H.
  simpl in H. inv H.
  unfold Genv.find_funct_ptr, Genv.find_def, Genv.globalenv in H0. simpl in H0. inv H0. auto.
Qed.

(* Freeing of size 0 *)
Lemma free_0:
  forall m stk, exists m',
    Memory.Mem.free m stk 0 0 = Some m'.
Proof.
  intros m stk. Transparent Memory.Mem.free. unfold Memory.Mem.free.
  destruct (Memory.Mem.range_perm_dec m stk 0 0 Memtype.Cur Memtype.Freeable) eqn:FREE.
  - unfold Memory.Mem.unchecked_free. destruct m. simpl.  eauto.
  - unfold Memory.Mem.range_perm in n. exfalso. apply n. intros ofs H. inv H. omega.
    Opaque Memory.Mem.free.
Qed.

(** * Forward Simulation  *)
Theorem flatten_forward:
  forall (p:program) (nc:asm_codes) (rtlb:RTLblockfun) (rtl:RTLfun)
    (NO_CONFLICT: ~ rtl_conflict (Some (inr rtlb)) nc) (* nc doesn't contain a function fid *)
    (FLATTEN: flatten rtlb = OK rtl),
    forward_internal_simulation p p (Some (inr rtlb)) (Some (inl rtl)) nc nc.
Proof.
  intros p nc rtlb rtl; intros.
  destruct rtl as [[[rtlfid rtlc] rtlentry] rtlcont].
  destruct rtlb as [[[fid blockc] entry] cont].
  assert (rtlfid = fid). { apply same_id in FLATTEN. inv FLATTEN. auto. } subst rtlfid.
  apply same_cont_idx in FLATTEN as SAME. subst rtlcont.
  apply same_entry in FLATTEN as SAME. subst rtlentry.

  eapply Forward_internal_simulation with (fsim_match_states:=match_states p rtlc) (fsim_order := order).
  - apply order_wf.
  - unfold call_refl, p_reflexive. intros s H.
    exists (entry, ONE). destruct s. eapply ms_refl. inv H. constructor.
  - intros p0 s1 s2 r Hm Hf1.
    inv Hm; auto; inv Hf1.
  -
{ intros s1 t s1' STEP i s2 MATCH. inv MATCH.
  - destruct s1' as (s', m').
      assert (M:match_states_is_refl s' \/ ~ match_states_is_refl s').
      { destruct s'; simpl; intuition. }
      destruct M.
    + exists (xH, ONE). apply simul_one_step_is_sufficient. exists (s', m').
        split; [idtac | econstructor 1; eauto].
        inv STEP; try (elim H; fail); try (elim H0; fail); econstructor; eauto.
    + inv STEP; try solve[inv H]; simpl in H0; try inv_not_true; try inv RTL.
        (* interpreter can't produce RTL states *)
        { unfold IRinterpreter.ir_step in STEP0. rewrite exec_bind2 in STEP0. simpl in STEP0.
          repeat sdo_ok. destruct p0. destruct i; simpl in H0; try inv_not_true.
          destruct c; simpl in H0; try inv_not_true. }
        (* ASM can't produce RTL states *)
        { unfold ASMinterpreter.asm_int_step in STEP0. rewrite exec_bind2 in STEP0. simpl in STEP0.
          repeat sdo_ok. destruct p0. destruct i; simpl in STEP0; repeat sdo_ok; simpl in H0; try inv_not_true.
          destruct c; simpl in H0; try inv_not_true. }
      * inv RTL_BLOCK.  (* calling RTLBLOCK *)
        exists (entry1, ONE).
        specialize (initial_rtl_exists rtlc entry1) as [inits INIT].
        { inv INIT.
          apply find_main in H3 as MAIN; auto. subst f.
          destruct (Memory.Mem.alloc m0 0 0) as [m0' stk] eqn:E.
          (* Going into the entry program *)
          econstructor; esplit.
          - left. simpl. eapply plus_two.
            + eapply Call_RTL; eauto. econstructor; eauto.
            + eapply rtl_step; eauto.
              * intro T; inv T.
              * eapply exec_function_internal; eauto.
            + reflexivity.
          - simpl. constructor; auto. }
      * inv RTL_BLOCK. (* returning to RTLBLOCK *)
        specialize (initial_rtl_exists rtlc cont_entry) as [inits INIT].
        { inv INIT.
          apply find_main in H3 as MAIN; auto. subst f.
          destruct (Memory.Mem.alloc m0 0 0) as [m0' stk] eqn:E .
          exists (cont_entry, ONE).      (* going into continuation *)
          econstructor; esplit.
          - left. simpl. eapply plus_two.
            + eapply Return_RTL; eauto. econstructor; eauto.
               + eapply rtl_step; eauto.
                 * intro T; inv T.
                 * eapply exec_function_internal; eauto.
               + reflexivity.
          - simpl. constructor; auto. }

  - inv STEP.                   (* ms_block *)
    destruct lbi.
    + inv UNF.                  (* exit instruction *)
      simpl in BLOCK. exists (entry0, ONE). destruct exb.
      * inv BLOCK. econstructor. split. (* nop *)
        ** left. apply plus_one. econstructor.
           { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in EXIT. inv EXIT. }
           eapply exec_Inop. simpl. eauto.
        ** constructor; auto.
      * repeat sdo_ok. econstructor. split. (* cond *)
        ** left. apply plus_one. econstructor.
           { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in EXIT. inv EXIT. }
           eapply exec_Icond; eauto. apply eval_condition_correct. eauto.
        ** constructor; auto.
      * assert (HMEM: exists m',  Memory.Mem.free mrtl stk 0 0 = Some m') by apply free_0.
        destruct HMEM as [m' HMEM]. repeat sdo_ok.
        unfold get_int_reg in HDO0. destruct (rs !! r) eqn:GET; inv HDO0.
        repeat sdo_ok. econstructor. split. (* return *)
        ** left. apply plus_one. econstructor.
           { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in EXIT. inv EXIT. }
           eapply exec_Ireturn; eauto.
        ** unfold Registers.regmap_optget. rewrite GET. constructor. auto.

    + inv UNF.                  (* peeling off one instruction of the block *)
      simpl in BLOCK. repeat sdo_ok. destruct b; simpl in FIRST; simpl in HDO.
      * repeat sdo_ok. eapply eval_operation_correct in HDO. (* Op *)
        exists (entry0, ONE). econstructor. split.
        ** left. apply plus_one. simpl. econstructor.
           { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in FIRST. inv FIRST. }
           eapply exec_Iop; eauto.
        ** simpl. eapply ms_block; eauto.
      * assert (A: find_function (Globalenvs.Genv.globalenv (make_prog rtlc entry0)) (inr (primitives.EF_ident e)) rs = Some (AST.External (AST.EF_runtime (primitives.EF_name e) (primitives.EF_sig e))) ).
        { apply find_ex_prim. }
        repeat sdo_ok. destruct p1. exists (entry0, ONE). econstructor. split. (* prim call *)
        ** left. eapply plus_three.
           *** eapply rtl_step.
               { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in FIRST. inv FIRST. }
               eapply exec_Icall; eauto.
           *** eapply RTL_prim. eapply HDO0.
           *** eapply rtl_step.
               { intros H. inv H. }
               eapply exec_return.
           *** simpl. rewrite Events.E0_right. auto.
        ** simpl. eapply ms_block; eauto.

  - exists (entry0, ONE). inv UNF. inv STEP. (* ms_cblock *)
    simpl in BLOCK. repeat sdo_ok.
    eapply eval_condition_correct in HDO0; eauto.
    destruct b.
    + inv BLOCK. econstructor. split.
      * left. apply plus_one. eapply rtl_step.
        { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in COND. inv COND. }
        eapply exec_Icond; eauto.
      * eapply ms_block; eauto.
    + inv BLOCK. econstructor. split.
      * left. apply plus_one. eapply rtl_step.
        { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in COND. inv COND. }
        eapply exec_Icond; eauto.
      * eapply ms_bpf; eauto.

  - inv STEP.                   (* ms_bpf *)
    simpl in BLOCK. repeat sdo_ok.
    eapply flatten_ok in FLATTEN as H; eauto. inv H.
    + exists (entry0, ONE). econstructor. split.      (* going into Bblock *)
      * left. apply plus_one. apply rtl_step.
        { intros H. inv H. simpl in BUILTIN. rewrite BUILTIN in NOP. inv NOP. }
        eapply exec_Inop; eauto.
      * destruct bb. inv BB. eapply ms_block; eauto.
    + exists (entry0, ZERO). inv BB. econstructor. split.      (* going into Cblock *)
      * right. split. 2: { apply stut. } eapply star_refl. (* stuttering *)
      * eapply ms_cblock; eauto. econstructor; eauto.

  - inv STEP.                   (* ms_final *)
    { simpl in BLOCK. inv BLOCK. }
    exists (entry0, ONE). econstructor. split.
    + left. eapply plus_one.
      eapply RTL_end; eauto. constructor.
    + apply ms_refl. destruct cp; simpl; auto. }
Qed.

Theorem flatten_correct:
  forall (p:program) (nc:asm_codes) (rtlb:RTLblockfun) (rtl:RTLfun)
    (NO_CONFLICT: ~ rtl_conflict (Some (inr rtlb)) nc)
    (FLATTEN: flatten rtlb = OK rtl),
    backward_internal_simulation p p (Some (inr rtlb)) (Some (inl rtl)) nc nc.
Proof.
  intros p nc rtlb rtl NO_CONFLICT FLATTEN.
  apply forward_to_backward_simulation.
  - apply flatten_forward; auto.
  - apply mixed_receptive.
  - apply mixed_determinate. unfold not. intros H.
    apply NO_CONFLICT. inv H. apply same_id in FLATTEN. destruct rtlb as [[[fid' blk] ent] cont].
    simpl in FLATTEN. inv FLATTEN. eapply conflict; eauto.
Qed.

(** * We show here that we only produce a subset of RTL *)
Require Import primitives.
Require Import Errors.

Inductive rtl_instr_wf : RTL.instruction -> Prop :=
(* no load, no store, no builtin, no jumptable *)
| inop_wf: forall n, rtl_instr_wf (Inop n)
| iop_wf: forall o l r n, rtl_instr_wf (Iop o l r n)
| icond_wf: forall o l n1 n2, rtl_instr_wf (Icond o l n1 n2)
(* calls are limited to primitives *)
| icall_wf: forall (ef:ext_primitive) l r n,
    rtl_instr_wf (Icall (EF_sig ef) (inr (EF_ident ef)) l r n)
| ireturn_wf: forall r, rtl_instr_wf (Ireturn (Some r)).

Definition rtl_code_wf (c:RTL.code): Prop :=
  forall pc i, c#pc = Some i -> rtl_instr_wf i.

Lemma fold_ok:
  forall l cf1 c2 n,
    fold_left (fun a p => transf_block a (fst p) (snd p)) l cf1 = OK (c2, n) ->
    exists cf, cf1 = OK (cf).
Proof.
  intros l. induction l; intros.
  - simpl in H. inv H. eauto.
  - simpl in H. apply IHl in H. destruct H as [cf OK].
    destruct cf1; eauto.
    unfold transf_block in OK. destruct a as [na [b1 | b2]];  inv OK.
Qed.

Lemma transf_basic_ok:
  forall b c1 f1 c2 f2,
    transf_basic_block (OK (c1, f1)) b = OK (c2, f2) ->
    rtl_code_wf c1 ->
    rtl_code_wf c2.
Proof.
  intros [l e]. induction l; intros.
  - simpl in H. inv H. unfold rtl_code_wf in *. unfold basic_transf_exit_instr. destruct e; intros.
    + poseq_destr pc f1.
      * rewrite PTree.gss in H. inv H. constructor.
      * rewrite PTree.gso in H; auto. apply H0 in H. auto.
    + poseq_destr pc f1.
      * rewrite PTree.gss in H. inv H. constructor.
      * rewrite PTree.gso in H; auto. apply H0 in H. auto.
    + poseq_destr pc f1.
      * rewrite PTree.gss in H. inv H. constructor.
      * rewrite PTree.gso in H; auto. apply H0 in H. auto.
  - simpl in H. eapply IHl in H; eauto. unfold rtl_code_wf in *. destruct a; intros.
    + poseq_destr pc f1.
      * rewrite PTree.gss in H1. inv H1. constructor.
      * rewrite PTree.gso in H1; auto. apply H0 in H1. auto.
    + poseq_destr pc f1.
      * rewrite PTree.gss in H1. inv H1. constructor.
      * rewrite PTree.gso in H1; auto. apply H0 in H1. auto.
Qed.

Lemma transf_block_ok:
  forall c1 f1 l b c2 f2,
    transf_block (OK (c1, f1)) l b = OK (c2, f2) ->
    rtl_code_wf c1 ->
    rtl_code_wf c2.
Proof.
  intros c1 f1 l b c2 f2 H H0. unfold transf_block in H.
  destruct b.
  + repeat do_ok. inv HDO. apply transf_basic_ok in H2; auto. unfold rtl_code_wf in *. intros.
    poseq_destr pc l.
    * rewrite PTree.gss in H. inv H. constructor.
    * rewrite PTree.gso in H; auto. apply H0 in H. auto.
  + repeat do_ok. inv HDO. apply transf_basic_ok in H2; auto.  unfold rtl_code_wf in *. intros.
    poseq_destr pc l.
    * rewrite PTree.gss in H. inv H. constructor.
    * rewrite PTree.gso in H; auto. apply H0 in H. auto.
Qed.

Theorem flatten_wf:
  forall rtlb fid rtlc entry cont,
    flatten rtlb = OK (fid, rtlc, entry, cont) ->
    rtl_code_wf rtlc.
Proof.
  assert (forall l fresh c1 c2 n, rtl_code_wf c1 -> fold_left (fun a p => transf_block a (fst p) (snd p)) l (OK (c1, fresh)) = OK (c2, n) -> rtl_code_wf c2).
  { intros l.
    induction l; intros; simpl in H0. { inv H0. auto. }
    apply fold_ok in H0 as OKinit. destruct OKinit as [[c f] OK]. rewrite OK in H0.
    apply IHl in H0; auto.
    destruct a as [label blk]. simpl in OK. apply transf_block_ok in OK; auto. }
  intros [[[f blkc] ent] co] fid rtlc entry cont H1.
  unfold flatten in H1. do_ok. destruct p as [rtlc' n]. inv H2.
  rewrite PTree.fold_spec in HDO. apply H in HDO; auto.
  unfold rtl_code_wf. intros pc i H0. rewrite PTree.gempty in H0. inv H0.
Qed.


Require Import Rel.Definitions.
Require Import Lang.BindingsFacts.
Require Import Lang.Static.
Require Import Lang.StaticFacts.
Require Import Lang.Sig.
Require Import Lang.SigFacts.
Require Import Wf_natnat.
Require Import Compat_sub.
Require Import Compat_map_EV.
Require Import Compat_map_LV.
Set Implicit Arguments.

Implicit Types EV LV V L : Set.

Section section_LV_bind_aux.

Hint Extern 0 => match goal with
| [ |- ?n ⊨ ?X ⇔ ?X ] => apply auto_contr_id
| [ |- ?n ⊨ ?X ≈ᵢ ?X ] => repeat iintro ; apply auto_contr_id
| [ |- Acc lt' (_, _) ] => try lt'_solve
| [ H : _ ⊨ (False)ᵢ |- _ ] => icontradict H
end.

Fixpoint
  LV_bind_𝓾_aux
  (n : nat)
  (EV LV LV' : Set)
  (Ξ : XEnv EV LV)
  (f : LV → lbl LV' ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α))
  (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α))
  (Hρ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
        𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
        𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
  )
  (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α))
  ξ₁ ξ₂ (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (ε : ef ∅ EV LV ∅)
  (W : Acc lt' (n, 0))
  {struct W} :
  (n ⊨
    𝓾⟦ Ξ ⊢ ε ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓾⟦ (LV_bind_XEnv f Ξ) ⊢ LV_bind_ef f ε ⟧
      δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)

with
  LV_bind_𝓤_aux
  (n : nat)
  (EV LV LV' : Set)
  (Ξ : XEnv EV LV)
  (f : LV → lbl LV' ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α))
  (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α))
  (Hρ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
        𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
        𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
  )
  (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α))
  ξ₁ ξ₂ (t₁ t₂ : tm0) (ψ : IRel 𝓣_Sig) l₁ l₂ (E : eff ∅ EV LV ∅)
  (W : Acc lt' (n, size_eff E))
  {struct W} :
  (n ⊨
    𝓤⟦ Ξ ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂ ⇔
    𝓤⟦ (LV_bind_XEnv f Ξ) ⊢ LV_bind_eff f E ⟧
      δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ l₁ l₂)

with
  LV_bind_𝓥_aux
  (n : nat)
  (EV LV LV' : Set)
  (Ξ : XEnv EV LV)
  (f : LV → lbl LV' ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α))
  (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α))
  (Hρ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
        𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
        𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
  )
  (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α))
  ξ₁ ξ₂ (v₁ v₂ : val0) (T : ty ∅ EV LV ∅)
  (W : Acc lt' (n, size_ty T))
  {struct W} :
  (n ⊨
    𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
    𝓥⟦ (LV_bind_XEnv f Ξ) ⊢ LV_bind_ty f T ⟧
      δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂)

with
  LV_bind_𝓜_aux
  (n : nat)
  (EV LV LV' : Set)
  (Ξ : XEnv EV LV)
  (f : LV → lbl LV' ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α))
  (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α))
  (Hρ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
        𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
        𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
  )
  (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α))
  ξ₁ ξ₂ (m₁ m₂ : md0) (σ : ms ∅ EV LV ∅) ℓ
  (W : Acc lt' (n, size_ms σ))
  {struct W} :
  (n ⊨
    𝓜⟦ Ξ ⊢ σ ^ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂ ⇔
    𝓜⟦ (LV_bind_XEnv f Ξ) ⊢ (LV_bind_ms f σ) ^ (LV_bind_lbl f ℓ) ⟧
      δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ m₁ m₂)

with
  LV_bind_𝓣𝓵_aux
  (n : nat)
  (EV LV LV' : Set)
  (Ξ : XEnv EV LV)
  (f : LV → lbl LV' ∅)
  (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig)
  (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig)
  (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig)
  (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α))
  (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α))
  (Hρ :
    n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
        𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
        𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
  )
  (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α))
  ξ₁ ξ₂ (t₁ t₂ : tm0) (ℓ : lbl LV ∅)
  (W : Acc lt' (n, size_lbl Ξ ℓ))
  {struct W} :
  (n ⊨
    𝓣𝓵⟦ Ξ ⊢ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
    𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ LV_bind_lbl f ℓ ⟧
      δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂)
.

Proof.

{
destruct ε as [ | α | [ α | [ α | X ] ] ] ; simpl.
+ auto.
+ auto_contr.
+ auto_contr.
  - clear - Hρ₁ Hρ₂ ; crush.
  - destruct (f α) as [ α' | [ α' | X' ] ] eqn : Heq ; [ reflexivity | reflexivity | ].
    split ; [ intro | trivial ].
    clear - Wf_f Heq.
    rewrite LV_bind_XEnv_dom.
    specialize (Wf_f α) ; rewrite Heq in Wf_f.
    inversion Wf_f ; subst.
    erewrite <- LV_bind_XEnv_dom ; eassumption.
  - apply 𝓗_Fun_nonexpansive ; repeat iintro.
    * auto_contr.
    * iespecialize Hρ ; apply Hρ.
+ contradict α.
+ rewrite LV_bind_XEnv_dom.
  auto_contr.
  apply 𝓗_Fun_nonexpansive ; repeat iintro.
  - auto_contr.
  - destruct (get X Ξ) as [ [T E] | ] eqn:HX.
    * eapply binds_LV_bind in HX ; rewrite HX.
      apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
      { apply 𝓥_roll_unroll_iff ; auto. }
      { apply 𝓤_roll_unroll_iff ; auto. }
    * apply get_none_inv in HX.
      erewrite <- LV_bind_XEnv_dom in HX.
      apply get_none in HX.
      rewrite HX ; auto_contr.
}

{
destruct E as [ | ε E ] ; simpl ; auto_contr.
+ apply LV_bind_𝓾_aux ; auto.
+ apply LV_bind_𝓤_aux ; auto.
}

{
destruct T as [ | Ta Ea Tb Eb | N ℓ | σ ℓ ] eqn:HT ; simpl 𝓥_Fun.
+ auto_contr.
+ auto_contr.
  apply 𝓚_Fun_nonexpansive ; repeat iintro ;
  apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
+ auto_contr.
  - repeat erewrite LV_bind_bind_lbl ; try reflexivity ; crush.
  - apply 𝓥_roll_unroll_iff.
    match goal with
    | [ |- ?n ⊨ 𝓥⟦ _ ⊢ ?T ⟧ _ _ _ _ _ _ _ _ _ _ ⇔
                𝓥⟦ _ ⊢ ?T' ⟧ _ _ _ _ _ _ _ _ _ _ ] =>
      replace T' with (LV_bind_ty f T)
      by (simpl ; erewrite LV_bind_it_msig ; crush)
    end.
    apply LV_bind_𝓥_aux ; auto.
+ auto_contr.
  - repeat erewrite LV_bind_bind_lbl ; try reflexivity ; crush.
  - apply LV_bind_𝓜_aux ; auto.
}

{
destruct σ as [ τ | τ | τ | Ta Ea ] eqn:Hσ ; simpl 𝓜_Fun.
+ auto_contr.
  rewrite LV_bind_EV_map_XEnv.
  apply LV_bind_𝓜_aux ; [ auto | auto | | | auto ].
  - erewrite <- LV_bind_EV_map_XEnv.
    repeat iintro ; iespecialize Hρ.
    eapply I_iff_transitive ; [
      apply I_iff_symmetric ; apply EV_map_𝓣𝓵 |
      eapply I_iff_transitive ; [ apply Hρ | apply EV_map_𝓣𝓵 ]
    ] ; try reflexivity ; try (repeat iintro ; simpl ; auto_contr).
  - erewrite <- LV_bind_EV_map_XEnv.
    intro ; apply EV_map_wf_lbl ; auto.
+ auto_contr.
  erewrite <- LV_bind_map_XEnv with (f₂ := LV_lift_inc f) ; [ | ].
  erewrite <- LV_bind_map_lbl with (f₂ := LV_lift_inc f) ; [ | ].
  apply LV_bind_𝓜_aux ; [ | | | | auto ].
  - intro α ; destruct α ; simpl ; [ auto | ].
    erewrite LV_bind_map_lbl, LV_map_lbl_id ; eauto.
    intro ; simpl ; erewrite LV_map_lbl_id ; reflexivity.
  - intro α ; destruct α ; simpl ; [ auto | ].
    erewrite LV_bind_map_lbl, LV_map_lbl_id ; eauto.
    intro ; simpl ; erewrite LV_map_lbl_id ; reflexivity.
  - iintro α ; destruct α ; simpl ; repeat iintro ; [ auto_contr | ].
    simpl in Hρ ; iespecialize Hρ.
    erewrite LV_bind_map_XEnv ; try reflexivity.
    eapply I_iff_transitive ; [
      apply Hρ |
      apply LV_map_𝓣𝓵 ; try reflexivity ; try (repeat iintro ; simpl ; auto_contr)
    ].
  - intro α ; destruct α ; simpl ; [ constructor | ].
    erewrite LV_bind_map_XEnv ; try reflexivity.
    apply LV_map_wf_lbl ; auto.
  - reflexivity.
  - reflexivity.
+ auto_contr ; auto.
+ rewrite LV_bind_XEnv_dom.
  auto_contr.
  - repeat match goal with
    | [ |- context[ match ?x with _ => _ end ] ] => destruct x eqn:?
    end ; simpl ; crush.
    match goal with
    | [ H : ?f ?α = _ |- _ ] => specialize (Wf_f α) ; rewrite H in Wf_f ; clear - Wf_f
    end.
    inversion Wf_f.
    rewrite LV_bind_XEnv_dom in *.
    crush.
  - apply 𝓗_Fun_nonexpansive ; repeat iintro.
    * apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; [ auto | ].
      auto_contr.
      { repeat erewrite LV_bind_bind_lbl ; try reflexivity ; crush. }
      {
        destruct ℓ as [ α | [ | X ] ] ; simpl ; [ | auto | crush ].
        destruct (f α) as [ | [ | X' ] ] eqn : Heq ; [ reflexivity | reflexivity | ].
        split ; [ intro | trivial ].
        clear - Wf_f Heq.
        specialize (Wf_f α) ; rewrite Heq in Wf_f.
        inversion Wf_f ; subst.
        erewrite <- LV_bind_XEnv_dom ; eassumption.
      }
      {
        apply 𝓗_Fun_nonexpansive ; repeat iintro.
        - auto_contr.
        - apply LV_bind_𝓣𝓵_aux ; auto.
      }
      { auto. }
    * apply LV_bind_𝓣𝓵_aux ; auto.
}

{
destruct ℓ as [ | [ | X ] ] ; simpl ; [ iespecialize Hρ ; apply Hρ | auto_contr | ].
destruct (get X Ξ) as [ [T E] | ] eqn:HX.
++ simpl in W ; rewrite HX in W.
   eapply binds_LV_bind in HX ; rewrite HX.
   apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro.
   -- apply 𝓥_roll_unroll_iff ; auto.
   -- apply 𝓤_roll_unroll_iff ; auto.
++ apply get_none_inv in HX.
   erewrite <- LV_bind_XEnv_dom in HX.
   apply get_none in HX.
   rewrite HX ; auto_contr.
}

Qed.

End section_LV_bind_aux.

Section section_LV_bind.
Context (n : nat).
Context (EV LV LV' : Set).
Context (Ξ : XEnv EV LV).
Context (f : LV → lbl LV' ∅).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (ρ₁' ρ₂' : LV' → lbl0) (ρ' : LV' → IRel 𝓣_Sig).
Context (Hρ₁ : ∀ α, ρ₁ α = LV_bind_lbl ρ₁' (f α)).
Context (Hρ₂ : ∀ α, ρ₂ α = LV_bind_lbl ρ₂' (f α)).
Context (Hρ :
  n ⊨ ∀ᵢ α ξ₁ ξ₂ v₁ v₂,
      𝓣𝓵⟦ Ξ ⊢ lbl_var α ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
      𝓣𝓵⟦ (LV_bind_XEnv f Ξ) ⊢ f α ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂
).
Context (Wf_f : ∀ α, wf_lbl (LV_bind_XEnv f Ξ) (f α)).

Hint Resolve lt'_wf.

Lemma LV_bind_𝓥 T ξ₁ ξ₂ v₁ v₂ :
n ⊨
  𝓥⟦ Ξ ⊢ T ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ v₁ v₂ ⇔
  𝓥⟦ LV_bind_XEnv f Ξ ⊢ LV_bind_ty f T ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ v₁ v₂.
Proof.
apply LV_bind_𝓥_aux ; auto.
Qed.

Lemma LV_bind_𝓜 σ ℓ ξ₁ ξ₂ m₁ m₂ :
n ⊨
  𝓜⟦ Ξ ⊢ σ ^ ℓ ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ m₁ m₂ ⇔
  𝓜⟦ LV_bind_XEnv f Ξ ⊢ (LV_bind_ms f σ) ^ (LV_bind_lbl f ℓ) ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ m₁ m₂.
Proof.
apply LV_bind_𝓜_aux ; auto.
Qed.

Lemma LV_bind_𝓤 E ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ :
n ⊨
  𝓤⟦ Ξ ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇔
  𝓤⟦ LV_bind_XEnv f Ξ ⊢ LV_bind_eff f E ⟧ δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂.
Proof.
apply LV_bind_𝓤_aux ; auto.
Qed.

Hint Resolve LV_bind_𝓥 LV_bind_𝓤.

Lemma LV_bind_𝓣 T E ξ₁ ξ₂ t₁ t₂ :
n ⊨
  𝓣⟦ Ξ ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ⇔
  𝓣⟦ LV_bind_XEnv f Ξ ⊢ (LV_bind_ty f T) # (LV_bind_eff f E) ⟧
  δ₁ δ₂ δ ρ₁' ρ₂' ρ' ξ₁ ξ₂ t₁ t₂.
Proof.
apply 𝓣_Fun_Fix'_nonexpansive ; repeat iintro ; auto.
Qed.

End section_LV_bind.


(** The implementation of rewriting hint databases
 **)
Require Import ExtLib.Structures.Functor.
Require Import MirrorCore.Lemma.
Require Import MirrorCore.RTac.CoreK.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.RewriteRelations.
Require Import MirrorCore.Polymorphic.
Require Import MirrorCore.Lambda.PolyInst.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.CTypes.CTypeUnify.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Set Suggest Proof Using.

Section setoid.
  Context {tsym : nat -> Set}.
  Let typ := ctyp tsym.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Local Existing Instance Subst_ctx_subst.
  Local Existing Instance SubstOk_ctx_subst.
  Local Existing Instance SubstUpdate_ctx_subst.
  Local Existing Instance SubstUpdateOk_ctx_subst.
  Local Existing Instance Expr_expr.
  Local Existing Instance ExprOk_expr.

  (* TODO(gmalecha): Wrap all of this up in a type class?
   * Why should it be different than Expr?
   *)
  Variable Rbase : Set.
  Variable Rbase_eq : Rbase -> Rbase -> bool.
  Hypothesis Rbase_eq_ok : forall a b, Rbase_eq a b = true -> a = b.

  Local Notation "'R'" := (R typ Rbase).

  Variable RbaseD : Rbase -> forall t : typ, option (typD t -> typD t -> Prop).

  Hypothesis RbaseD_single_type
  : forall r t1 t2 rD1 rD2,
      RbaseD r t1 = Some rD1 ->
      RbaseD r t2 = Some rD2 ->
      t1 = t2.

  Inductive HintRewrite : Type :=
  | PRw_tc : forall {n : nat},
      polymorphic@{Set} typ n (rw_lemma typ func Rbase) ->
      polymorphic@{Set} typ n bool ->
      CoreK.rtacK typ (expr typ func) ->
      HintRewrite.

  (* TODO - change to RewriteDb for consistency? *)
  Definition RewriteHintDb : Type := list HintRewrite.

  (* TODO(mario): this is duplicated in Respectful.v. We should find a long-term home for it *)
  (* TODO(mario): convert this so it uses rw_concl instead of rw_lemma? *)
  (* no-op typeclass, used to construct polymorphic types without constraints *)
  Definition tc_any (n : nat) : polymorphic typ n bool :=
    make_polymorphic (fun _ => true).

  Definition with_typeclasses@{X} {T : Type@{X}} {n}
             (tc : polymorphic@{Set} typ n bool) (pc : polymorphic@{X} typ n T)
  : polymorphic@{X} typ n (option T) :=
    make_polymorphic (fun args =>
                        if inst tc args
                        then Some (inst pc args)
                        else None).

  (* TODO(mario): end duplicated code *)

  Definition rw_lemmaP (rw : rw_lemma typ func Rbase) : Prop :=
    lemmaD (rw_conclD RbaseD) nil nil rw.

  Definition RewriteHintOk (hr : HintRewrite) : Prop :=
    match hr with
    | PRw_tc plem tc tac =>
      polymorphicD@{Set} (fun x => match x return Prop with
                                | None => True
                                | Some x => rw_lemmaP x
                                end) (with_typeclasses tc plem) /\
      rtacK_sound tac
    end.

  Theorem PRw_tc_sound
          {n : nat}
          (plem : polymorphic typ n (rw_lemma typ func Rbase)) tc tac
  : polymorphicD (fun x => match x with
                        | None => True
                        | Some x => rw_lemmaP x
                        end) (with_typeclasses tc plem) ->
    rtacK_sound tac ->
    RewriteHintOk (PRw_tc plem tc tac).
  Proof using.
    clear. simpl. tauto.
  Qed.

  (** Convenience constructors for building lemmas that do not use
   ** polymorphism.
   **)
  Definition Rw (rw : rw_lemma typ func Rbase) :=
    @PRw_tc 0 rw true.

  Theorem Rw_sound
          (rw : rw_lemma typ func Rbase)
          (tac : CoreK.rtacK typ (expr typ func))
  : rw_lemmaP rw ->
      CoreK.rtacK_sound tac ->
      RewriteHintOk (Rw rw tac).
  Proof using.
    clear.
    intros.
    eapply PRw_tc_sound; eauto.
  Qed.

  (** polymorphic proper hint without typeclass constraints *)
  Definition PRw {n : nat} (pc : polymorphic typ n (rw_lemma typ func Rbase)) :=
    PRw_tc (n:=n) pc (tc_any n).

  Theorem PRw_sound
          {n : nat}
          (plem : polymorphic typ n (rw_lemma typ func Rbase))
          (tac : CoreK.rtacK typ (expr typ func))
  : polymorphicD rw_lemmaP plem ->
    CoreK.rtacK_sound tac ->
    RewriteHintOk (PRw plem tac).
  Proof using.
    intros.
    eapply PRw_tc_sound; eauto.
    eapply polymorphicD_make_polymorphic. intros.
    unfold tc_any.
    rewrite inst_make_polymorphic.
    unfold rw_lemmaP, lemmaD.
    apply inst_sound.
    simpl. assumption.
  Qed.

  Local Definition view_update := ctype_unify tsym.

  Local Definition get_lemma su {n : nat}
        (plem : polymorphic typ n (rw_lemma typ func Rbase))
        (tc : polymorphic typ n bool)
        (e : expr typ func)
  : option (rw_lemma typ func Rbase) :=
    match
      get_inst tyVar su (fmap (fun x => x.(concl).(lhs)) plem) e
    with
    | None => None
    | Some args =>
      if (inst tc args)
      then Some (inst plem args)
      else None
    end.

  Fixpoint CompileHints su (hints : RewriteHintDb)
           (e : expr typ func)
           (r : R)
    : list (rw_lemma typ func Rbase * rtacK typ (expr typ func)) :=
    match hints with
    | nil => nil
    | PRw_tc plem tc tac :: hints =>
      match get_lemma su plem tc e with
      | None => CompileHints su hints e r
      | Some lem => (lem, tac) :: CompileHints su hints e r
      end
    end.

  Definition hints_sound
             (hints : expr typ func -> R ->
                      list (rw_lemma typ func Rbase * CoreK.rtacK typ (expr typ func)))
  : Prop :=
    (forall r e,
        Forall (fun lt =>
                  (forall tus tvs t eD,
                      lambda_exprD tus tvs t e = Some eD ->
                      Lemma.lemmaD (rw_conclD RbaseD) nil nil (fst lt)) /\
                  CoreK.rtacK_sound (snd lt)) (hints e r)).

  Definition RewriteHintDbOk (db : RewriteHintDb) : Prop :=
    Forall RewriteHintOk db.

  Theorem CompileHints_sound
  : forall su db,
      RewriteHintDbOk db ->
      hints_sound (CompileHints su db).
  Proof using.
    induction db; intros; simpl.
    { unfold hints_sound. intros. constructor. }
    { inversion H; subst; clear H.
      specialize (IHdb H3). clear H3.
      unfold hints_sound. intros.
      destruct a.
      destruct (get_lemma su p p0) eqn:Hgl; [|eapply IHdb].
      constructor; [|eauto].
      unfold RewriteHintOk in *. destruct H2.
      split; [|eauto].
      intros.
      unfold get_lemma in *.
      Require Import MirrorCore.Util.Forwardy.
      forwardy.
      eapply inst_sound with (v:=y) in H.
      unfold with_typeclasses in H.
      rewrite inst_make_polymorphic in H.
      destruct (inst p0 y); [|congruence].
      inversion H3; clear H3; subst.
      simpl in *. clear H2.
      red in H. tauto. }
  Qed.
End setoid.


Require Import FP.Data.Function.
Require Import FP.Data.String.
Require Import FP.Data.Ascii.
Require Import FP.Data.N.
Require Import FP.Data.NStructures.
Require Import FP.Structures.Show.
Require Import FP.Structures.Monoid.
Require Import FP.Structures.Injection.
Require Import FP.Structures.Comonad.
Require Import FP.Structures.Foldable.
Require Import FP.Structures.Monad.
Require Import FP.Data.PrettyI.

Import MonoidNotation.
Import CharNotation.
Import ComonadNotation.
Import FunctionNotation.

Section Show.
  Section string_show.
    Variable (R:Type) (SR:ShowResult R).

    Definition string_show (s:string) : R :=
         raw_char """"%char
      ** raw_string s
      ** raw_char """"%char.
  End string_show.

  Global Instance string_Show : Show string := { show := string_show }.
End Show.

Section Monoid.
  Global Instance string_Monoid : Monoid string :=
    { monoid_times := String.append
    ; monoid_unit := EmptyString
    }.
End Monoid.

Section Injection.
  Global Instance string_ascii_HasInjection : HasInjection ascii string :=
    { inject c := String c EmptyString }.
End Injection.

Section Foldable.
  Fixpoint string_cofold {w} {W:Comonad w} {B} (f:ascii -> w B -> B) (bW:w B) (t:string) : B :=
    match t with
    | EmptyString => coret bW
    | String a t =>
        let bW := codo bW => string_cofold f bW t
        in f a bW
    end.
  Global Instance string_Foldable : Foldable ascii string :=
    { cofold := @string_cofold }.
End Foldable.

Section Buildable.
  Definition string_mbuild {m} {M:Monad m} (f:forall {C}, (ascii -> C -> C) -> C -> m C) : m string :=
    f String EmptyString.
  Global Instance string_Buildable : Buildable ascii string :=
    { mbuild := @string_mbuild }.
End Buildable.

Instance N_Pretty : Pretty N := { pretty := text_d '.' show }.


(** * Transfer [Context] across an injection *)
Require Import Crypto.Reflection.Named.Syntax.

Section language.
  Context {base_type_code Name1 Name2 : Type}
          (f : Name2 -> Name1)
          (f_inj : forall x y, f x = f y -> x = y)
          {var : base_type_code -> Type}.

  Definition ContextOn (Ctx : Context Name1 var) : Context Name2 var
    := {| ContextT := Ctx;
          lookupb ctx n t := lookupb ctx (f n) t;
          extendb ctx n t v := extendb ctx (f n) v;
          removeb ctx n t := removeb ctx (f n) t;
          empty := empty |}.
End language.


Require Import StlcEqui.CanForm.
Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.LemmasTyping.
Require Import StlcEqui.LemmasProgramContext.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     subst*);
  try discriminate;
  eauto with eval.

Ltac progressH :=
  match goal with
    | [ H: ⟪ _ : _ r∈ empty ⟫ |- _         ] => inversion H
    | [ H: _ ∨ _             |- _         ] => destruct H
    | [ H: True              |- _         ] => clear H
    | [ H: False             |- _         ] => inversion H
    | [                      |- False ∨ _ ] => right
    | [                      |- True ∨ _  ] => left; auto
  end;
  stlcCanForm.

#[export]
Hint Constructors eval : pctx.
#[export]
Hint Constructors eval₀ : pctx.
#[export]
Hint Extern 20 (Value _) => cbn : pctx.
#[export]
Hint Extern 20 (ECtx _) => cbn : pctx.

(* Lemma local_progress {t U} (wt: ⟪ empty ⊢ t : U ⟫) : *)
(*   Value t ∨ *)
(*   ∃ C t₀ t₀', *)
(*     t = pctx_app t₀ C ∧ *)
(*     t₀ -->₀ t₀' ∧ *)
(*     ECtx C. *)
(* Proof. *)
(*   depind wt; *)
(*   repeat *)
(*     (try progressH; cbn in *; destruct_conjs; subst); *)
(*     eauto 20 with pctx; *)
(*     try (exists phole; cbn; eauto 20 with pctx; fail). *)
(* Qed. *)

(* Lemma progress {t U} (wt: ⟪ empty ⊢ t : U ⟫) : *)
(*   Value t ∨ *)
(*   ∃ t', t --> t'. *)
(* Proof. *)
(*   destruct (local_progress wt); destruct_conjs; *)
(*     subst; eauto using eval. *)
(* Qed. *)

Lemma context_replacement {Γ C t t' T}
  (hyp: ∀ Γ' T', ValidEnv Γ' -> ⟪ Γ' e⊢ t : T' ⟫ → ⟪ Γ' e⊢ t' : T' ⟫) :
  ValidEnv Γ ->
    ⟪ Γ e⊢ pctx_app t C : T ⟫ →
    ⟪ Γ e⊢ pctx_app t' C : T ⟫.
Proof.
  intros vΓ wt; depind wt; crushTyping;
    induction C; crush; eauto with typing.
Qed.

Lemma preservation₀ {t t'} (r : t -->₀ t') :
  ∀ {Γ τ}, ValidEnv Γ -> ⟪ Γ e⊢ t : τ ⟫ → ⟪ Γ e⊢ t' : τ ⟫.
Proof.
  induction r;
    eauto using context_replacement;
    crushTyping.
  - refine (typed_terms_are_valid _ _ _ H6).
    eauto with tyvalid.
  - now eapply ValidTy_invert_arr in H4.
  - crushTyping.
    eapply (WtEq _ (tyeq_symm H2)); try assumption.
    now eapply ValidTy_invert_arr in H4.
  - now refine (typed_terms_are_valid _ _ _ H4).
  - now eapply ValidTy_invert_prod in H2.
  - now refine (typed_terms_are_valid _ _ _ H3).
  - now eapply ValidTy_invert_prod in H2.
  - crushTyping.
    now refine (typed_terms_are_valid _ _ _ H6).
    now eapply ValidTy_invert_sum in H1.
  - crushTyping.
    now refine (typed_terms_are_valid _ _ _ H6).
    now eapply ValidTy_invert_sum in H1.
Qed.

Lemma preservation {t t'} (r: t --> t') :
  ∀ {Γ τ}, ValidEnv Γ -> ⟪ Γ e⊢ t : τ ⟫ → ⟪ Γ e⊢ t' : τ ⟫.
Proof.
  induction r.
  eauto using context_replacement, preservation₀.
Qed.

Lemma preservation_star {t t'} (r: t -->* t') :
  ∀ {Γ τ}, ValidEnv Γ -> ⟪ Γ e⊢ t : τ ⟫ → ⟪ Γ e⊢ t' : τ ⟫.
Proof.
  induction r;
  eauto using preservation.
Qed.

Lemma termination_value {t τ} (wt: ⟪ empty e⊢ t : τ ⟫) :
  t⇓ → ∃ t', t -->* t' ∧ Value t'.
Proof.
  destruct 1; crush.
Qed.