Require Import UFO.Lang.Syntax.
Require Import UFO.Lang.Bindings.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Operational.
Require Import UFO.Lang.Xs.
Require Import UFO.Util.Subset.

Set Implicit Arguments.

Implicit Types EP EV LV V L : Set.

Lemma Xs_eff_app EP EV LV L (E E' : eff EP EV LV L) :
Xs_eff (E ++ E') = Xs_eff E \u Xs_eff E'.
Proof.
induction E ; simpl.
+ rewrite union_empty_l ; auto.
+ rewrite IHE, union_assoc ; auto.
Qed.

Section section_Xs_map_and_bind.

Lemma
L_map_lid_Xs
L L' (f : L → L')
(ι : lid L) :
Xs_lid (L_map_lid f ι) = Xs_lid ι.
Proof.
destruct ι ; crush.
Qed.

Hint Rewrite L_map_lid_Xs.

Lemma
L_map_lbl_Xs
LV L L' (f : L → L')
(ℓ : lbl LV L) :
Xs_lbl (L_map_lbl f ℓ) = Xs_lbl ℓ.
Proof.
destruct ℓ ; crush.
Qed.

Hint Rewrite L_map_lbl_Xs.

Lemma
L_map_ef_Xs
EP EV LV L L' (f : L → L')
(e : ef EP EV LV L) :
Xs_ef (L_map_ef f e) = Xs_ef e.
Proof.
destruct e ; crush.
Qed.

Hint Rewrite L_map_ef_Xs.

Lemma
L_map_eff_Xs
EP EV LV L L' (f : L → L')
(E : eff EP EV LV L) :
Xs_eff (L_map_eff f E) = Xs_eff E.
Proof.
induction E ; crush.
Qed.

Hint Rewrite L_map_eff_Xs.

Lemma
L_map_it_Xs
EP EV LV L L' (f : L → L')
κ (N : it EP EV LV L κ) :
Xs_it (L_map_it f N) = Xs_it N.
Proof.
induction N ; crush.
Qed.

Hint Rewrite L_map_it_Xs.

Fixpoint
L_map_ms_Xs
EP EV LV L L' (f : L → L')
(σ : ms EP EV LV L) :
Xs_ms (L_map_ms f σ) = Xs_ms σ
with
L_map_ty_Xs
EP EV LV L L' (f : L → L')
(T : ty EP EV LV L) :
Xs_ty (L_map_ty f T) = Xs_ty T
.
Proof.
+ destruct σ ; crush.
+ destruct T ; crush.
Qed.

Hint Rewrite L_map_ms_Xs.
Hint Rewrite L_map_ty_Xs.

Fixpoint
L_map_md_Xs
EV LV V L L' (f : L → L')
(m : md EV LV V L) :
Xs_md (L_map_md f m) = Xs_md m
with
L_map_ktx_Xs
EV LV V L L' (f : L → L')
(K : ktx EV LV V L) :
Xs_ktx (L_map_ktx f K) = Xs_ktx K
with
L_map_tm_Xs
EV LV V L L' (f : L → L')
(t : tm EV LV V L) :
Xs_tm (L_map_tm f t) = Xs_tm t
with
L_map_val_Xs
EV LV V L L' (f : L → L')
(v : val EV LV V L) :
Xs_val (L_map_val f v) = Xs_val v
.
Proof.
+ destruct m ; crush.
+ destruct K ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite L_map_md_Xs.
Hint Rewrite L_map_ktx_Xs.
Hint Rewrite L_map_tm_Xs.
Hint Rewrite L_map_val_Xs.

Lemma
LV_map_lbl_Xs
LV L LV' (f : LV → LV')
(ℓ : lbl LV L) :
Xs_lbl (LV_map_lbl f ℓ) = Xs_lbl ℓ.
Proof.
destruct ℓ ; crush.
Qed.

Hint Rewrite LV_map_lbl_Xs.

Lemma
LV_map_ef_Xs
EP EV LV L LV' (f : LV → LV')
(e : ef EP EV LV L) :
Xs_ef (LV_map_ef f e) = Xs_ef e.
Proof.
destruct e ; crush.
Qed.

Hint Rewrite LV_map_ef_Xs.

Lemma
LV_map_eff_Xs
EP EV LV L LV' (f : LV → LV')
(E : eff EP EV LV L) :
Xs_eff (LV_map_eff f E) = Xs_eff E.
Proof.
induction E ; crush.
Qed.

Hint Rewrite LV_map_eff_Xs.

Lemma
LV_map_it_Xs
EP EV LV L LV' (f : LV → LV')
κ (N : it EP EV LV L κ) :
Xs_it (LV_map_it f N) = Xs_it N.
Proof.
induction N ; crush.
Qed.

Hint Rewrite LV_map_it_Xs.

Fixpoint
LV_map_ms_Xs
EP EV LV L LV' (f : LV → LV')
(σ : ms EP EV LV L) :
Xs_ms (LV_map_ms f σ) = Xs_ms σ
with
LV_map_ty_Xs
EP EV LV L LV' (f : LV → LV')
(T : ty EP EV LV L) :
Xs_ty (LV_map_ty f T) = Xs_ty T
.
Proof.
+ destruct σ ; crush.
+ destruct T ; crush.
Qed.

Hint Rewrite LV_map_ms_Xs.
Hint Rewrite LV_map_ty_Xs.

Fixpoint
LV_map_md_Xs
EV LV V L LV' (f : LV → LV')
(m : md EV LV V L) :
Xs_md (LV_map_md f m) = Xs_md m
with
LV_map_ktx_Xs
EV LV V L LV' (f : LV → LV')
(K : ktx EV LV V L) :
Xs_ktx (LV_map_ktx f K) = Xs_ktx K
with
LV_map_tm_Xs
EV LV V L LV' (f : LV → LV')
(t : tm EV LV V L) :
Xs_tm (LV_map_tm f t) = Xs_tm t
with
LV_map_val_Xs
EV LV V L LV' (f : LV → LV')
(v : val EV LV V L) :
Xs_val (LV_map_val f v) = Xs_val v
.
Proof.
+ destruct m ; crush.
+ destruct K ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite LV_map_md_Xs.
Hint Rewrite LV_map_ktx_Xs.
Hint Rewrite LV_map_tm_Xs.
Hint Rewrite LV_map_val_Xs.

Lemma
EV_map_ef_Xs
EP EV LV L EV' (f : EV → EV')
(e : ef EP EV LV L) :
Xs_ef (EV_map_ef f e) = Xs_ef e.
Proof.
destruct e ; crush.
Qed.

Hint Rewrite EV_map_ef_Xs.

Lemma
EV_map_eff_Xs
EP EV LV L EV' (f : EV → EV')
(E : eff EP EV LV L) :
Xs_eff (EV_map_eff f E) = Xs_eff E.
Proof.
induction E ; crush.
Qed.

Hint Rewrite EV_map_eff_Xs.

Lemma
EV_map_it_Xs
EP EV LV L EV' (f : EV → EV')
κ (N : it EP EV LV L κ) :
Xs_it (EV_map_it f N) = Xs_it N.
Proof.
induction N ; crush.
Qed.

Hint Rewrite EV_map_it_Xs.

Fixpoint
EV_map_ms_Xs
EP EV LV L EV' (f : EV → EV')
(σ : ms EP EV LV L) :
Xs_ms (EV_map_ms f σ) = Xs_ms σ
with
EV_map_ty_Xs
EP EV LV L EV' (f : EV → EV')
(T : ty EP EV LV L) :
Xs_ty (EV_map_ty f T) = Xs_ty T
.
Proof.
+ destruct σ ; crush.
+ destruct T ; crush.
Qed.

Hint Rewrite EV_map_ms_Xs.
Hint Rewrite EV_map_ty_Xs.

Fixpoint
EV_map_md_Xs
EV LV V L EV' (f : EV → EV')
(m : md EV LV V L) :
Xs_md (EV_map_md f m) = Xs_md m
with
EV_map_ktx_Xs
EV LV V L EV' (f : EV → EV')
(K : ktx EV LV V L) :
Xs_ktx (EV_map_ktx f K) = Xs_ktx K
with
EV_map_tm_Xs
EV LV V L EV' (f : EV → EV')
(t : tm EV LV V L) :
Xs_tm (EV_map_tm f t) = Xs_tm t
with
EV_map_val_Xs
EV LV V L EV' (f : EV → EV')
(v : val EV LV V L) :
Xs_val (EV_map_val f v) = Xs_val v
.
Proof.
+ destruct m ; crush.
+ destruct K ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite EV_map_md_Xs.
Hint Rewrite EV_map_ktx_Xs.
Hint Rewrite EV_map_tm_Xs.
Hint Rewrite EV_map_val_Xs.

Fixpoint
V_map_md_Xs
EV LV V L V' (f : V → V')
(m : md EV LV V L) :
Xs_md (V_map_md f m) = Xs_md m
with
V_map_ktx_Xs
EV LV V L V' (f : V → V')
(K : ktx EV LV V L) :
Xs_ktx (V_map_ktx f K) = Xs_ktx K
with
V_map_tm_Xs
EV LV V L V' (f : V → V')
(t : tm EV LV V L) :
Xs_tm (V_map_tm f t) = Xs_tm t
with
V_map_val_Xs
EV LV V L V' (f : V → V')
(v : val EV LV V L) :
Xs_val (V_map_val f v) = Xs_val v
.
Proof.
+ destruct m ; crush.
+ destruct K ; crush.
+ destruct t ; crush.
+ destruct v ; crush.
Qed.

Hint Rewrite V_map_md_Xs.
Hint Rewrite V_map_ktx_Xs.
Hint Rewrite V_map_tm_Xs.
Hint Rewrite V_map_val_Xs.

Hint Resolve subset_empty_l.
Hint Resolve subset_union_l subset_union_r.
Hint Resolve subset_refl.

Lemma
L_bind_lid_Xs
L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(ι : lid L) :
Xs_lid (L_bind_lid f ι) \c Xs_lid ι \u B.
Proof.
destruct ι ; simpl ; auto.
Qed.

Lemma
L_bind_lbl_Xs
LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(ℓ : lbl LV L) :
Xs_lbl (L_bind_lbl f ℓ) \c Xs_lbl ℓ \u B.
Proof.
destruct ℓ ; simpl.
+ auto.
+ eapply subset_trans ; [ apply L_bind_lid_Xs ; auto | auto ].
Qed.

Lemma
L_bind_ef_Xs
EV LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(e : ef ∅ EV LV L) :
Xs_ef (L_bind_ef f e) \c Xs_ef e \u B.
Proof.
destruct e ; simpl.
+ auto.
+ auto.
+ eapply subset_trans ; [ apply L_bind_lbl_Xs ; auto | auto ].
Qed.

Lemma
L_bind_eff_Xs
EV LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(E : eff ∅ EV LV L) :
Xs_eff (L_bind_eff f E) \c Xs_eff E \u B.
Proof.
induction E ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply L_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Fixpoint
L_bind_it_Xs
EV LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
κ (N : it ∅ EV LV L κ) :
Xs_it (L_bind_it f N) \c Xs_it N \u B.
Proof.
destruct N as [ | N E ] ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply L_bind_it_Xs ; auto | ].
    auto using union_subset.
  - eapply subset_trans ; [ apply L_bind_eff_Xs ; auto | ].
    auto using union_subset.
Qed.

Fixpoint
L_bind_ms_Xs
EV LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(σ : ms ∅ EV LV L) :
Xs_ms (L_bind_ms f σ) \c Xs_ms σ \u B
with
L_bind_ty_Xs
EV LV L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(T : ty ∅ EV LV L) :
Xs_ty (L_bind_ty f T) \c Xs_ty T \u B
.
Proof.
+ destruct σ ; simpl.
  - eapply subset_trans ; [ apply L_bind_ms_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_ms_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply L_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
+ destruct T ; simpl.
  - auto.
  - repeat apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_it_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lbl_Xs with (B := B) ; auto | auto ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
Qed.

Fixpoint
L_bind_md_Xs
EV LV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(m : md EV LV V L) :
Xs_md (L_bind_md f m) \c Xs_md m \u B
with
L_bind_ktx_Xs
EV LV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(K : ktx EV LV V L) :
Xs_ktx (L_bind_ktx f K) \c Xs_ktx K \u B
with
L_bind_val_Xs
EV LV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(v : val EV LV V L) :
Xs_val (L_bind_val f v) \c Xs_val v \u B
with
L_bind_tm_Xs
EV LV V L L'
B (f : L → lid L') (Q : ∀ x, Xs_lid (f x) \c B)
(t : tm EV LV V L) :
Xs_tm (L_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct m ; simpl.
  - eapply subset_trans ; [ apply L_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct K ; simpl.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_val_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply L_bind_ktx_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lid_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - eapply union_subset.
    * eapply subset_trans ; [ apply L_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lid_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply L_bind_val_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply L_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
Qed.

Lemma
LV_bind_lbl_Xs
LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(ℓ : lbl LV L) :
Xs_lbl (LV_bind_lbl f ℓ) \c Xs_lbl ℓ \u B.
Proof.
destruct ℓ ; simpl ; auto.
Qed.

Lemma
LV_bind_ef_Xs
EV LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(e : ef ∅ EV LV L) :
Xs_ef (LV_bind_ef f e) \c Xs_ef e \u B.
Proof.
destruct e ; simpl.
+ auto.
+ auto.
+ eapply subset_trans ; [ apply LV_bind_lbl_Xs ; auto | auto ].
Qed.

Lemma
LV_bind_eff_Xs
EV LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(E : eff ∅ EV LV L) :
Xs_eff (LV_bind_eff f E) \c Xs_eff E \u B.
Proof.
induction E ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply LV_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Fixpoint
LV_bind_it_Xs
EV LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
κ (N : it ∅ EV LV L κ) :
Xs_it (LV_bind_it f N) \c Xs_it N \u B.
Proof.
destruct N as [ | N E ]; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply LV_bind_it_Xs ; auto | ].
    auto using union_subset.
  - eapply subset_trans ; [ apply LV_bind_eff_Xs ; auto | ].
    auto using union_subset.
Qed.

Fixpoint
LV_bind_ms_Xs
EV LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(σ : ms ∅ EV LV L) :
Xs_ms (LV_bind_ms f σ) \c Xs_ms σ \u B
with
LV_bind_ty_Xs
EV LV L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(T : ty ∅ EV LV L) :
Xs_ty (LV_bind_ty f T) \c Xs_ty T \u B
.
Proof.
+ destruct σ ; simpl.
  - eapply subset_trans ; [ apply LV_bind_ms_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_ms_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply LV_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply LV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
+ destruct T ; simpl.
  - auto.
  - repeat apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_it_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
Qed.

Fixpoint
LV_bind_md_Xs
EV LV V L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(m : md EV LV V L) :
Xs_md (LV_bind_md f m) \c Xs_md m \u B
with
LV_bind_ktx_Xs
EV LV V L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(K : ktx EV LV V L) :
Xs_ktx (LV_bind_ktx f K) \c Xs_ktx K \u B
with
LV_bind_val_Xs
EV LV V L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(v : val EV LV V L) :
Xs_val (LV_bind_val f v) \c Xs_val v \u B
with
LV_bind_tm_Xs
EV LV V L LV'
B (f : LV → lbl LV' L) (Q : ∀ x, Xs_lbl (f x) \c B)
(t : tm EV LV V L) :
Xs_tm (LV_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct m ; simpl.
  - eapply subset_trans ; [ apply LV_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct K ; simpl.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_val_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply LV_bind_ktx_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply LV_bind_val_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_lbl_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply LV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
Qed.

Lemma
EV_bind_ef_Xs
EV LV L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
e :
Xs_eff (EV_bind_ef f e) \c Xs_ef e \u B.
Proof.
destruct e ; simpl.
+ auto.
+ auto.
+ apply union_subset ; auto.
Qed.

Lemma
EV_bind_eff_Xs
EV LV L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
E :
Xs_eff (EV_bind_eff f E) \c Xs_eff E \u B.
Proof.
induction E ; simpl.
+ auto.
+ rewrite Xs_eff_app.
  apply union_subset.
  - eapply subset_trans ; [ apply EV_bind_ef_Xs ; auto | ].
    auto using union_subset.
  - rewrite <- union_assoc ; auto.
Qed.

Fixpoint
EV_bind_it_Xs
EV LV L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
κ (N : it ∅ EV LV L κ) :
Xs_it (EV_bind_it f N) \c Xs_it N \u B.
Proof.
destruct N as [ | N E ] ; simpl.
+ auto.
+ apply union_subset.
  - eapply subset_trans ; [ apply EV_bind_it_Xs ; auto | ].
    auto using union_subset.
  - eapply subset_trans ; [ apply EV_bind_eff_Xs ; auto | ].
    auto using union_subset.
Qed.

Fixpoint
EV_bind_ms_Xs
EV LV L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
σ :
Xs_ms (EV_bind_ms f σ) \c Xs_ms σ \u B
with
EV_bind_ty_Xs
EV LV L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
T :
Xs_ty (EV_bind_ty f T) \c Xs_ty T \u B
.
Proof.
+ destruct σ ; simpl.
  - eapply subset_trans ; [ apply EV_bind_ms_Xs with (B := B) | auto ].
    intro α ; destruct α ; simpl.
    * rewrite union_empty_l ; auto.
    * rewrite EV_map_eff_Xs ; auto.
  - eapply subset_trans ; [ apply EV_bind_ms_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply EV_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto using union_assoc.
+ destruct T ; simpl.
  - auto.
  - repeat apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_ty_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_it_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ms_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
Qed.

Fixpoint
EV_bind_md_Xs
EV LV V L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
(m : md EV LV V L) :
Xs_md (EV_bind_md f m) \c Xs_md m \u B
with
EV_bind_ktx_Xs
EV LV V L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
(K : ktx EV LV V L) :
Xs_ktx (EV_bind_ktx f K) \c Xs_ktx K \u B
with
EV_bind_val_Xs
EV LV V L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
(v : val EV LV V L) :
Xs_val (EV_bind_val f v) \c Xs_val v \u B
with
EV_bind_tm_Xs
EV LV V L EV'
B (f : EV → eff ∅ EV' LV L) (Q : ∀ x, Xs_eff (f x) \c B)
(t : tm EV LV V L) :
Xs_tm (EV_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct m ; simpl.
  - eapply subset_trans ; [ apply EV_bind_md_Xs with (B := B) | auto ].
    intro α ; destruct α ; simpl.
    * rewrite union_empty_l ; auto.
    * rewrite EV_map_eff_Xs ; auto.
  - eapply subset_trans ; [ apply EV_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_md_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
+ destruct K ; simpl.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_val_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
+ destruct v ; simpl.
  - auto.
  - auto.
  - eapply subset_trans ; [ apply EV_bind_ktx_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_md_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
+ destruct t ; simpl.
  - eapply subset_trans ; [ apply EV_bind_val_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | auto ].
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_eff_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * auto.
  - apply union_subset.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
    * eapply subset_trans ; [ apply EV_bind_tm_Xs with (B := B) ; auto | ].
      apply union_subset ; auto.
Qed.

Fixpoint
V_bind_md_Xs
EV LV V L V'
B (f : V → val EV LV V' L) (Q : ∀ x, Xs_val (f x) \c B)
m :
Xs_md (V_bind_md f m) \c Xs_md m \u B
with
V_bind_ktx_Xs
EV LV V L V'
B (f : V → val EV LV V' L) (Q : ∀ x, Xs_val (f x) \c B)
K :
Xs_ktx (V_bind_ktx f K) \c Xs_ktx K \u B
with
V_bind_val_Xs
EV LV V L V'
B (f : V → val EV LV V' L) (Q : ∀ x, Xs_val (f x) \c B)
v :
Xs_val (V_bind_val f v) \c Xs_val v \u B
with
V_bind_tm_Xs
EV LV V L V'
B (f : V → val EV LV V' L) (Q : ∀ x, Xs_val (f x) \c B)
t :
Xs_tm (V_bind_tm f t) \c Xs_tm t \u B
.
Proof.
+ destruct m ; simpl ; auto.
+ destruct K ; simpl.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_ktx K)), <- union_assoc ; auto.
+ destruct v ; simpl.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_md m)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans.
      { apply V_bind_md_Xs with (B := B) ; crush. }
      { auto using union_subset, union_assoc. }
    * rewrite (union_comm (Xs_md m)), <- union_assoc ; auto.
+ destruct t ; simpl.
  - auto.
  - auto.
  - auto.
  - auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_tm t)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * eapply subset_trans.
      { apply V_bind_tm_Xs with (B := B) ; crush. }
      { rewrite <- union_assoc ; auto. }
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * eapply subset_trans ; auto using union_subset, union_assoc.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_tm t)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * rewrite (union_comm (Xs_tm t)), <- union_assoc ; auto.
  - apply union_subset.
    * eapply subset_trans ; auto using union_subset, union_assoc.
    * eapply subset_trans ; auto using union_subset, union_assoc.
Qed.

End section_Xs_map_and_bind.

Section section_Xs_ktx_plug.

Hint Rewrite union_empty_l.

Lemma Xs_ktx_plug EV LV V L (K : ktx EV LV V L) t :
Xs_tm (ktx_plug K t) = Xs_ktx K \u Xs_tm t.
Proof.
induction K ; simpl.
+ crush.
+ crush.
+ crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite <- union_assoc, (union_comm (Xs_tm t)).
  rewrite union_assoc.
  crush.
+ rewrite IHK.
  rewrite union_assoc, (union_comm _ (Xs_tm K)).
  crush.
Qed.

End section_Xs_ktx_plug.


Require Import String.
Require Import Ast.
Require Import EvalE.
Require Import List.
Import ListNotations.
From Template Require Ast.
From Template Require Import TemplateMonad.
From Template Require Import monad_utils.

Import MonadNotation.
Import BaseTypes.
Import StdLib.

Definition negb_app_true :=
    [|
     (\x : Bool ->
           case x : Bool return Bool of
           | true -> false
           | false -> true) true
     |].

Print negb_app_true.

Unset Printing Notations.
Print negb_app_true.

Set Printing Notations.

Import InterpreterEnvList.

(* Execute the program using the interpreter *)
Compute (expr_eval_n 3 Σ [] negb_app_true).

Compute (expr_eval_i 3 Σ [] (indexify [] negb_app_true)).

(* Make a Coq function from the AST of the program *)
Make Definition coq_negb_app_true :=
  Eval compute in (expr_to_term Σ (indexify nil negb_app_true)).

Print coq_negb_app_true.

Definition my_negb_syn :=
  [| \x : Bool -> case x : Bool return Bool of
                   | true -> false
                   | false -> true  |].

Make Definition my_negb :=
  Eval compute in (expr_to_term Σ (indexify [] my_negb_syn)).

Lemma my_negb_coq_negb b :
  my_negb b = negb b.
Proof. reflexivity. Qed.

Compute (expr_eval_n 3 Σ [] my_negb_syn).

Make Definition coq_my_negb := Eval compute in (expr_to_term Σ (indexify [] my_negb_syn)).

Import MonadNotation.

Run TemplateProgram
    (
      t <- tmEval lazy (expr_eval_n 3 Σ [] my_negb_syn);;
        match t with
          Ok v =>
          t' <- tmEval lazy (expr_to_term Σ (indexify [] (InterpreterEnvList.from_val v))) ;;
          def <- tmUnquoteTyped (bool -> bool) t' ;;
          tmDefinition "eval_my_negb" def ;;
             print_nf "Done."
        | EvalError msg => print_nf msg
        | NotEnoughFuel => print_nf "Not enough fuel"
        end
    ).

Lemma my_negb_adequate : forall b, coq_my_negb b = eval_my_negb b.
Proof.
  intros [];auto.
Qed.

Definition is_zero_syn :=
  [|

      \x : Nat ->
           case x : Nat return Bool of
           | Z -> true
           | Suc y -> false

  |].

Make Definition is_zero' := Eval compute in (expr_to_term Σ (indexify nil is_zero_syn)).

Definition pred_syn :=
  [|

      \x : Nat ->
           case x : Nat return Nat of
           | Z -> x
           | Suc y -> y

  |].

Make Definition pred' := Eval compute in (expr_to_term Σ (indexify nil pred_syn)).

Definition prog2 := [| Suc (Suc Z) |].

Compute (expr_eval_n 3 Σ [] prog2).

Inductive blah :=
  Bar : blah -> blah -> blah
| Baz : blah.

Definition Σ' : global_env :=
  [gdInd "blah" [("Bar", [tyInd "blah"; tyInd "blah"]); ("Baz", [])];
     gdInd Nat  [("Z", []); ("Suc", [tyInd Nat])]].

Notation "'Bar'" := (eConstr "blah" "Bar") (in custom expr).
Notation "'Baz'" := (eConstr "blah" "Baz") (in custom expr).

Definition prog3 := [| Bar (Bar Baz Baz) Baz |].

Compute (expr_eval_n 5 Σ [] prog3).

(* Examples of a fixpoint *)

Definition factorial_syn :=
  [|
   fix "factorial" (x : Nat) : Nat :=
       case x : Nat return Nat of
       | Z -> 1
       | Suc y -> x * ("factorial" y)
  |].

Make Definition factorial :=
  Eval compute in ((expr_to_term Σ (indexify [] factorial_syn))).

Definition plus_syn : expr :=
  [| fix "plus" (x : Nat) : Nat -> Nat :=
           case x : Nat return Nat -> Nat of
           | Z -> \y : Nat -> y
           | Suc y -> \z : Nat -> Suc ("plus" y z) |].

Make Definition my_plus := Eval compute in (expr_to_term Σ (indexify [] plus_syn)).

Lemma my_plus_correct n m :
  my_plus n m = n + m.
Proof. induction n;simpl;auto. Qed.

Definition two :=
  (vConstr Nat "Suc"
           [vConstr Nat "Suc" [vConstr Nat "Z" []]]).

Definition one_plus_one :=
  [| {plus_syn} 1 1 |].

Compute (expr_eval_n 10 Σ [] [| {plus_syn} 1 1 |]).
(* = Ok (vConstr "nat" "Suc" [vConstr "nat" "Suc" [vConstr "nat" "Z" []]])*)

Definition two_arg_fun_syn := [| \x : Nat -> \y : Bool -> x |].

Make Definition two_arg_fun_app :=
  Eval compute in (expr_to_term Σ (indexify [] [| {two_arg_fun_syn} 1 true |])).

Parameter bbb: bool.

Quote Definition two_arg_fun_app_syn' := ((fun (x : nat) (_ : bool) => x) 1 bbb).

Example one_plus_one_two : expr_eval_n 10 Σ [] one_plus_one = Ok two.
Proof. reflexivity. Qed.

Definition plus_syn' :=
  [| \x : Nat ->
          (fix "plus" (y : Nat) : Nat :=
           case y : Nat return Nat of
           | Z -> x
           | Suc z -> Suc ("plus" z))
  |].

Make Definition my_plus' :=
  Eval compute in ((expr_to_term Σ (indexify [] plus_syn'))).

Lemma my_plus'_0 : forall n, my_plus' 0 n = n.
Proof.
  induction n;simpl;easy.
Qed.

Lemma my_plus'_Sn : forall n m, my_plus' (S n) m = S (my_plus' n m).
Proof.
  induction m;simpl;easy.
Qed.

Lemma my_plus'_comm : forall n m, my_plus' n m = my_plus' m n.
Proof.
  induction n; intros m;simpl.
  + rewrite my_plus'_0. reflexivity.
  + rewrite my_plus'_Sn. easy.
Qed.

(* my_plus corresponds to addition of natural numbers defined in the standard library *)
Lemma my_plus'_correct : forall n m, my_plus' n m = n + m.
Proof.
  intros n m.
  induction m;simpl;easy.
Qed.

Definition id_rec :=
  [| (fix "plus" (y : Nat) : Nat :=
           case y : Nat return Nat of
           | Z -> 0
           | Suc z -> Suc ("plus" z))
   |].

Compute (expr_eval_n 20 Σ [] [| {id_rec} (Suc (Suc (Suc 1))) |]).
Compute (expr_eval_i 20 Σ [] (indexify [] [| {id_rec} (Suc (Suc (Suc 1))) |])).

Example id_rec_named_and_indexed :
  let arg := [| Suc (Suc (Suc 1)) |] in
  expr_eval_n 20 Σ [] [| {id_rec} {arg} |] =
  expr_eval_i 20 Σ [] (indexify [] [| {id_rec} {arg} |]).
Proof. reflexivity. Qed.

Example plus_named_and_indexed :
  let two := [| (Suc 1)|] in
  let three := [| Suc {two} |] in
  expr_eval_n 20 Σ [] [| ({plus_syn} {two}) {three} |] =
  expr_eval_i 20 Σ [] (indexify [] [| ({plus_syn} {two}) {three} |]).
Proof. reflexivity. Qed.

Compute ( v <- (expr_eval_i 10 Σ [] (indexify [] [| {one_plus_one} |]));;
          ret (from_val v)).

Compute (expr_eval_i 10 Σ [] (indexify [] [| {plus_syn} 1 |])).

Compute ( v <- (expr_eval_n 10 Σ [] [| {plus_syn} 1 |]);;
          ret (from_val v)).

Compute (indexify [] [| {plus_syn}|]).

Compute ( v <- (expr_eval_i 10 Σ [] (indexify [] [| {plus_syn} |]));;
          ret (from_val v)).

Compute (expr_eval_n 10 Σ [] [| {plus_syn} 0 |]).

Definition fun_app := [| (\x : Nat -> \y : Nat -> y + x) Z |].

Compute (expr_eval_n 10 [] [] fun_app).

Example fun_app_from_val :
  exists v, (expr_eval_n 10 Σ' [] (indexify [] fun_app)) = Ok v /\
       from_val_i v = (indexify [] [|\y : Nat -> y + Z |]).
Proof.
  eexists. split. compute. reflexivity.
  simpl. compute. reflexivity.
Qed.

Example plus_syn_partial_app :
  exists v, (expr_eval_i 10 Σ [] (indexify [] [| {plus_syn'} 0 |])) = Ok v /\
       from_val_i v = indexify [] id_rec.
Proof.
  eexists. split. compute. reflexivity.
  compute. reflexivity.
Qed.

Inductive mybool :=
| mfalse
| mtrue.

Definition stupid_case (b : mybool) : nat :=
  match b with
  | mtrue => 1
  | mfalse => 0
  end.

Definition stupid_case' (b : mybool * mybool) : nat :=
  match b with
  | (mtrue, _) => 1
  | (mfalse, _) => 0
  end.

Definition is_zero (n : nat) :=
  match n with
  | S n => mfalse
  | O => mtrue
  end.

Quote Definition q_stupid_case := Eval compute in stupid_case.
(* Nested patters are transformed into the nested "case" expressions *)
Quote Definition q_stupid_case' := Eval compute in stupid_case'.

Inductive Bazz :=
  cBazz : nat -> nat -> nat -> Bazz.

Definition Bazz_match b :=
  match b with
    cBazz n m k => n
  end.

Quote Definition q_Bazz_match := Eval compute in Bazz_match.


Add LoadPath "../metatheory".
Require Export PLC_init.

(* Mutual induction principles *)
Scheme pval_mut_ind_aux := Induction for pval Sort Prop
with   val_mut_ind_aux  := Induction for val  Sort Prop.
Combined Scheme pval_val_mut_ind from pval_mut_ind_aux, val_mut_ind_aux.

(* Administrative lemmas *)
Lemma pval_val_regular :
  (forall p, pval p → lc_term p) ∧ (forall v, val v → lc_term v).
Proof.
apply pval_val_mut_ind; eauto.
Qed.

Lemma pval_regular : forall p, pval p → lc_term p.
Proof.
intros; destruct pval_val_regular as [H1 _]; auto.
Qed.

Lemma val_regular : forall v, val v → lc_term v.
Proof.
intros; destruct pval_val_regular as [_ H2]; auto.
Qed.
Hint Resolve pval_regular val_regular.

(* Lemmas about values *)
Lemma value_is_normal_aux :
  (forall v, pval v → ~ exists e, v ⇝ e) ∧
  (forall v, val v → ~ exists e, v ⇝ e).
Proof.
apply pval_val_mut_ind; intros; intros [e0 Hred]; inversion Hred; subst; eauto.
inversion H.
inversion H1; subst. inversion p.
inversion H0.
pick fresh x. eapply H; eauto.
Qed.

Lemma value_is_normal : forall v, val v → ~ exists e, v ⇝ e.
Proof.
destruct value_is_normal_aux as [_ Th]. intuition auto.
Qed.

(* Administrative lemmas *)
Lemma var_subst : forall e x, subst_term e x (term_var_f x) = e.
Proof.
intros e x; simpl; destruct (x == x); congruence.
Qed.
Hint Rewrite var_subst : lngen.

Lemma red0_regular1 : forall e1 e2, red0 e1 e2 → lc_term e1.
Proof.
intros e1 e2 H; destruct H; auto.
Qed.

Lemma red0_regular2 : forall e1 e2, red0 e1 e2 → lc_term e2.
Proof.
intros e1 e2 H; destruct H; auto with lngen.
Qed.
Hint Resolve red0_regular1 red0_regular2.

Lemma red1_regular1 : forall e1 e2, e1 ⇝ e2 → lc_term e1.
Proof.
intros e1 e2 H; induction H; eauto.
Qed.

Lemma red1_regular2 : forall e1 e2, e1 ⇝ e2 → lc_term e2.
Proof.
intros e1 e2 H; induction H; eauto.
Qed.
Hint Resolve red1_regular1 red1_regular2.

Lemma red_star_regular1 : forall e1 e2, e1 ⇝⋆ e2 →
  lc_term e2 → lc_term e1.
Proof.
intros e1 e2 H Hlc; induction H; eauto.
Qed.

Lemma red_star_regular2 : forall e1 e2, e1 ⇝⋆ e2 →
  lc_term e1 → lc_term e2.
Proof.
intros e1 e2 H Hlc; induction H; eauto.
Qed.
Hint Resolve red_star_regular1 red_star_regular2.

Lemma para_red_regular1 : forall e1 e2, e1 ⇒ e2 → lc_term e1.
Proof.
intros e1 e2 H; induction H; eauto.
Qed.

Lemma para_red_regular2 : forall e1 e2, e1 ⇒ e2 → lc_term e2.
Proof.
intros e1 e2 H; induction H; eauto.
Qed.
Hint Resolve para_red_regular1 para_red_regular2.

Lemma can_regular1 : forall e1 e2, e1↓ = e2 → lc_term e1.
Proof.
intros e1 e2 H; induction H; auto.
Qed.

Lemma can_regular2 : forall e1 e2, e1↓ = e2 → lc_term e2.
Proof.
intros e1 e2 H; induction H; auto.
pick fresh x; auto with lngen.
Qed.
Hint Resolve can_regular1 can_regular2.

(* Renaming lemmas *)
Lemma red0_renaming : forall x y e e', red0 e e' →
  red0 (subst_term (term_var_f y) x e) (subst_term (term_var_f y) x e').
Proof.
intros x y e e' H.
inversion H; subst.
simpl. rewrite subst_term_open_term_wrt_term; auto. apply red0_beta; auto with lngen.
assert (lc_term (subst_term (term_var_f y) x (term_abs e1))) by auto with lngen; auto.
Qed.
Hint Resolve red0_renaming.

Lemma red1_renaming : forall x y e e', e ⇝ e' →
  (subst_term (term_var_f y) x e) ⇝ (subst_term (term_var_f y) x e').
Proof.
intros x y e e' H.
induction H; subst; simpl; auto.
apply red1_appL; auto with lngen.
apply red1_appR; auto with lngen.
apply red1_abs with (L := L `union` {{x}}); intros z Hz.
replace (term_var_f z) with (subst_term (term_var_f y) x (term_var_f z)) by auto with lngen.
repeat rewrite <- subst_term_open_term_wrt_term; eauto.
Qed.
Hint Resolve red1_renaming.

Lemma red_star_renaming : forall x y e e', e ⇝⋆ e' →
  (subst_term (term_var_f y) x e) ⇝⋆ (subst_term (term_var_f y) x e').
Proof.
intros x y e e' H.
induction H.
apply rt_step; auto.
apply rt_refl.
eapply rt_trans; eauto.
Qed.
Hint Resolve red_star_renaming.

(* Lemmas about red_star *)
Lemma red_star_context_appL : forall e1 e1' e2,
  lc_term e2 → e1 ⇝⋆ e1' →
  term_app e1 e2 ⇝⋆ term_app e1' e2.
Proof.
intros e1 e1' e2 Hlc Hred.
induction Hred.
apply rt_step; auto.
apply rt_refl.
eapply rt_trans; eauto.
Qed.

Lemma red_star_context_appR : forall e1 e2 e2',
  lc_term e1 → e2 ⇝⋆ e2' →
  term_app e1 e2 ⇝⋆ term_app e1 e2'.
Proof.
intros e1 e2 e2' Hlc Hred.
induction Hred.
apply rt_step; auto.
apply rt_refl.
eapply rt_trans; eauto.
Qed.

Lemma red_star_context_app : forall e1 e1' e2 e2',
  lc_term e1 → lc_term e2 → e1 ⇝⋆ e1' → e2 ⇝⋆ e2' →
  term_app e1 e2 ⇝⋆ term_app e1' e2'.
Proof.
intros e1 e1' e2 e2' Hlc1 Hlc2 Hred1 Hred2.
eapply rt_trans; eauto using red_star_context_appL, red_star_context_appR.
Qed.

Lemma red_star_context_abs : forall L e e',
  (forall x, x `notin` L → e ^ x ⇝⋆ e' ^ x) →
  term_abs e ⇝⋆ term_abs e'.
Proof.
intros L e e' H. pick fresh x.
remember (e ^ x) as e1.
remember (e' ^ x) as e1'.
assert (e1 ⇝⋆ e1') as Hred by solve [subst; apply H; auto]. clear H.
generalize dependent x. generalize dependent e'. generalize dependent e.
induction Hred; intros; subst.
Case "step".
apply rt_step.
apply red1_abs with (L := L `union` fv_term e `union` fv_term e'); intros.
rewrite <- var_subst with (e := term_var_f x) (x := x0).
replace e with (subst_term (term_var_f x) x0 e) by auto with lngen.
replace e' with (subst_term (term_var_f x) x0 e') by auto with lngen.
repeat rewrite <- subst_term_open_term_wrt_term; eauto.
Case "refl".
assert (e = e'). eapply open_term_wrt_term_inj; eauto. subst. apply rt_refl.
Case "trans".
apply rt_trans with (y := term_abs (close_term_wrt_term x0 y)).
apply IHHred1 with (x := x0); autorewrite with lngen; auto.
apply IHHred2 with (x := x0); autorewrite with lngen; auto.
Qed.
Hint Resolve red_star_context_appL red_star_context_appR red_star_context_app red_star_context_abs.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.list_solver.
Require Import x448.
Require Import stdpp.list.
Require Import ZArith.
Require Import compcert.lib.Coqlib.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition t_gf := Tstruct __257 noattr.

(** We will define a separation-logic predicate, [listrep N p],
 to describe the concept that the address [p] in memory is a
 list that represents the number N \in GF(prime) in 16 limbs. *)

Local Open Scope Z.

Definition gf_cpy_spec : ident * funspec :=
    DECLARE _gf_cpy
    WITH
        x: val,
        shx : share,
        contents_x : list val,
        y: val,
        shy : share,
        contents_y : list Z,
        gv : globals
    PRE [ tptr t_gf, tptr t_gf ]
        PROP   (writable_share shx;
                readable_share shy;
                Zlength contents_x = 16;
                Zlength contents_y = 16)
        PARAMS (x ; y) GLOBALS (gv)
        SEP    (field_at shx t_gf (DOT _limb) contents_x x;
                field_at shy t_gf (DOT _limb) (map Vint (map Int.repr contents_y)) y)
    POST [ tvoid ]
        PROP   ()
        RETURN ()
        SEP    (field_at shx t_gf (DOT _limb) (map Vint (map Int.repr contents_y)) x;
                field_at shy t_gf (DOT _limb) (map Vint (map Int.repr contents_y)) y).

(* Compute list.take 2 [1;2;3;4;5] = sublist.sublist 0 0 [1;2;3;4;5].
Compute list.drop 2 [1;2;3;4;5] = sublist.sublist 2 (Zlength [1;2;3;4;5]) [1;2;3;4;5]. *)

Definition gf_cpy_Inv shx shy x y contents_x contents_y :=
    (EX i : Z,
        (PROP   (writable_share shx;
                readable_share shy;
                Zlength contents_x = 16;
                Zlength contents_y = 16;
                i >= 0)
        LOCAL   (temp _x x; temp _y y)
        SEP     (field_at shx t_gf (DOT _limb) (
                    (sublist.sublist 0 i (map Vint (map Int.repr contents_y)))
                    ++ (sublist.sublist i (Zlength contents_x) contents_x)) x;
                field_at shy t_gf (DOT _limb) (map Vint (map Int.repr contents_y)) y)))%assert.

Definition Gprog : funspecs := ltac:(with_library prog [ gf_cpy_spec ]).

(* Lemma L1 (i : Z) (l : list val) :
0 <= i < Zlength l ->
upd_Znth i (take (Z.to_nat i) l) (Znth i l) =  take (Z.to_nat (i + 1)) l.
Proof. Admitted.

Lemma L2 (i : Z) (l1 l2 : list val) :
0 <= i < Zlength l1 ->
0 <= i < Zlength l2 ->
upd_Znth i (take (Z.to_nat i) l1 ++ drop (Z.to_nat i) l2) (Znth i l1)
    =  take (Z.to_nat (i + 1)) l1 ++
       drop (Z.to_nat (i + 1)) l2.
Proof.
    intros.
    rewrite upd_Znth_unfold.
    simpl.
    assert (sublist.sublist 0 i (take (Z.to_nat i) l1 ++ drop (Z.to_nat i) l2) = take (Z.to_nat i) l1).
    admit.
    rewrite H1.
    replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)) by lia.
    apply take_S_r. *)

Lemma L1 (i : Z) (l1 l2 : list val) :
0 <= i < Zlength l1 ->
sublist.sublist 0 i (sublist.sublist 0 i l1 ++ l2) = sublist.sublist 0 i l1.
Proof.
    intros;
    list_solve.
    Qed.

Lemma L1' (i : Z) (l1 l2 : list val) :
0 <= i < Zlength l1 ->
Zlength l1 = Zlength l2 ->
sublist.sublist (i + 1) (Zlength l2) (sublist.sublist 0 i l1 ++
    sublist.sublist i (Zlength l2) l2) = sublist.sublist (i + 1) (Zlength l2) l2.
Proof.
    intros;
    list_solve.
    Qed.

Lemma L2 (i : Z) (l : list Z) :
0 <= i < Zlength l ->
(sublist.sublist 0 i (map Vint (map Int.repr l))) ++
[Vint (Int.repr (Znth i l))] = sublist.sublist 0 (i+1) (map Vint (map Int.repr l)).
Proof.
    intros;
    list_solve.
    Qed.

Lemma L3 (i : Z) (l1 l2 : list val) :
0 <= i < Zlength l1 ->
Zlength l1 = Zlength l2 ->
Zlength (sublist.sublist 0 i l1 ++ sublist.sublist i (Zlength l2) l2) = Zlength l2.
Proof.
    intros.
    rewrite Zlength_app.
    list_simplify.
    Qed.

Lemma body_gf_cpy : semax_body Vprog Gprog f_gf_cpy gf_cpy_spec.
Proof.
    start_function.
    forward.
    forward_for_simple_bound 16 (gf_cpy_Inv shx shy x y contents_x contents_y).
    -   entailer!.
    assert (sublist.sublist 0 0 (map Vint (map Int.repr contents_y)) = [])by list_solve.
    rewrite H5; simpl.
    assert ((sublist.sublist 0 (Zlength contents_x) contents_x) = contents_x) by list_solve.
    rewrite H6.
    cancel.
    - try repeat forward.
        entailer!.
        rewrite upd_Znth_unfold.
        rewrite L1.
        rewrite app_assoc.
        rewrite L2.
        rewrite L3.
        rewrite L1'.
        cancel.
        try repeat rewrite Zlength_map.
        by rewrite H0.
        try repeat rewrite Zlength_map.
        by rewrite H0.
        try repeat rewrite Zlength_map; by rewrite H0.
        try repeat rewrite Zlength_map; by rewrite H0.
        by rewrite H0.
        try repeat rewrite Zlength_map; by rewrite H0.

        About sublist.sublist.

        list_simplify.

    - entailer!.
        rewrite <- H0.
        assert (Zlength contents_y = Zlength (map Vint (map Int.repr contents_y))) by list_simplify.
        rewrite H6 at 1.
        assert (sublist.sublist 0 (Zlength (map Vint (map Int.repr contents_y)))
        (map Vint (map Int.repr contents_y)) = (map Vint (map Int.repr contents_y))) by list_solve.
        rewrite H7.
        rewrite H, H0.
        assert (sublist.sublist 16 16 contents_x = []) by list_solve.
        rewrite H8.
        rewrite app_nil_r.
        cancel.
        Qed.


From Undecidability.L Require Export Prelim.ARS Prelim.MoreBase.
From Undecidability.Shared.Libs.PSL Require Export Base Bijection.
From Undecidability.L Require Export L.

Require Import Lia.

#[export] Hint Constructors ARS.star : cbv.

(* * The call-by-value lambda calculus L *)

(* ** Syntax   *)

Notation "'#' v" := (var v) (at level 1).
(* Notation "(λ  s )" := (lam s) (right associativity, at level 0).  *)

Module L_Notations_app.
  Coercion app : term >-> Funclass.
End L_Notations_app.

Module L_Notations.

  Coercion var : nat >-> term.
  Export L_Notations_app.
End L_Notations.

#[global]
Instance term_eq_dec : eq_dec term.
Proof.
  intros s t; unfold dec; repeat decide equality.
Defined. (* because instance *)

Definition term_eq_dec_proc s t := if Dec (s = t) then true else false.

#[export] Hint Resolve term_eq_dec : core.

(* Notation using binders *)

Inductive hoas : Type := hv (n : nat) | ha (s t : hoas) | hl (f : nat -> hoas) | hter (t : term).

Fixpoint TH n s :=
  match s with
  | hv m => var (n - m - 1)
  | ha s t => app (TH n s) (TH n t)
  | hl f => lam (TH (S n) (f n))
  | hter t => t
  end.

(* TODO: should not be a coercion *)
Definition convert := TH 0.

Module HOAS_Notations.

  Coercion hv : nat >-> hoas.
  Coercion ha : hoas >-> Funclass.
  Notation "'!!' s" := (hter s) (at level 0).

  Notation "[ 'L_HOAS' p ]" := (convert p) (at level 0, format  "[ 'L_HOAS'  p ]").

  Notation "'λ' x .. y , p" := (hl (fun x => .. (hl (fun y => p)) ..))
    (at level 100, x binder, right associativity,
     format "'[' 'λ'  '/  ' x  ..  y ,  '/  ' p ']'").

End HOAS_Notations.

(* Use Eval simpl in (term) when defining an term using convert.
This converts while defining and therefore makes all later steps faster.
See "important terms" below

Also: remember to give the type of combinators explicitly becuase we want to use the coercion!
(e.g. "Definition R:term := ..." )*)

Arguments convert /.

(* Important terms *)

(* Import L_Notations. *)
Import HOAS_Notations.

Definition r := Eval simpl in [L_HOAS λ r f, f (λ x , r r f x) ].
Definition R := app r r.
Definition rho (s : term)  := Eval simpl in [L_HOAS λ x, !!r !!r !!s x].

Definition I := Eval simpl in [L_HOAS λ x, x].
Definition K := Eval simpl in [L_HOAS λ x y, x].

Definition omega : term := Eval simpl in [L_HOAS λ x , x x].
Definition Omega : term := app omega omega.

(*  Substitution *)

(* Important definitions *)

Definition closed s := forall n u, subst s n u = s.

Definition lambda s := exists t, s = lam t.

Definition proc s := closed s /\ lambda s.

Lemma lambda_lam s : lambda (lam s).
Proof.
  exists s; reflexivity.
Qed.

#[export] Hint Resolve lambda_lam : core.

#[global]
Instance lambda_dec s : dec (lambda s).
Proof.
  destruct s;[right;intros C;inv C;congruence..|left;eexists;eauto].
Defined. (* because instance *)

(* Size of terms *)

Fixpoint size (t : term) :=
  match t with
  | var n => 1 + n
  | app s t => 1+ size s + size t
  | lam s => 1 + size s
  end.

Fixpoint size' (t : term) :=
  match t with
  | var n => 0
  | app s t => 1+ size' s + size' t
  | lam s => 1 + size' s
  end.

(* Alternative definition of closedness *)

Inductive bound : nat -> term -> Prop :=
  | dclvar k n : k > n -> bound k (var n)
  | dclApp k s t : bound k s -> bound k t -> bound k (app s t)
  | dcllam k s : bound (S k) s -> bound k (lam s).

Lemma bound_closed_k s k u : bound k s -> subst s k u = s.
Proof with eauto.
  intros H; revert u; induction H; intros u; simpl.
  - destruct (Nat.eqb_spec n k)... lia.
  - rewrite IHbound1, IHbound2...
  - f_equal...
Qed.

Lemma bound_ge k s : bound k s -> forall m, m >= k -> bound m s.
Proof.
  induction 1; intros m Hmk; econstructor; eauto.
  - lia.
  - eapply IHbound. lia.
Qed.

Lemma bound_gt k s : bound k s -> forall m, m > k -> bound m s.
Proof.
  intros. apply (bound_ge H). lia.
Qed.

Lemma bound_closed s k u : bound 0 s -> subst s k u = s.
Proof.
  intros H. destruct k.
  - eapply bound_closed_k. eassumption.
  - eapply bound_gt in H. eapply bound_closed_k. eassumption. lia.
Qed.

Lemma closed_k_bound k s : (forall n u, n >= k -> subst s n u = s) -> bound k s.
Proof.
  revert k. induction s; intros k H.
  - econstructor. specialize (H n (#(S n))). simpl in H.
    decide (n >= k) as [Heq | Heq].
    + destruct (Nat.eqb_spec n n); [injection (H Heq)|]; lia.
    + lia.
  - econstructor; [eapply IHs1 | eapply IHs2]; intros n u Hnk;
    injection (H n u Hnk); congruence.
  - econstructor. eapply IHs. intros n u Hnk.
    destruct n. lia.
    injection (H n u). tauto. lia.
Qed.

Lemma closed_dcl s : closed s <-> bound 0 s.
Proof.
  split.
  -eauto using closed_k_bound.
  -unfold closed. eauto using bound_closed.
Qed.

Lemma closed_app (s t : term) : closed (app s t) -> closed s /\ closed t.
Proof.
  intros cls. rewrite closed_dcl in cls. inv cls. split; rewrite closed_dcl; eassumption.
Qed.

Lemma app_closed (s t : term) : closed s -> closed t -> closed (app s t).
Proof.
  intros H H' k u. simpl. now rewrite H, H'.
Qed.

#[global]
Instance bound_dec k s : dec (bound k s).
Proof with try ((left; econstructor; try lia; tauto) || (right; inversion 1; try lia; tauto)).
  revert k; induction s; intros k.
  - destruct (le_lt_dec n k) as [Hl | Hl]... destruct (le_lt_eq_dec _ _ Hl)...
  - destruct (IHs1 k), (IHs2 k)...
  - induction k.
    + destruct (IHs 1)...
    + destruct (IHs (S (S k)))...
Defined. (* because instance *)

#[global]
Instance closed_dec s : dec (closed s).
Proof.
  decide (bound 0 s);[left|right];now rewrite closed_dcl.
Defined. (* because instance *)

(* ** Reduction *)

Reserved Notation "s '≻' t" (at level 50).

Inductive step : term -> term -> Prop :=
| stepApp  s t     : app (lam s) (lam t) ≻ subst s 0 (lam t)
| stepAppR s t  t' : t ≻ t' -> app s t ≻ app s t'
| stepAppL s s' t  : s ≻ s' -> app s t ≻ app s' t
where "s '≻' t" := (step s t).

#[export] Hint Constructors step : core.

Ltac inv_step :=
  match goal with
    | H : step (lam _) _ |- _ => inv H
    | H : step (var _) _ |- _ => inv H
    | H : star step (lam _) _ |- _ => inv H
    | H : star step (var _) _ |- _ => inv H
  end.

Lemma closed_subst s t k : bound (S k) s -> bound k t -> bound k (subst s k t).
Proof.
  revert k t; induction s; intros k t cls_s cls_t; simpl; inv cls_s; eauto 6 using bound, bound_gt.
  destruct (Nat.eqb_spec n k); eauto. econstructor.  lia.
Qed.

Lemma closed_step s t : s ≻ t -> closed s -> closed t.
Proof.
  rewrite !closed_dcl; induction 1; intros cls_s; inv cls_s; eauto using bound.
  inv H2. eauto using closed_subst.
Qed.

Lemma comb_proc_red s : closed s -> proc s \/ exists t, s ≻ t.
Proof with try tauto.
  intros cls_s. induction s.
  - eapply closed_dcl in cls_s. inv cls_s. lia.
  - eapply closed_app in cls_s. destruct IHs1 as [[C [t A]] | A], IHs2 as [[D [t' B]] | B]...
    + right. subst. eexists. eauto.
    + right; subst. firstorder; eexists. eapply stepAppR. eassumption.
    + right; subst. firstorder; eexists. eapply stepAppL. eassumption.
    + right. subst. firstorder. eexists. eapply stepAppR. eassumption.
  - left. split. eassumption. firstorder.
Qed.

Goal forall s, closed s -> ((~ exists t, s ≻ t) <-> proc s).
Proof.
  intros s cls_s. split.
  destruct (comb_proc_red cls_s).
  - eauto.
  - tauto.
  - destruct 1 as [? [? ?]]. subst. destruct 1 as [? B]. inv B.
Qed.

(* Properties of the reduction relation *)

Theorem uniform_confluence : uniform_confluent step.
Proof with repeat inv_step; eauto using step.
  intros s; induction s; intros t1 t2 step_s_t1 step_s_t2; try now inv step_s_t2.
  inv step_s_t1.
  - inv step_s_t2; try eauto; inv_step.
  - inv step_s_t2...
    + destruct (IHs2 _ _ H2 H3).
      * left. congruence.
      * right. destruct H as [u [A B]]...
    + right...
  - inv step_s_t2...
    + right...
    + destruct (IHs1 _ _ H2 H3).
      * left. congruence.
      * right. destruct H as [u [A B]]...
Qed.

Notation "s '>(' l ')' t" := (pow step l s t) (at level 50, format "s  '>(' l ')'  t").
Arguments pow: simpl never.

Lemma confluence : confluent step.
Proof.
  intros x y z x_to_y x_to_z.
  eapply star_pow in x_to_y. destruct x_to_y as [n x_to_y].
  eapply star_pow in x_to_z. destruct x_to_z as [m x_to_z].
  destruct (parametrized_confluence uniform_confluence x_to_y x_to_z) as
      [k [l [u [_ [_ [C [D _]]]]]]].
  exists u. split; eapply star_pow; eexists; eassumption.
Qed.

Lemma step_Lproc s v :
  lambda v -> app (lam s) v ≻ subst s 0 v.
Proof.
  intros [t lamv].
  rewrite lamv.
  repeat econstructor.
Qed.

Lemma lam_terminal u: lambda u -> terminal step u.
Proof.
  intros H ? R;inv H;inv R.
Qed.

(* Properties of the reflexive, transitive closure of reduction *)

Notation "s '>*' t" := (star step s t) (at level 50).

#[global]
Instance star_PreOrder : PreOrder (star step).
Proof.
  constructor; hnf.
  - eapply starR.
  - eapply star_trans.
Qed.

Lemma step_star s s':
  s ≻ s' -> s >* s'.
Proof.
  eauto using star.
Qed.

#[global]
Instance step_star_subrelation : subrelation step (star step).
Proof.
  cbv. apply step_star.
Qed.

Lemma star_trans_l s s' t :
  s >* s' -> app s t >* app s' t.
Proof.
  induction 1; eauto using star, step.
Qed.

Lemma star_trans_r (s s' t:term):
  s >* s' -> app t s >* app t s'.
Proof.
  induction 1; eauto using star, step.
Qed.

#[global]
Instance star_step_app_proper :
  Proper ((star step) ==> (star step) ==> (star step)) app.
Proof.
  cbv. intros s s' A t t' B.
  etransitivity. apply (star_trans_l _ A). now apply star_trans_r.
Qed.

Lemma closed_star s t: s >* t -> closed s -> closed t.
Proof.
  intros R. induction R;eauto using closed_step.
Qed.

#[global]
Instance star_closed_proper :
  Proper ((star step) ==> Basics.impl) closed.
Proof.
  exact closed_star.
Qed.

(*  Properties of star: *)

#[global]
Instance pow_step_congL k:
  Proper ((pow step k) ==> eq ==> (pow step k)) app.
Proof.
  intros s t R u ? <-. revert s t R u.
  induction k;cbn in *;intros ? ? R ?. congruence. destruct R as [s' [R1 R2]].
  exists (app s' u). firstorder.
Qed.

#[global]
Instance pow_step_congR k:
  Proper (eq ==>(pow step k) ==> (pow step k)) app.
Proof.
  intros s ? <- t u R. revert s t u R.
  induction k;cbn in *;intros ? ? ? R. congruence. destruct R as [t' [R1 R2]].
  exists (app s t'). firstorder.
Qed.

(* Equivalence *)

Reserved Notation "s '==' t" (at level 50).

Inductive equiv : term -> term -> Prop :=
  | eqStep s t : step s t -> s == t
  | eqRef s : s == s
  | eqSym s t : t == s -> s == t
  | eqTrans s t u: s == t -> t == u -> s == u
where "s '==' t" := (equiv s t).

#[export] Hint Immediate eqRef : core.

(* Properties of the equivalence relation *)

#[global]
Instance equiv_Equivalence : Equivalence equiv.
Proof.
  constructor; hnf.
  - apply eqRef.
  - intros. eapply eqSym. eassumption.
  - apply eqTrans.
Qed.

Lemma equiv_ecl s t : s == t <-> ecl step s t.
Proof with eauto using ecl, equiv.
  split; induction 1...
  - eapply ecl_sym...
  - eapply ecl_trans...
Qed.

Lemma church_rosser s t : s == t -> exists u, s >* u /\ t >* u.
Proof.
  rewrite equiv_ecl. eapply confluent_CR, confluence.
Qed.

Lemma star_equiv s t :
  s >* t -> s == t.
Proof.
  induction 1.
  - reflexivity.
  - eapply eqTrans. econstructor; eassumption. eassumption.
Qed.
#[export] Hint Resolve star_equiv : core.

#[global]
Instance star_equiv_subrelation : subrelation (star step) equiv.
Proof.
  cbv. apply star_equiv.
Qed.

#[global]
Instance step_equiv_subrelation : subrelation step equiv.
Proof.
  cbv. intros ? ? H. apply star_equiv, step_star. assumption.
Qed.

Lemma equiv_lambda s t : lambda t -> s == t -> s >* t.
Proof.
  intros H eq. destruct (church_rosser eq) as [u [A B]]. inv B. assumption. inv H. inv H0.
Qed.

Lemma eqStarT s t u : s >* t -> t == u -> s == u.
Proof.
  eauto using equiv.
Qed.

Lemma eqApp s s' u u' : s == s' -> u == u' -> app s u == app s' u'.
Proof with eauto using equiv, step.
  intros H; revert u u'; induction H; intros z z' H'...
  - eapply eqTrans. eapply eqStep. eapply stepAppL. eassumption.
    induction H'...
  - induction H'...
Qed.

#[global]
Instance equiv_app_proper :
  Proper (equiv ==> equiv ==> equiv) app.
Proof.
  cbv. intros s s' A t t' B.
  eapply eqApp; eassumption.
Qed.

(* Definition of convergence *)

Definition converges s := exists t, s == t /\ lambda t.

Lemma converges_equiv s t : s == t -> (converges s <-> converges t).
Proof.
  intros H; split; intros [u [A lu]]; exists u;split;try assumption; rewrite <- A.
  - symmetry. eassumption.
  - eassumption.
Qed.

#[global]
Instance converges_proper :
  Proper (equiv ==> iff) converges.
Proof.
  intros s t H. now eapply converges_equiv.
Qed.
(*
Lemma eq_lam s t : lambda s -> lambda t -> lam s == lam t <-> s = t.
Proof.
  split.
  - intros H. eapply equiv_lambda in H; repeat inv_step; reflexivity.
  - intros []. reflexivity.
Qed.

Lemma unique_normal_forms' (s t t' : term) : s == lam t -> s == lam t' -> lam t = lam t'.
Proof.
  intros Ht Ht'. rewrite Ht in Ht'. eapply eq_lam in Ht'. congruence.
Qed.*)

Lemma unique_normal_forms (s t : term) : lambda s -> lambda t ->  s == t -> s = t.
Proof.
  intros ls lt. intros H. apply equiv_lambda in H;try assumption. inv ls. inv H. reflexivity. inv H0.
Qed.

(* Eta expansion *)

Lemma Eta (s : term ) t : closed s -> lambda t -> app (lam (app s #0)) t == app s t.
Proof.
  intros cls_s lam_t. eapply star_equiv, starC; eauto using step_Lproc. simpl. rewrite cls_s. reflexivity.
Qed.

(* Useful lemmas *)

Lemma pow_trans s t u i j: pow step i s t -> pow step j t u -> pow step (i+j) s u.
Proof.
  intros. subst. apply pow_add. now exists t.
Qed.

#[global]
Instance pow_star_subrelation i: subrelation (pow step i) (star step).
Proof.
  intros ? ? ?.
  eapply pow_star;eauto.
Qed.

(* Definition of evaluation *)

Definition eval s t := s >* t /\ lambda t.
Notation "s '⇓' t" := (eval s t) (at level 51).
#[export] Hint Unfold eval : core.

Lemma eval_unique s v1 v2 :
  s ⇓ v1 -> s ⇓ v2 -> v1 = v2.
Proof.
  intros (R1&L1) (R2&L2).
  eapply unique_normal_forms.
  1-2:eassumption.
  now rewrite <-R1,R2.
Qed.

#[global]
Instance eval_star_subrelation : subrelation eval (star step).
Proof.
  now intros ? ? [].
Qed.

#[global]
Instance reduce_eval_proper : Proper (Basics.flip (star step) ==> eq ==> Basics.impl) eval.
Proof.
  repeat intro. subst. unfold Basics.flip in H. destruct H1. split. etransitivity. eassumption. assumption. assumption.
Qed.

#[global]
Instance equiv_eval_proper: Proper (equiv ==> eq ==> Basics.impl) eval.
Proof.
  repeat intro;subst. destruct H1. split;try auto. apply equiv_lambda. auto. now rewrite <- H0, H.
Qed.

Definition evalIn i s t := s >(i) t /\ lambda t.

Notation "s '⇓(' l ')' t" := (evalIn l s t) (at level 50, format "s  '⇓(' l ')'  t").

Definition redLe l s t := exists i , i <= l /\ pow step i s t.
Notation "s '>(<=' l ')' t" := (redLe l s t) (at level 50, format "s  '>(<=' l ')'  t").

Definition evalLe l s t := s >(<=l) t /\ lambda t.
Notation "s '⇓(<=' l ')' t" := (evalLe l s t) (at level 50, format "s  '⇓(<=' l ')'  t").

#[global]
Instance evalLe_eval_subrelation i: subrelation (evalLe i) eval.
Proof.
  intros ? ? [[? []] ?]. split. eapply pow_star_subrelation. all:eauto.
Qed.

Lemma evalLe_evalIn s t k:
  s ⇓(<=k) t -> exists k', k' <= k /\ s ⇓(k') t.
Proof.
  unfold evalLe,redLe,evalIn. firstorder.
Qed.

Lemma evalIn_evalLe s t k k':
  k' <= k -> s ⇓(k') t -> s ⇓(<=k) t.
Proof.
  unfold evalLe,redLe,evalIn. firstorder.
Qed.

#[global]
Instance evalIn_evalLe_subrelation i: subrelation (evalIn i) (evalLe i).
Proof.
  intros s t (R & lt). split;[now exists i|trivial].
Qed.

#[global]
Instance pow_redLe_subrelation i: subrelation (pow step i) (redLe i).
Proof.
  intros s t R. now exists i.
Qed.

#[global]
Instance evalLe_redLe_subrelation i: subrelation (evalLe i) (redLe i).
Proof.
  now intros ? ? [].
Qed.

#[global]
Instance evalIn_eval_subrelation i: subrelation (evalIn i) eval.
Proof.
  intros ? ? [?  ?]. split. eapply pow_star_subrelation. all:eauto.
Qed.

#[global]
Instance redLe_star_subrelation i: subrelation (redLe i) (star step).
Proof.
  intros ? ? (j & leq & R). now rewrite R.
Qed.

#[global]
Instance le_redLe_proper: Proper (le ==> eq ==> eq ==> Basics.impl) redLe.
Proof.
  intros ? ? ? ? ? -> ? ? -> (i&lt&R).
  exists i. split. lia. tauto.
Qed.

Lemma redLe_mono s t n n' :
  s >(<=n) t -> n <= n' -> s >(<=n') t.
Proof.
  intros ? <-. easy.
Qed.

#[global]
Instance le_evalLe_proper: Proper (le ==> eq ==> eq ==> Basics.impl) evalLe.
Proof.
  intros ? ? H' ? ? -> ? ? -> [H p].
  split. 2:tauto. now rewrite <- H'.
Qed.

Lemma evalIn_mono s t n n' :
  s ⇓(<=n) t -> n <= n' -> s ⇓(<=n') t.
Proof.
  intros ? <-. easy.
Qed.

Lemma evalIn_trans s t u i j :
  s >(i) t -> t ⇓(j) u -> s ⇓(i+j) u.
Proof.
  intros R1 [R2 lam].
  split; eauto using pow_trans.
Qed.

Lemma redLe_trans s t u i j :
  s >(<=i) t -> t >(<=j) u -> s >(<=i+j) u.
Proof.
  intros [i' [? R1]] [j' [? R2]].
  exists (i'+j'). split. lia. apply pow_add. hnf; eauto.
Qed.

Lemma redLe_trans_eq s t u i j k :
  i+j=k ->  s >(<=i) t -> t >(<=j) u -> s >(<=k) u.
Proof.
  intros;subst;eauto using redLe_trans.
Qed.

Lemma evalLe_trans s t u i j :
  s >(<=i) t -> t ⇓(<=j) u -> s ⇓(<=i+j) u.
Proof.
  intros R1 [R2 lam].
  split; eauto using redLe_trans.
Qed.

#[global]
Instance pow0_refl : Reflexive (pow step 0).
Proof.
  intro. reflexivity.
Qed.

#[global]
Instance redLe_refl : Reflexive (redLe 0).
Proof.
  intro. eexists; split;reflexivity.
Qed.

Lemma evalIn_unique s k1 k2 v1 v2 :
  s ⇓(k1) v1 -> s ⇓(k2) v2 -> k1 = k2 /\ v1 = v2.
Proof.
  intros (R1&L1) (R2&L2).
  eapply uniform_confluence_parameterized_both_terminal.
  all:eauto using lam_terminal,uniform_confluence.
Qed.

Lemma eval_evalIn s t:
  eval s t -> exists k, evalIn k s t.
Proof.
  intros [(R&?)%star_pow ?]. unfold evalIn. eauto.
Qed.

(* Helpfull Lemmas*)

Lemma pow_trans_lam' t v s k j:
  lambda v -> pow step j t v -> pow step k t s  -> j>=k /\ pow step (j-k) s v.
Proof.
  intros lv A B.
  destruct (parametrized_confluence uniform_confluence A B)
     as [m' [l [u [m_le_Sk [l_le_n [C [D E]]]]]]].
  cut (m' = 0).
  -intros ->. split. lia. replace (j-k) with l by lia. hnf in C. subst v. tauto.
  -destruct m'; eauto. destruct C. destruct H. inv lv. inv H.
Qed.

Lemma evalLe_trans_rev t v s k j:
  evalLe j t v -> pow step k t s  -> j>=k /\ evalLe (j-k) s v.
Proof.
  intros [(i&lti&R) lv] B.
  edestruct (pow_trans_lam' lv R B). split. lia. split. 2:tauto. eexists;split. 2:eauto. lia.
Qed.

Lemma pow_trans_lam t v s k n :
  lambda v -> pow step n t v -> pow step (S k) t s  -> exists m, m < n /\ pow step m s v.
Proof.
  intros H1 H2 H3. edestruct (pow_trans_lam' H1 H2 H3) as (H'1&H'2). do 2 eexists. 2:eassumption. lia.
Qed.

Lemma powSk t t' s : t ≻ t' -> t' >* s -> exists k, pow step (S k) t s.
Proof.
  intros A B.
  eapply star_pow in B. destruct B as [n B]. exists n.
  unfold pow. simpl. econstructor. unfold pow in B. split; eassumption.
Qed.

(* Properties of rho *)

Lemma rho_dcls n s : bound (S n) s -> bound n (rho s).
Proof.
  unfold rho,r. intros H. repeat (apply dcllam || apply dclApp || apply dclvar);try assumption;try lia.
Qed.

Lemma closed_dcl_x x s: closed s -> bound x s.
Proof.
  intros. apply (@bound_ge 0). now apply closed_dcl. lia.
Qed.
Lemma rho_cls s : closed s -> closed (rho s).
Proof.
  intros. rewrite closed_dcl.  apply rho_dcls. now apply closed_dcl_x.
Qed.

Lemma rho_lambda s : lambda (rho s).
Proof.
  eexists. reflexivity.
Qed.

Lemma step_eval s t v :
  s ≻ t -> L.eval t v -> L.eval s v.
Proof.
  induction 1 in v |- *; intros He.
  - repeat econstructor; eauto.
  - inv He. econstructor; eauto.
  - inv He. econstructor; eauto.
Qed.

Lemma eval_iff s t :
  L.eval s t <-> s ⇓ t.
Proof.
  split.
  - induction 1.
    + split. reflexivity. eauto.
    + split.
      destruct IHeval2 as [IH1 [v' ->]].
      2:eapply IHeval3.
      rewrite IHeval1, IH1.
      econstructor. 2:eapply IHeval3.
      econstructor.
  - intros [H1 [v ->]].
    revert H1. revert s.
    eapply (star_simpl_ind (y := lam v)).
    + econstructor.
    + intros s s' H1 H2 IH.
      eapply step_eval; eauto.
Qed.


(************************************************************************)
(*  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: Prelude.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Notations.
Require Export Logic.
Require Export Datatypes.
Require Export Specif.
Require Export Peano.
Require Export Coq.Init.Wf.
Require Export Coq.Init.Tactics.
(* Initially available plugins
   (+ nat_syntax_plugin loaded in Datatypes) *)
Declare ML Module "extraction_plugin".
Declare ML Module "cc_plugin".
Declare ML Module "ground_plugin".
Declare ML Module "dp_plugin".
Declare ML Module "recdef_plugin".
Declare ML Module "subtac_plugin".
Declare ML Module "xml_plugin".


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.WfInversion.
Require Import Crypto.Compilers.Rewriter.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}.

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation wff := (@wff base_type_code op).
  Local Notation wf := (@wf base_type_code op).
  Local Notation Wf := (@Wf base_type_code op).
  Local Notation exprf := (@exprf base_type_code op).
  Local Notation expr := (@expr base_type_code op).
  Local Notation Expr := (@Expr base_type_code op).

  Section with_var.
    Context {var1 var2 : base_type_code -> Type}
            {rewrite_op_expr1 : forall src dst (opc : op src dst),
                exprf (var:=var1) src -> exprf (var:=var1) dst}
            {rewrite_op_expr2 : forall src dst (opc : op src dst),
                exprf (var:=var2) src -> exprf (var:=var2) dst}
            (Hrewrite_wf : forall G src dst opc args1 args2,
                wff G args1 args2
                -> wff G
                       (rewrite_op_expr1 src dst opc args1)
                       (rewrite_op_expr2 src dst opc args2)).

    Lemma wff_rewrite_opf {t} G (e1 : @exprf var1 t) (e2 : @exprf var2 t)
          (Hwf : wff G e1 e2)
      : wff G (rewrite_opf rewrite_op_expr1 e1) (rewrite_opf rewrite_op_expr2 e2).
    Proof using Type*.
      induction Hwf; simpl; try constructor; auto.
    Qed.

    Lemma wf_rewrite_op {t} (e1 : @expr var1 t) (e2 : @expr var2 t)
          (Hwf : wf e1 e2)
      : wf (rewrite_op rewrite_op_expr1 e1) (rewrite_op rewrite_op_expr2 e2).
    Proof using Type*.
      destruct Hwf; simpl; constructor; intros; apply wff_rewrite_opf; auto.
    Qed.
  End with_var.

  Lemma Wf_RewriteOp
        {rewrite_op_expr}
        (Hrewrite_wff : forall var1 var2 G src dst opc args1 args2,
            wff G args1 args2
            -> wff G
                   (rewrite_op_expr var1 src dst opc args1)
                   (rewrite_op_expr var2 src dst opc args2))
        {t} (e : Expr t)
        (Hwf : Wf e)
    : Wf (RewriteOp rewrite_op_expr e).
  Proof using Type.
    intros var1 var2; apply wf_rewrite_op; auto.
  Qed.
End language.

Hint Resolve Wf_RewriteOp : wf.


(*
 * Copyright (C) BedRock Systems Inc. 2022
 *
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Import iris.algebra.frac.	(** for [fracO] *)
Require Import iris.algebra.proofmode_classes.	(** for [IsOp] *)
Require Export iris.algebra.lib.dfrac_agree.
Require Export bedrock.prelude.base.
Set Printing Coercions.

Lemma qple_dfrac_own_incl q1 q2 :
  (q1 ≤ q2)%Qp ↔ DfracOwn q1 ≼ DfracOwn q2 ∨ DfracOwn q1 = DfracOwn q2.
Proof.
  by rewrite dfrac_own_included (inj_iff DfracOwn) -Qp.le_lteq.
Qed.

Definition dfrac_agreeRF (F : oFunctor) : rFunctor :=
  constRF dfracR * agreeRF F.

(**
Iris left [to_frac_agree] transparent in [typeclass_instances] in an
attempt to reuse instances for the underlying [to_dfrac_agree].
Unfortunately, some useful instances aren't derivable. We declare what
we need and, orthogonally, mark [to_frac_agree] TC opaque to speed up
type class resolution.
*)

Section dfrac_agree.
  Context {A : ofe}.
  Implicit Types (q : Qp) (d : dfrac) (a : A).

  Lemma to_dfrac_agree_valid d a : ✓ to_dfrac_agree d a -> ✓ d.
  Proof. by rewrite/to_dfrac_agree pair_valid=>-[]. Qed.

  #[global] Instance to_frac_agree_ne q : NonExpansive (@to_frac_agree A q).
  Proof. Fail apply _. apply to_dfrac_agree_ne. Qed.
  #[global] Instance to_frac_agree_proper q :
    Proper (equiv ==> equiv) (@to_frac_agree A q).
  Proof. Fail apply _. apply to_dfrac_agree_proper. Qed.

  #[global] Instance to_frac_agree_exclusive a :
    Exclusive (to_frac_agree 1 a) := _.
  #[global] Instance to_frac_agree_discrete q a :
    Discrete a -> Discrete (to_frac_agree q a) := _.
  #[global] Instance to_frac_agree_injN n :
    Inj2 (dist n) (dist n) (dist n) (@to_frac_agree A).
  Proof.
    Fail apply _. by intros q1 a1 q2 a2 [[= ->]->]%to_dfrac_agree_injN.
  Qed.
  #[global] Instance to_frac_agree_inj :
    Inj2 equiv equiv equiv (@to_frac_agree A).
  Proof.
    Fail apply _. by intros q1 a1 q2 a2 [[= ->]->]%to_dfrac_agree_inj.
  Qed.

  (** IPM support *)

  #[global] Instance to_dfrac_agree_is_op a d d1 d2 :
    IsOp d d1 d2 ->
    IsOp' (to_dfrac_agree d a) (to_dfrac_agree d1 a) (to_dfrac_agree d2 a).
  Proof. rewrite/IsOp'/IsOp=>->. apply dfrac_agree_op. Qed.
  #[global] Instance to_frac_agree_is_op a q q1 q2 :
    IsOp q q1 q2 ->
    IsOp' (to_frac_agree q a) (to_frac_agree q1 a) (to_frac_agree q2 a) := _.
End dfrac_agree.
#[global] Hint Opaque to_frac_agree : typeclass_instances.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  finite.v }%*)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Arith.
Require Export equal_syntax.

(** - The setoid of natural numbers - not really necessary but it's nice to have a
 uniform approach *)

Definition Nat : Setoid.
apply (Build_Setoid (Equal:=fun i j : nat => i = j)).
split; try split; red in |- *; unfold app_rel in |- *; simpl in |- *; auto.
intros; transitivity y; auto.
Defined.

(** - In this formalisation, we often need the sets $\{0...n-1\}$
 We use these for finite sequences: $(a_1...a_n)$ is represented
 as a setoid function $a:\{0...n-1\}\to A$; also these elements are used as
 indices into these sequences. Since we use a function type to
 represent a sequence, we can just type [(a i)] for $a_i$.
 - finiteT will serve as the Type on which we base our finite
 setoids [(fin N)] = $\{0...N-1\} = \{ n \in N | n<N \}$. *)

Record finiteT (N : Nat) : Type :=  {index : nat; in_range_prf : index < N}.

(** - The setoid itself is called [(fin N)]. [n:(finiteT N)] is really a pair <n,H>;
 <n,H> and <n',H'> will be deemed equal if n and n' are; the proofs H of n<N and
 H' of n'(=n)<N may differ.

 - %\bf% Useful knowledge: if [H:(lt i n)] then [(Build_finiteT H):(fin n)]

%\label{fin}% *)

Definition fin : Nat -> Setoid.
  intro N.
  apply
  (Build_Setoid (Carrier:=finiteT N)
      (Equal:=fun n m : finiteT N => index n = index m)).
  (* Now, we prove that our relation is an equivalence *)
  red in |- *.
  split.
  { (* Reflexivity *)
    red in |- *.
    intro.
    red in |- *.
    reflexivity.
  }
  { (* Partial equivalence *)
    red in |- *.
    split.
    { (* Transitivity *)
      red in |- *.
      intros.
      red in H.
      red in H0.
      red in |- *.
      transitivity (index y); assumption.
    }
    { (* Symmetry *)
      red in |- *.
      intros.
      red in H.
      red in |- *.
      symmetry  in |- *.
      assumption.
    }
  }
Defined.

Lemma fin_equation :
 forall (n i j : nat) (Hi : i < n) (Hj : j < n),
 i = j -> Build_finiteT Hi =' Build_finiteT Hj in fin n.
intros.
simpl in |- *.
auto.
Qed.

(* This formalisation is heavily dependent on Loic Pottier's algebra contribution *)
(* and therefore relies heavily on the algebra Hints database as well. *)
(* We feel free to extend it: *)

Hint Resolve fin_equation: algebra.

Lemma fin_decidable :
 forall (n : Nat) (i i' : fin n), i =' i' in _ \/ ~ i =' i' in _.
intros.
simpl in |- *.
cut (forall k l : nat, k = l \/ k <> l).
intro.
auto.
clear i' i n.
double induction k l.
left; auto.
intros; right.
unfold not in |- *.
intro.
inversion H0.
intros; right.
unfold not in |- *.
intro.
inversion H0.
intros.
elim (H0 n).
auto.
auto.
Qed.

Lemma fin_O_nonexistent : fin 0 -> False.
destruct 1.
inversion_clear in_range_prf0.
Qed.

Hint Resolve fin_O_nonexistent: algebra.

Lemma fin_S_O_unique : forall i j : fin 1, i =' j in _.
intro.
case i.
intro x.
case x.
intros l j.
case j.
intro x0.
case x0.
simpl in |- *.
auto.
intros.
inversion in_range_prf0.
inversion H0.
intros.
inversion in_range_prf0.
inversion H0.
Qed.

Hint Resolve fin_S_O_unique: algebra.

(** - A sequence is just a setoid function from (fin n) to A:
%\label{seq}% *)
Definition seq (n : Nat) (A : Setoid) := MAP (fin n) A.

(* Somehow this is necessary: *)
Lemma toSeq :
 forall (A : Setoid) (n : Nat) (v v' : Map (fin n) A),
 v =' v' in seq _ _ -> v =' v' in MAP _ _.
auto.
Qed.

Lemma toMap :
 forall (A : Setoid) (n : Nat) (v v' : Map (fin n) A),
 v =' v' in MAP _ _ -> v =' v' in seq _ _.
auto.
Qed.

Hint Resolve toSeq toMap: algebra.


(** * Definition of the fired set of transitions *)

Require Import common.CoqLib.
Require Import sitpn.Sitpn.
Require Import sitpn.SitpnTypes.
Require Import common.GlobalTypes.
Require Import sitpn.SitpnSemanticsDefs.
Require Import common.ListPlus.
Require Import sitpn.SitpnFacts.

Set Implicit Arguments.

(** ** Operational Implementation of the Fired set. *)

(** A more operational implementation of the set of fired transitions
    at a given SITPN state s. *)

(** Qualifies the sublist of transitions that are of top priority
    (i.e, [tp]) in a given list of transitions (i.e, [lofT]). *)

Inductive IsTopPriorityListAux sitpn :
  list (T sitpn) -> list (T sitpn) -> list (T sitpn) -> list (T sitpn) -> Prop :=
| IsTopPriorityList_nil :
    forall lofT__b tp, IsTopPriorityListAux [] lofT__b tp tp
| IsTopPriorityList_cons :
    forall t lofT__a lofT__b tp tp',
      ~(exists t', In t' (lofT__a ++ lofT__b) /\ t' >~ t) ->
      IsTopPriorityListAux lofT__a (lofT__b ++ [t]) (tp ++ [t]) tp' ->
      IsTopPriorityListAux (t :: lofT__a) lofT__b tp tp'
| IsTopPriorityList_not_top :
    forall t lofT__a lofT__b tp tp',
      (exists t', In t' (lofT__a ++ lofT__b) /\ t' >~ t) ->
      IsTopPriorityListAux lofT__a (lofT__b ++ [t]) tp tp' ->
      IsTopPriorityListAux (t :: lofT__a) lofT__b tp tp'.

(** Wrapper around the IsTopPriorityListAux.  [tp] is the top-priority
    list of transitions of the list [lofT].  *)

Definition IsTopPriorityList sitpn (lofT : list (T sitpn)) (tp : list (T sitpn)) : Prop :=
  IsTopPriorityListAux lofT [] [] tp.

(** Elects the fired transitions from a list of transitions [tp];
    the election is based on the firability status of transitions at
    state [s] and their sensitization status at marking [m].
 *)

Inductive ElectFired sitpn (s : SitpnState sitpn) (fired : list (T sitpn)) :
  list (T sitpn) -> list (T sitpn) -> Prop :=
| ElectFired_nil :
    ElectFired s fired [] fired
| ElectFired_cons :
    forall tp t msub fired',
      Firable s t ->
      MarkingSubPreSum (fun t' => t' >~ t /\ InA Teq t' fired) (M s) msub ->
      Sens msub t ->
      ElectFired s (fired ++ [t]) tp fired' ->
      ElectFired s fired (t :: tp) fired'
| ElectFired_not_fired :
    forall tp t msub fired',
      MarkingSubPreSum (fun t' => t' >~ t /\ InA Teq t' fired) (M s) msub ->
      ~(Firable s t /\ Sens msub t) ->
      ElectFired s fired tp fired' ->
      ElectFired s fired (t :: tp) fired'.

(** States that a list [d] is the result of the difference between two
    lists [l] and [m]; i.e, d = l\m is set theory notation. *)

Definition IsDiff {A} (l m d : list A) :=
  NoDup l /\ NoDup m /\ NoDup d /\ forall a, In a d <-> (In a l /\ ~In a m).

(** Builds the list of fired transitions from the list [lofT], the
    list of already elected fired transitions [fired], and the
    residual marking [m]. *)

Inductive IsFiredListAux sitpn (s : SitpnState sitpn) (fired : list (T sitpn)) :
  list (T sitpn) -> list (T sitpn) -> Prop :=
| IsFiredListAux_nil :
      IsFiredListAux s fired [] fired
| IsFiredListAux_cons :
    forall lofT tp fired' lofT' fired'',

      (* [tp] is the list of top-priority transitions contained in [lofT]. *)
      IsTopPriorityList lofT tp ->

      (* [fired'] is the list of fired transitions built from the
         previous list of fired transitions [fired], and the list of
         top-priority transitions [tp]. *)
      ElectFired s fired tp fired' ->

      (* lofT' = lofT \ tp *)

      IsDiff lofT tp lofT' ->

      IsFiredListAux s fired' lofT' fired'' ->

      IsFiredListAux s fired lofT fired''.

(** Wrapper around the IsFiredListAux predicate.

    Adds that [Tlist] must implement the set (T sitpn).
 *)

Definition IsFiredList sitpn (s : SitpnState sitpn) (fired : list (T sitpn)) : Prop :=
    forall Tlist,
      Set_in_ListA Teq (fun t => True) Tlist ->
      IsFiredListAux s [] Tlist fired.

(** Final definition of the set of [fired] transitions at state [s]
    and the fact that a transition [t] belongs to the set. *)

Definition Fired sitpn (s : SitpnState sitpn) (fired : list (T sitpn)) (t : T sitpn) : Prop :=
  IsFiredList s fired /\ In t fired.