Add LoadPath "../..".
Require Import Setoid.
Require Export HybND_Shared.
Require Export PermutLib.
Require Export HybND_PPermutLib.
Require Export ListLib.

Open Scope permut_scope.

(*** Definitions ***)

Set Implicit Arguments.

Section Definitions.

Variables A B : Type.

Inductive ok_Hyb: list (var * A) -> list var -> Prop :=
| ok_Hyb_nil: forall U, ok_Hyb nil U
| ok_Hyb_step: forall w C G U,
  ~ Mem w U -> ok_Hyb G (w::U) -> ok_Hyb ((w, C)::G) U
.

End Definitions.

Definition ok_Bg_Hyb (G: bg_Hyb) : Prop :=
ok_Hyb G nil /\
ok_Hyb (flat_map snd_ G) nil.

Fixpoint used_t_vars_Hyb (G: bg_Hyb) :=
match G with
| nil => from_list nil
| (w, Gamma) :: G => from_list (map fst_ Gamma) \u used_t_vars_Hyb G
end.

Fixpoint used_w_vars_Hyb (G: bg_Hyb) :=
match G with
| nil => from_list nil
| (w, Gamma) :: G => \{w} \u used_w_vars_Hyb G
end.

(*** Lemmas ***)

Lemma flat_map_PPermut_Hyb:
forall G G',
  G ~=~ G' -> flat_map snd_ G *=* flat_map snd_ G'.
induction G; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
destruct a; apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst; simpl in *.
specialize IHG with (hd ++ tl).
rew_flat_map; simpl.
transitivity (l' ++ flat_map snd_ G); permut_simpl; auto.
transitivity (flat_map snd_ (hd++tl)).
apply IHG; apply PPermut_Hyb_last_rev with (w:=v) (Gamma:=l) (Gamma':=l');
auto; transitivity ((v,l)::G); PPermut_Hyb_simpl; rewrite H0; PPermut_Hyb_simpl.
rew_flat_map; auto.
Qed.

(* used_*_vars *)

Lemma used_t_vars_Hyb_app:
forall x y,
  used_t_vars_Hyb (x ++ y) = used_t_vars_Hyb x \u used_t_vars_Hyb y.
induction x; intros.
rew_app; simpl; rewrite from_list_nil; rewrite union_empty_l; auto.
rew_app; destruct a; simpl; rewrite IHx; rewrite union_assoc; auto.
Qed.

Lemma used_w_vars_Hyb_app:
forall x y,
  used_w_vars_Hyb (x ++ y) = used_w_vars_Hyb x \u used_w_vars_Hyb y.
induction x; intros.
rew_app; simpl; rewrite from_list_nil; rewrite union_empty_l; auto.
rew_app; destruct a; simpl; rewrite IHx; rewrite union_assoc; auto.
Qed.

Add Morphism used_t_vars_Hyb: PPermut_Hyb_used_t.
induction x; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
destruct a; simpl.
assert ((v, l) :: x ~=~ y) by auto.
apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst.
assert (x & (v,l) ~=~  (hd ++ tl) & (v, l')).
  transitivity ((v,l)::x); [ | rewrite H0];
  PPermut_Hyb_simpl.
apply PPermut_Hyb_last_rev in H; auto.
rewrite IHx with (y:=hd ++ tl); auto.
repeat rewrite used_t_vars_Hyb_app.
simpl; repeat rewrite <- union_assoc.
rewrite from_list_nil; rewrite union_empty_l.
assert (from_list (map fst_ l) = from_list (map fst_ l')).
  apply from_list_map; auto.
rewrite union_comm_assoc; rewrite H1; auto.
Qed.

Add Morphism used_w_vars_Hyb: PPermut_Hyb_used_w.
induction x; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
destruct a; simpl.
assert ((v, l) :: x ~=~ y) by auto.
apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))).
subst.
assert (x & (v,l) ~=~  (hd ++ tl) & (v, l')).
  transitivity ((v,l)::x); [ | rewrite H0];
  PPermut_Hyb_simpl.
apply PPermut_Hyb_last_rev in H; auto.
rewrite IHx with (y:=hd ++ tl); auto.
repeat rewrite used_w_vars_Hyb_app.
simpl; repeat rewrite <- union_assoc.
rewrite union_comm_assoc;
rewrite from_list_nil; rewrite union_empty_l.
auto.
Qed.

(* ok_Hyb for a generic type *)

Lemma ok_Hyb_used_permut:
forall A G U U',
  U *=* U' ->
  (@ok_Hyb A G U) ->
  (@ok_Hyb A G U').
induction G; intros.
destruct U'; econstructor; eauto.
destruct a; inversion H0; subst;
constructor; [ intro | apply IHG with (U:=v::U)]; auto;
apply Mem_permut with (l':=U) in H1; [ elim H5 | symmetry]; auto.
Qed.

Lemma ok_Hyb_used_weakening:
forall A G x U,
  (@ok_Hyb A G (x::U)) ->
  (@ok_Hyb A G U).
induction G; intros; try constructor;
destruct a; inversion H; subst;
constructor.
intro; apply Mem_permut with (l':=U) in H0; auto; elim H4;
rewrite Mem_cons_eq; right; auto.
apply ok_Hyb_used_permut with (U' := (x::v::U)) in H5;
[ | permut_simpl]; apply IHG with (x:=x); auto.
Qed.

Lemma ok_Hyb_split:
forall A G1 G2 U,
  (@ok_Hyb A (G1++G2) U) ->
  ok_Hyb G1 U /\ ok_Hyb G2 U.
induction G1; intros; split; try destruct a; auto using ok_Hyb.
rew_app in *; inversion H; subst; constructor; auto;
eapply IHG1 with (G2:=G2); auto.
rew_app in *; inversion H; subst; eapply IHG1 with (G2:=G2); auto;
eapply ok_Hyb_used_weakening in H5; eauto.
Qed.

(* ok_Hyb for a specific type -- would be nice to make it more general btw *)

Add Morphism (@ok_Hyb (list (var*ty))) : ok_Hyb_PPermut_Hyb_lst_var_ty.
split; intros;
[apply ok_Hyb_used_permut with (U:=x0); auto |
 apply ok_Hyb_used_permut with (U:=y0); [symmetry | ]; auto];
generalize dependent y0; generalize dependent x0;
induction H; intros; auto using ok_Hyb.
inversion H1; subst; constructor; auto;
eapply IHPPermut_Hyb; auto.
inversion H1; subst; inversion H8; subst;
constructor;
[intro; elim H9; rewrite Mem_cons_eq; right; auto | ];
constructor.
intro; rewrite Mem_cons_eq in H3; elim H9; destruct H3; subst.
  elim H9; rewrite Mem_cons_eq; left; auto. contradiction.
  apply ok_Hyb_used_permut with (U:=w'::w::y0); auto.
  permut_simpl; symmetry; auto.
  apply ok_Hyb_used_permut with (U:=(w'::w::x0)); auto.
eapply IHPPermut_Hyb2; eauto; eapply IHPPermut_Hyb1; auto.
inversion H2; subst; constructor; auto;
eapply IHPPermut_Hyb; auto.
inversion H2; subst; inversion H8; subst;
constructor;
[intro; elim H9; rewrite Mem_cons_eq; right; auto | ];
constructor.
intro; rewrite Mem_cons_eq in H3; elim H9; destruct H3; subst.
  elim H9; rewrite Mem_cons_eq; left; auto. contradiction.
  apply ok_Hyb_used_permut with (U:=w::w'::y0); auto.
  permut_simpl; symmetry; auto.
eapply IHPPermut_Hyb1; eauto; eapply IHPPermut_Hyb2; auto.
Qed.

Lemma ok_Hyb_permut_any0:
forall X (G1: list (var * X)) G2 U,
  G1 *=* G2 ->
  ok_Hyb G1 U ->
  ok_Hyb G2 U.
intro A.
induction G1; intros.
apply permut_nil_eq in H; subst; auto.
destruct a. inversion H0; subst.
assert ((v, a)::G1 *=* G2) by auto.
apply permut_split_head in H.
destruct H as (hd, (tl, H)).
assert (G1 *=* hd ++ tl).
  apply permut_cons_inv with (a:=(v, a)); rewrite H1; subst; permut_simpl.
specialize IHG1 with (G2:=hd++tl).
apply IHG1 in H6; auto.
subst; generalize dependent G1; generalize dependent U;
induction hd; intros; rew_app in *.
constructor; auto.
destruct a0. inversion H6; subst. constructor.
intro; elim H8; rewrite Mem_cons_eq; right; auto.
apply IHhd with (G1:=hd++tl); try permut_simpl.
intro n; elim H8; rewrite Mem_cons_eq in n; destruct n; rewrite Mem_cons_eq;
[left; subst; auto | contradiction].
apply ok_Hyb_used_permut with (U:=v0::v::U); [permut_simpl | auto].
intros; auto.
constructor.
intro; elim H8; rewrite Mem_cons_eq; rewrite Mem_cons_eq in H; destruct H;
subst. left; auto. contradiction.
apply ok_Hyb_used_permut with (U:=v0::v::U); [permut_simpl | auto].
Qed.

Lemma ok_Hyb_permut_any:
forall X (G: list (var * X)) G',
  G *=* G' ->
  forall U, ok_Hyb G U <-> ok_Hyb G' U.
split; intros; [ | symmetry in H]; eapply ok_Hyb_permut_any0; eauto.
Qed.

Lemma ok_Hyb_PPermut_Hyb_ty:
forall G G'
  (H: G ~=~ G'),
  forall U, ok_Hyb (flat_map snd_ G) U <->
  ok_Hyb (flat_map snd_ G') U.
intros; eapply ok_Hyb_permut_any; apply flat_map_PPermut_Hyb; auto.
Qed.

Lemma ok_Hyb_fresh_te_list:
forall G Gamma v A w U,
 ok_Hyb ((w, Gamma) :: G) U ->
 v \notin (used_t_vars_Hyb ((w,Gamma)::G)) ->
 ok_Hyb ((w, (v,A)::Gamma) :: G) U.
intros; inversion H; subst; constructor; auto.
Qed.

Lemma ok_Hyb_merge_contexts:
forall (G: list (var * list (var * ty))) U l1 l2 (w: var) w' w'',
  ok_Hyb (flat_map snd_ ((w,l1)::(w',l2)::G)) U <->
  ok_Hyb (flat_map snd_ ((w'', l1++l2)::G)) U.
split; intros; simpl in *; rew_app in *; auto.
Qed.

Lemma ok_Hyb_fresh_te_ty0:
forall G U w v A,
  ok_Hyb (flat_map snd_ G) U ->
  v \notin (used_t_vars_Hyb G \u from_list U) ->
  ok_Hyb (flat_map snd_ ((w, (v, A)::nil) :: G)) U.
induction G; intros.
simpl in *; constructor; [apply notin_Mem | constructor]; auto.
eapply ok_Hyb_PPermut_Hyb_ty with (G':=a:: (w, (v,A)::nil)::G).
PPermut_Hyb_simpl. destruct a; simpl in *; rew_app in *.
generalize dependent U.
induction l; intros; simpl in *.
rew_app in *; apply IHG; eauto.
destruct a.
rew_app in *; inversion H; subst.
constructor; auto.
apply IHl; auto.
simpl in *; rew_map in *; simpl in *; rewrite from_list_cons in *;
repeat rewrite notin_union in *; destruct H0; destruct H0; destruct H0;
repeat split; auto.
Qed.

Lemma ok_Hyb_fresh_te_ty:
forall Gamma G U v A w,
 ok_Hyb (flat_map snd_ ((w, Gamma) :: G)) U ->
 v \notin (used_t_vars_Hyb ((w, Gamma)::G) \u from_list U) ->
 ok_Hyb (flat_map snd_ ((w, (v, A)::Gamma) :: G)) U.
intros; simpl in *.
replace (((v,A) :: Gamma) ++ flat_map snd_ G) with
  ((flat_map snd_ ((w,(v,A)::nil)::((w,Gamma)::G)))) by (simpl; auto).
apply ok_Hyb_fresh_te_ty0; auto.
Qed.

Lemma ok_Hyb_fresh_wo_list:
forall G w U l,
 ok_Hyb G U ->
 w \notin (used_w_vars_Hyb G)  \u from_list U ->
 ok_Hyb ((w, l) :: G) U.
induction G; intros.
constructor.
  apply notin_Mem; auto.
  constructor.
destruct a; inversion H; subst; constructor.
  apply notin_Mem;
  rewrite notin_union in H0; destruct H0; auto.
  constructor.
  rewrite Mem_cons_eq; intro; destruct H1; subst.
  simpl in H0; repeat rewrite notin_union in H0; destruct H0;
  destruct H0; rewrite notin_singleton in H0; elim H0; auto.
  contradiction.
apply ok_Hyb_used_permut with (U:=w::v::U).
permut_simpl.
assert (ok_Hyb ((w, l) :: G) (v::U)).
apply IHG; auto.
simpl in *; repeat rewrite notin_union in H0;
rewrite from_list_cons; repeat rewrite notin_union;
destruct H0; destruct H0; split; auto; split; auto.
inversion H1; subst; auto.
Qed.

Lemma ok_Hyb_fresh_wo_ty:
forall G w U,
 ok_Hyb (flat_map snd_ G) U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 ok_Hyb (flat_map snd_ ((w, nil) :: G)) U.
intros; inversion H; subst; simpl in *; rew_app in *; auto.
Qed.

Lemma ok_Hyb_fresh_wo_te_list:
forall U G v A w,
 ok_Hyb G U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 v \notin (used_t_vars_Hyb G) ->
 ok_Hyb ((w, (v,A)::nil) :: G) U.
intros; apply ok_Hyb_fresh_te_list;
[ apply ok_Hyb_fresh_wo_list | ]; auto.
simpl; rewrite map_nil; rewrite from_list_nil; rewrite union_empty_l; auto.
Qed.

Lemma ok_Hyb_fresh_wo_te_ty:
forall U G v A w,
 ok_Hyb (flat_map snd_ G) U ->
 w \notin (used_w_vars_Hyb G) \u from_list U ->
 v \notin (used_t_vars_Hyb G) \u from_list U ->
 ok_Hyb (flat_map snd_ ((w, (v,A) :: nil) :: G)) U.
intros; apply ok_Hyb_fresh_te_ty.
apply ok_Hyb_fresh_wo_ty; auto.
simpl; rewrite map_nil; rewrite from_list_nil; rewrite union_empty_l; auto.
Qed.

Lemma ok_Hyb_empty_first_list:
forall w G Gamma U,
  ok_Hyb ((w,Gamma) :: G) U ->
  ok_Hyb ((w, (@nil (prod var ty))) :: G) U.
intros; simpl in *; inversion H; subst; constructor; auto.
Qed.

Lemma ok_Hyb_empty_first_ty:
forall Gamma (w: var) G U,
  (@ok_Hyb ty (flat_map snd_ ((w,Gamma) :: G)) U) ->
  (@ok_Hyb ty (flat_map snd_ ((w, nil) :: G)) U).
induction Gamma; intros; simpl in *; auto; destruct a;
rew_app in H; inversion H; subst.
apply IHGamma; auto.
apply ok_Hyb_used_weakening with (x:=v); auto.
Qed.

(* ok_Bg_Hyb *)

Add Morphism ok_Bg_Hyb : ok_Bg_Hyb_PPermut_Hyb.
intros; unfold ok_Bg_Hyb; split; intros;
destruct H0; split;
[ rewrite <- H | |
  rewrite H | eapply ok_Hyb_PPermut_Hyb_ty; try symmetry ]; eauto.
assert (x ~=~y) by auto; eapply flat_map_PPermut_Hyb in H;
eapply ok_Hyb_PPermut_Hyb_ty;
try symmetry; eauto.
assert (x ~=~ y) by auto; eapply flat_map_PPermut_Hyb in H;
eapply ok_Hyb_PPermut_Hyb_ty;
eauto.
Qed.

Lemma ok_Bg_Hyb_ppermut:
forall G G',
  G ~=~ G' ->
  ok_Bg_Hyb G ->
  ok_Bg_Hyb G'.
intros; rewrite <- H; auto.
Qed.

Lemma ok_Bg_Hyb_permut:
forall G Ctx Ctx' w,
  Ctx *=* Ctx' ->
  ok_Bg_Hyb ((w, Ctx) :: G) ->
  ok_Bg_Hyb ((w, Ctx') :: G).
intros;
assert ((w, Ctx) :: G ~=~ (w, Ctx') :: G) by PPermut_Hyb_simpl;
rewrite <- H1; auto.
Qed.

Lemma ok_Bg_Hyb_permut_last:
forall G Ctx Ctx' w,
  Ctx *=* Ctx' ->
  ok_Bg_Hyb (G ++ (w, Ctx) :: nil) ->
  ok_Bg_Hyb (G ++ (w, Ctx') :: nil).
intros;
assert (G & (w, Ctx) ~=~ G & (w, Ctx')) by PPermut_Hyb_simpl;
rewrite <- H1; auto.
Qed.

Lemma ok_Bg_Hyb_fresh_te:
forall G Gamma v A w,
 ok_Bg_Hyb ((w, Gamma) :: G) ->
 v \notin (used_t_vars_Hyb ((w,Gamma)::G)) ->
 ok_Bg_Hyb ((w, (v,A)::Gamma) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ apply ok_Hyb_fresh_te_list |
  apply ok_Hyb_fresh_te_ty]; auto.
rewrite from_list_nil. rewrite notin_union; split; auto; rewrite notin_empty.
Qed.

Lemma ok_Bg_Hyb_fresh_wo:
forall G w,
 ok_Bg_Hyb G ->
 w \notin (used_w_vars_Hyb G) ->
 ok_Bg_Hyb ((w, nil) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ eapply ok_Hyb_fresh_wo_list |
  eapply ok_Hyb_fresh_wo_ty]; eauto;
rewrite from_list_nil; rewrite union_empty_r; auto.
Qed.

Lemma ok_Bg_Hyb_fresh_wo_te:
forall G w v A,
 ok_Bg_Hyb G ->
 w \notin (used_w_vars_Hyb G) ->
 v \notin (used_t_vars_Hyb G) ->
 ok_Bg_Hyb ((w, (v, A) :: nil) :: G).
intros; unfold ok_Bg_Hyb in *;  destruct H; split;
[ apply ok_Hyb_fresh_wo_te_list |
  apply ok_Hyb_fresh_wo_te_ty]; eauto;
rewrite from_list_nil; rewrite union_empty_r; auto.
Qed.

Lemma ok_Bg_Hyb_cons_last:
forall G a,
  ok_Bg_Hyb (G & a) <-> ok_Bg_Hyb (a :: G).
intros; assert (G & a ~=~ a :: G) by PPermut_Hyb_simpl;
rewrite H; split; auto.
Qed.

Lemma ok_Bg_Hyb_swap:
forall C C' G,
  ok_Bg_Hyb (C :: G & C') ->
  ok_Bg_Hyb (C' :: G & C).
intros; assert (C:: G & C' ~=~ C' :: G & C) by PPermut_Hyb_simpl;
rewrite <- H0; auto.
Qed.

Hint Resolve ok_Bg_Hyb_cons_last ok_Bg_Hyb_swap.
Hint Resolve ok_Bg_Hyb_permut_last: ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_fresh_te ok_Bg_Hyb_fresh_wo ok_Bg_Hyb_fresh_wo_te.

Lemma ok_Bg_Hyb_permut_first_tail:
forall G C C' w x A,
  ok_Bg_Hyb ((w, C) :: G) ->
  C *=* (x,A)::C' ->
  ok_Bg_Hyb ((w, C') :: G).
intros;
assert ((w,(x, A) :: C') :: G ~=~ (w, C) :: G) by PPermut_Hyb_simpl;
rewrite <- H1 in H; unfold ok_Bg_Hyb in *; destruct H; split; simpl in *.
inversion H; subst; constructor; auto.
rew_app in *; inversion H2; subst; simpl in *.
apply ok_Hyb_used_weakening with (x:=x); auto.
Qed.
Hint Resolve ok_Bg_Hyb_permut_first_tail : ok_bg_hyb_rew.

Lemma ok_Bg_Hyb_empty_first:
forall w G Gamma,
  ok_Bg_Hyb ((w,Gamma) :: G) ->
  ok_Bg_Hyb ((w, nil) :: G).
intros; unfold ok_Bg_Hyb; destruct H; split;
[eapply ok_Hyb_empty_first_list |
 eapply ok_Hyb_empty_first_ty]; eauto.
Qed.

Hint Resolve ok_Bg_Hyb_empty_first : ok_bg_hyb_rew.

Lemma ok_Bg_Hyb_Mem_eq:
forall w C C' v A A0 G,
  ok_Bg_Hyb ((w, C) :: G) ->
  C *=* (v, A) :: C' ->
  Mem (v, A0) C ->
  A0 = A.
intros; destruct (eq_ty_dec A0 A); auto;
assert (exists gh, exists gt, C' = gh & (v, A0) ++ gt) by
  ( apply permut_neq_split with (b := (v, A)) (l1 := C); auto;
    intro HH; inversion HH; subst; elim n; auto);
destruct H2 as (gh); destruct H2 as (gt); subst;
assert (C *=* (v, A) :: (v, A0) :: gh ++ gt) by (rewrite H0; permut_simpl);
unfold ok_Bg_Hyb in *; destruct H.
assert (ok_Hyb (flat_map snd_ ((w, (v, A) :: (v, A0) :: gh ++ gt ) :: G )) nil)
by
  (apply ok_Hyb_PPermut_Hyb_ty with (G := ((w, C) :: G));
   [PPermut_Hyb_simpl | auto]).
simpl in *. rew_app in *; inversion H4; subst.
inversion H10; subst;
elim H11; apply Mem_here.
Qed.

Lemma ok_Bg_Hyb_Mem_contradict:
forall A A' w w' v C C' G G',
 ok_Bg_Hyb ((w, C) :: G) ->
 Mem (v, A) C ->
 G ~=~ G' & (w', (v, A') :: C') ->
 False.
intros.
rewrite H1 in H.
apply permut_Mem_split_head with (l2 := C) in H0; auto;
destruct H0 as (gh); destruct H0 as (gt); subst.
assert ((w, gh & (v, A) ++ gt) :: G' & (w', (v, A') :: C') ~=~
        (w, (v, A) :: gh ++ gt) :: (w', (v, A') :: C') :: G') by
(PPermut_Hyb_simpl; apply PPermut_Hyb_skip; [permut_simpl | auto]).
rewrite H0 in H; unfold ok_Bg_Hyb in H; destruct H.
rew_flat_map in *. simpl ok_Hyb in H2.
rew_app in *. inversion H2; subst.
assert (ok_Hyb ((v, A') :: C' ++ flat_map snd_ G') (v :: nil)).
  eapply ok_Hyb_split with (G1:=flat_map snd_ ((w, gh++gt)::nil)); simpl;
  rew_app; auto.
inversion H3; subst; elim H10; apply Mem_here.
Qed.

Lemma ok_Bg_Hyb_permut_no_last:
forall G w C v A,
  ok_Bg_Hyb (G & (w, (v,A) :: C)) ->
  ok_Bg_Hyb (G & (w, C)).
intros;
assert (G & (w, C) ~=~ (w,C) :: G) by PPermut_Hyb_simpl;
assert (G & (w, (v, A) :: C) ~=~ (w, (v,A) :: C) :: G) by PPermut_Hyb_simpl;
rewrite H1 in H; destruct H; simpl in *; split; rew_app in *.
inversion H; subst; rewrite H0; constructor; auto.
inversion H2; subst;
apply ok_Hyb_PPermut_Hyb_ty with (U:=nil) in H0;
apply H0; simpl;
apply ok_Hyb_used_weakening in H8;
auto.
Qed.

Lemma ok_Bg_Hyb_permut_no_last_spec:
forall G w C C0 v A,
  ok_Bg_Hyb (C0::G & (w, (v,A) :: C)) ->
  ok_Bg_Hyb (C0::G & (w, C)).
intros;
assert (C0 :: G & (w, C)  ~=~ (C0 :: G) & (w, C))
  by (rew_app; PPermut_Hyb_simpl);
rewrite H0; eapply ok_Bg_Hyb_permut_no_last; rew_app; eauto.
Qed.

Lemma ok_Bg_Hyb_no_last:
forall G C,
  ok_Bg_Hyb (G & C) -> ok_Bg_Hyb G.
intros;
assert (G & C ~=~ (C :: nil) ++ G) by PPermut_Hyb_simpl; rewrite H0 in H;
destruct H; split.
eapply ok_Hyb_split with (G1:=C::nil) (G2:=G); eauto.
destruct C; rew_app in *; simpl in *.
eapply ok_Hyb_split with (G1:=l) (G2:=flat_map snd_  G); auto.
Qed.
Hint Resolve ok_Bg_Hyb_no_last.

Lemma ok_Bg_Hyb_permut_no_last_spec2:
forall G w C C0 v A,
  ok_Bg_Hyb (G & (w, (v,A) :: C) & C0) ->
  ok_Bg_Hyb (G & (w, C) & C0).
intros.
assert (G & (w, C) & C0 ~=~ G & C0 & (w, C)) by PPermut_Hyb_simpl;
rewrite H0;
apply ok_Bg_Hyb_permut_no_last with (v:=v) (A:=A).
assert (G & C0 & (w, (v, A) :: C) ~=~ G & (w, (v, A) :: C) & C0)
  by PPermut_Hyb_simpl;
rewrite H1; auto.
Qed.

Lemma ok_Bg_Hyb_first_last_neq:
forall w w' C C' G,
  ok_Bg_Hyb ((w, C) :: G & (w', C')) ->
  w <> w'.
intros.
assert ((w, C) :: G & (w', C') ~=~ (w, C) :: (w', C') :: G)
  by PPermut_Hyb_simpl;
rewrite H0 in H;
destruct H; simpl in *. inversion H; subst; inversion H7; subst.
rewrite Mem_cons_eq in H8. rewrite Mem_nil_eq in H8. auto.
Qed.

Lemma ok_Bg_Hyb_last_last2_neq:
forall w w' C C' G,
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  w <> w'.
intros;
assert (G & (w, C) & (w', C') ~=~ (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl;
rewrite H0 in H;
destruct H; simpl in *; inversion H; subst; inversion H7; subst.
rewrite Mem_cons_eq in H8. rewrite Mem_nil_eq in H8; auto.
Qed.

Lemma ok_Bg_Hyb_swap_worlds:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w', C) & (w, C')).
intros.
assert (G & (w, C) & (w', C') ~=~ (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
rewrite H0 in H.
assert (G & (w', C) & (w, C') ~=~ (w', C) :: (w, C') :: G) by PPermut_Hyb_simpl.
rewrite H1.
destruct H; split; simpl in *.
inversion H; subst; constructor. rewrite Mem_nil_eq; tauto.
inversion H8; subst; constructor.
rewrite Mem_cons_eq in *; intro; destruct H3; subst;
[ elim H9; left | rewrite Mem_nil_eq in H3 ]; auto.
apply ok_Hyb_used_permut with (U := w'::w::nil); [permut_simpl | ]; auto.
auto.
Qed.

Lemma ok_Bg_Hyb_impl_ppermut:
forall G G' w C C',
  ok_Bg_Hyb ((w, C) :: G) ->
  G & (w, C) ~=~ G' & (w, C') ->
  G ~=~ G' /\ C *=* C'.
unfold ok_Bg_Hyb.
intros. destruct H.
assert ((w,C) :: G ~=~ (w, C') :: G').
  transitivity (G & (w,C)); [ | rewrite H0]; PPermut_Hyb_simpl.
apply PPermut_Hyb_split_head in H2.
destruct H2 as (C'', (hd, (tl, (H2, H3)))).
assert ((w, C') :: G' = hd & (w, C'') ++ tl) by auto.
apply cons_eq_last_val_app_inv in H4; destruct H4.
(* case 1: positive - hd = nil and C *=* C'' *)
destruct H4; destruct H5; subst; rew_app in *;
inversion H3; subst; split; auto;
apply PPermut_Hyb_last_rev with (Gamma:=C)(Gamma':=C'')(w:=w); auto.
(* case 2: negative *)
destruct H4 as (hd', H4); subst.
assert ((w, C) :: G ~=~ (w, C') :: (w, C'') :: hd' ++ tl).
  transitivity (G & (w,C)). PPermut_Hyb_simpl.
  rewrite H0; transitivity ((w, C') :: G'); [ | rewrite H3];
  PPermut_Hyb_simpl.
rewrite H4 in H; inversion H; subst; inversion H10; subst.
elim H11; apply Mem_here.
Qed.

(* FIXME: generalize all the ok_Bg_Hyb_split* into :
   ok_Bg_Hyb G <- ok_Bg_Hyb reorder_G <- ok_Bg_Hyb reorder_G' <- ok_Bg_Hyb G':
   reorder X ~=~ X and all the singletons are in the front *)

Lemma ok_Bg_Hyb_split1:
forall G w w' C C',
  ok_Bg_Hyb ((w,C)::G & (w',C')) ->
  ok_Bg_Hyb ((w, C ++ C') :: G).
intros.
assert ((w, C) :: G & (w', C') ~=~ (w,C) :: (w', C')::G) by PPermut_Hyb_simpl.
rewrite H0 in H; destruct H; split; simpl in *.
inversion H; subst; inversion H7; subst; constructor; auto;
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split2:
forall G w w' C C',
  ok_Bg_Hyb ((w,C)::G & (w',C')) ->
  ok_Bg_Hyb ((w', C' ++ C) :: G).
intros.
assert ((w, C) :: G & (w', C') ~=~ (w', C') :: (w, C)::G) by PPermut_Hyb_simpl.
rewrite H0 in H; destruct H; split; simpl in *.
inversion H; subst; inversion H7; subst;
constructor; auto.
apply ok_Hyb_used_weakening with (x:=w); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split3:
forall G w w' w'' C C' C'',
  ok_Bg_Hyb ((w,C)::G & (w',C') & (w'',C'')) ->
  ok_Bg_Hyb ((w, C) :: G & (w', C' ++ C'')).
intros.
assert ((w, C) :: G & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert ((w,C) :: G & (w', C'++C'') ~=~ (w,C) :: (w', C'++C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst;
constructor; auto; constructor; auto.
apply ok_Hyb_used_weakening with (x:=w''); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split4:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w', C' ++ C)).
intros.
assert (G & (w, C) & (w', C') ~=~
  (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
assert (G & (w', C'++C) ~=~ (w', C'++C) :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split.
simpl in *; inversion H; subst; inversion H8; subst; constructor; auto.
rewrite Mem_nil_eq; tauto.
apply ok_Hyb_used_weakening with (x:=w);
apply ok_Hyb_used_permut with (U:= w'::w::nil);
try permut_simpl; auto.
assert ((w', C'++C)::G ~=~ (w',C++C')::G) by PPermut_Hyb_simpl.
apply ok_Hyb_PPermut_Hyb_ty with (U:=nil) in H3.
simpl in *; rew_app in *.
apply H3. auto.
Qed.

Lemma ok_Bg_Hyb_split5:
forall G w w' C C',
  ok_Bg_Hyb (G & (w, C) & (w', C')) ->
  ok_Bg_Hyb (G & (w, C ++ C')).
intros.
assert (G & (w, C) & (w', C') ~=~
  (w, C) :: (w', C') :: G) by PPermut_Hyb_simpl.
assert (G & (w, C++C') ~=~ (w, C++C') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst.
constructor; auto;
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split6:
forall G w C C' C'' w' w'',
  ok_Bg_Hyb (G & (w, C) & (w', C') & (w'', C'')) ->
  ok_Bg_Hyb (G & (w, C ++ C') & (w'', C'')).
intros.
assert (G & (w,C) & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert (G & (w, C++C') & (w'', C'') ~=~ (w, C ++ C') :: (w'', C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor; auto.
apply ok_Hyb_used_weakening with (x:=w'); auto.
rew_app; auto.
Qed.

Lemma ok_Bg_Hyb_split8:
forall G G' w w' w'' C C' C'',
  ok_Bg_Hyb (G ++ G' ++ (w, C) :: (w', C') :: (w'', C'') :: nil) ->
  ok_Bg_Hyb (G ++ G' ++ (w', C') :: (w'', C'' ++ C)::nil) .
intros.
assert (G++G' ++ (w, C) :: (w', C') :: (w'',C'') :: nil ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G ++ G') by PPermut_Hyb_simpl.
assert (G ++ G' ++ (w', C') :: (w'', C'' ++ C) :: nil ~=~
  (w', C') :: (w'', C''++C) :: G ++ G')
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split.
simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor.
intro; rewrite Mem_nil_eq in H3; auto.
constructor.
intro; elim H11; rewrite Mem_cons_eq in *; destruct H3.
left; auto.
rewrite Mem_nil_eq in H3; auto.
contradiction.
apply ok_Hyb_used_weakening with (x:=w);
apply ok_Hyb_used_permut with (U:=w'' :: w' :: w :: nil);
auto; permut_simpl.
apply ok_Hyb_PPermut_Hyb_ty with
  (G':=(w',C') :: (w'', C'')::(w,C) :: G ++ G') in H2.
simpl in *.
rew_app. auto.
PPermut_Hyb_simpl.
Qed.

Lemma ok_Bg_Hyb_split9:
forall G w w' w'' C C' C'',
  ok_Bg_Hyb ((w,C)::G & (w',C') & (w'',C'')) ->
  ok_Bg_Hyb ((w, C++C') :: G & (w'', C'')).
intros.
assert ((w, C) :: G & (w', C') & (w'',C'') ~=~
  (w, C) :: (w', C'):: (w'',C'') :: G) by PPermut_Hyb_simpl.
assert ((w, C++C') :: G & (w'', C'')  ~=~
  (w, C++C') :: (w'', C'') :: G)
  by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst.
constructor; auto; constructor.
intro; rewrite Mem_cons_eq in *. destruct H3; subst.
elim H11;right; apply Mem_here.
rewrite Mem_nil_eq in H3; auto.
apply ok_Hyb_used_weakening with (x:=w');
apply ok_Hyb_used_permut with (U:=w'' :: w' :: w :: nil);
auto; permut_simpl.
rew_app. auto.
Qed.

Lemma ok_Bg_Hyb_split10:
forall G G' w1 w2 w3 w4 c1 c2 c3 c4,
  ok_Bg_Hyb (G ++ (w1, c1)::G' ++ (w2, c2) :: (w3, c3) :: (w4, c4) :: nil) ->
  ok_Bg_Hyb (G ++ (w1, c1)::G' ++ (w2, c2 ++ c3) :: (w4, c4) :: nil).
intros.
assert (G ++ (w1,c1) :: G' ++ (w2, c2) :: (w3, c3) :: (w4,c4) :: nil ~=~
   (w1,c1) :: (w2, c2) :: (w3, c3) :: (w4,c4) :: G ++ G') by PPermut_Hyb_simpl.
assert (G ++ (w1, c1) :: G' ++ (w2, c2 ++ c3) :: (w4, c4) :: nil~=~
   (w1,c1) :: (w2, c2 ++ c3) :: (w4,c4) :: G ++ G') by PPermut_Hyb_simpl.
rewrite H0 in H; rewrite H1; destruct H; split; simpl in *.
inversion H; subst; inversion H8; subst; inversion H10; subst;
inversion H12; subst.
constructor; auto; constructor; auto; constructor.
intro; rewrite Mem_cons_eq in *. destruct H3; subst.
elim H13; right; left; auto.
rewrite Mem_cons_eq in H3; destruct H3; subst.
elim H13; right; rewrite Mem_cons_eq; right; rewrite Mem_cons_eq; left; auto.
rewrite Mem_nil_eq in H3; auto.
apply ok_Hyb_used_weakening with (x:=w3);
apply ok_Hyb_used_permut with (U:=w4 :: w3 :: w2 :: w1 :: nil);
auto; permut_simpl.
rew_app; auto.
Qed.

Hint Resolve ok_Bg_Hyb_split1 ok_Bg_Hyb_split2 ok_Bg_Hyb_split3 ok_Bg_Hyb_split4
  ok_Bg_Hyb_split5 ok_Bg_Hyb_split6 ok_Bg_Hyb_split8
  ok_Bg_Hyb_split9 ok_Bg_Hyb_split10 : ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_permut_no_last ok_Bg_Hyb_permut_no_last_spec2
  ok_Bg_Hyb_permut_no_last_spec ok_Bg_Hyb_first_last_neq
  ok_Bg_Hyb_last_last2_neq : ok_bg_hyb_rew.
Hint Resolve ok_Bg_Hyb_swap_worlds.

Lemma ok_Hyb_not_Mem_fst:
forall (G: bg_Hyb) U w,
  ok_Hyb G U -> Mem w U ->
  ~ Mem w (map fst_ G) .
induction G; intros; simpl in *.
rewrite Mem_nil_eq; auto.
destruct a; rew_map; simpl; rewrite Mem_cons_eq; intro; destruct H1; subst.
inversion H; subst; auto; inversion H; subst. apply IHG in H0;
[ contradiction | ]; inversion H; subst; apply ok_Hyb_used_weakening in H7;
auto.
Qed.

Close Scope permut_scope.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

(** Instances of [Below] for the standard datatypes. To be used by
   [equations] when it needs to do recursion on a type. *)

Require Import Bvector.
Require Import Vectors.Vector.
Require Import Equations.Init Equations.CoreTactics Equations.Prop.DepElim Equations.Prop.Tactics
        Equations.Prop.Constants.
Require Import Equations.Prop.FunctionalInduction.

(** The [BelowPackage] class provides the definition of a [Below] predicate for some datatype,
   allowing to talk about course-of-value recursion on it. *)

Class BelowPackage (A : Type) := {
  Below : A -> Type ;
  below : forall (a : A), Below a }.

(** The [Recursor] class defines a recursor on a type *)

Class Recursor (A : Type) :=
  { rec_type : forall x : A, Type ; rec : forall x : A, rec_type x }.

(** Support simplification of unification constraints appearing in the goal
   and the hypothesis. *)

#[local] Hint Extern 0 (_ = _) => reflexivity : Below.

Ltac simpl_let :=
  match goal with
    [ H : let _ := ?t in _ |- _ ] =>
    match t with
    | fixproto => fail 1
    | _ => cbv zeta in H
    end
  end.

#[local] Hint Extern 40 => progress (cbv beta in * || simpl_let) : Below.

(** Use it as well as the [equations] simplifications. *)

Ltac unfold_equations ::= repeat progress autounfold with equations Below.
Ltac unfold_equations_in H ::= repeat progress autounfold with equations Below in H.

Ltac destruct_conj :=
  match goal with
    [ H : (_ * _)%type |- _ ] => destruct H
  end.

(** Simplify [Below] hyps for proof search. *)

#[local] Hint Extern 2 => progress (autorewrite with Below in * ;
  destruct_conj ; simplify_IH_hyps) : Below.

(** When solving goals with recursive prototypes in them, we allow an application
   only if it keeps the proof guarded (FIXME, guarded doesn't work). *)

Ltac apply_fix_proto :=
  match goal with
  | [ f : let _ := fixproto in _ |- _ ] => apply f
  end.

#[local] Hint Extern 100 => apply_fix_proto : Below.

(** We now derive standard Below instances. *)

Derive Below for nat.

Definition rec_nat (P : nat -> Type) n (step : forall n, Below_nat P n -> P n) : P n :=
  step n (below_nat P step n).

#[export]
Instance nat_Recursor : Recursor nat :=
  { rec_type := fun n => forall P step, P n ;
    rec := fun n P step => rec_nat P n step }.

Notation vector := Vector.t.
Import Vector.
Arguments nil {A}.
Arguments cons {A} _ {n}.

Open Scope equations_scope.

Import EquationsNotations.

Equations Below_vector A (P : forall n, vector A n -> Type) n (v : vector A n) : Type
  by struct v :=
Below_vector A P ?(0) [] := unit ;
Below_vector A P _ (a :: v) :=
  ((P _ v) * Below_vector A P _ v)%type.

#[local] Hint Rewrite Below_vector_equation_2 : Below.

Ltac rec_fast v recname := intro_block v ; move v at top ;
  generalize_by_eqs_vars v ; (intros until v || revert_until v) ;
    let recv := eval simpl in (rec v) in
    (eapply recv || (dependent pattern v ; refine (recv _ _))) ;
    clear -recname ;
    intros until 1 ; on_last_hyp ltac:(fun x => rename x into recname) ;
      simpl in * ; simplify_dep_elim ; intros ; unblock_goal ; intros ;
        (try move recname at bottom) ;
        add_pattern (hide_pattern recname).

(* Ltac rec_debug v recname := intro_block v ; move v at top ; *)
(*   generalize_by_eqs_vars v ; (intros until v || revert_until v) ; *)
(*     let recv := eval simpl in (rec v) in show_goal ;  *)
(*     (eapply recv || (dependent pattern v ; refine (recv _ _))) ; show_hyps ; idtac "before clear"; *)
(*     clear_except recname ;  *)
(*     intros until 1 ; on_last_hyp ltac:(fun x => rename x into recname) ; *)
(*     idtac "after clear"; *)
(*     show_hyps ; show_goal ; simpl in * ; simplify_dep_elim ; intros ; unblock_goal ; intros ; *)
(*       add_pattern (hide_pattern recname). *)

Ltac rec recname v := rec_fast v recname.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst.

Require Import ssreflect.
Require Import Equations.Prop.DepElim.
From Equations.Type Require Import Relation Relation_Properties.
From Equations Require Import Equations.
Set Equations Transparent.
Set Default Goal Selector "!".

Notation rtrans_clos := clos_refl_trans_n1.

Lemma All2_many_OnOne2 :
  forall A (R : A -> A -> Type) l l',
    All2 R l l' ->
    rtrans_clos (OnOne2 R) l l'.
Proof.
  intros A R l l' h.
  induction h.
  - constructor.
  - econstructor.
    + constructor. eassumption.
    + clear - IHh. rename IHh into h.
      induction h.
      * constructor.
      * econstructor.
        -- econstructor 2. eassumption.
        -- assumption.
Qed.

Definition tDummy := tVar String.EmptyString.
Definition dummy_branch : branch term := mk_branch [] tDummy.

(** ** Reduction *)

(** *** One step strong beta-zeta-iota-fix-delta reduction

  Inspired by the reduction relation from Coq in Coq [Barras'99].
*)

Arguments OnOne2 {A} P%type l l'.

Definition set_pcontext (p : predicate term) (pctx' : context) : predicate term :=
  {| pparams := p.(pparams);
      puinst := p.(puinst);
      pcontext := pctx';
      preturn := p.(preturn) |}.

Definition set_pcontext_two {p x} x' :
  set_pcontext (set_pcontext p x') x = set_pcontext p x :=
  eq_refl.

Definition set_preturn (p : predicate term) (pret' : term) : predicate term :=
  {| pparams := p.(pparams);
      puinst := p.(puinst);
      pcontext := p.(pcontext);
      preturn := pret' |}.

Definition set_preturn_two {p} pret pret' : set_preturn (set_preturn p pret') pret = set_preturn p pret :=
  eq_refl.

Definition set_pparams (p : predicate term) (pars' : list term) : predicate term :=
  {| pparams := pars';
     puinst := p.(puinst);
     pcontext := p.(pcontext);
     preturn := p.(preturn) |}.

Definition set_pparams_two {p pars} pars' : set_pparams (set_pparams p pars') pars = set_pparams p pars :=
  eq_refl.

Definition map_decl_na (f : aname -> aname) (g : term -> term) d :=
  {| decl_name := f (decl_name d);
     decl_body := option_map g (decl_body d);
     decl_type := g (decl_type d) |}.

(** We do not allow alpha-conversion and P applies to only one of the
  fields in the context declaration. Used to define one-step context reduction. *)
Definition on_one_decl (P : context -> term -> term -> Type)
  Γ (d : context_decl) (d' : context_decl) : Type :=
  match d, d' with
  | {| decl_name := na; decl_body := None; decl_type := ty |},
    {| decl_name := na'; decl_body := None; decl_type := ty' |} =>
      na = na' × P Γ ty ty'
  | {| decl_name := na; decl_body := Some b; decl_type := ty |},
    {| decl_name := na'; decl_body := Some b'; decl_type := ty' |} =>
      na = na' ×
      ((P Γ ty ty' × b = b') +
        (P Γ b b' × ty = ty'))
  | _, _ => False
  end.

Lemma on_one_decl_impl (P Q : context -> term -> term -> Type) :
  (forall Γ, inclusion (P Γ) (Q Γ)) ->
  forall Γ, inclusion (on_one_decl P Γ) (on_one_decl Q Γ).
Proof.
  intros HP Γ x y.
  destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl; firstorder auto.
Qed.

Lemma on_one_decl_map_na (P : context -> term -> term -> Type) f g :
  forall Γ,
    inclusion (on_one_decl (fun Γ => on_Trel (P (map (map_decl_na f g) Γ)) g) Γ)
    (on_Trel (on_one_decl P (map (map_decl_na f g) Γ)) (map_decl_na f g)).
Proof.
  intros Γ x y.
  destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl;
    auto.
Qed.

Lemma on_one_decl_map (P : context -> term -> term -> Type) f :
  forall Γ,
    inclusion (on_one_decl (fun Γ => on_Trel (P (map (map_decl f) Γ)) f) Γ)
    (on_Trel (on_one_decl P (map (map_decl f) Γ)) (map_decl f)).
Proof.
  intros Γ x y.
  destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl;
    auto.
Qed.

Lemma on_one_decl_mapi_context (P : context -> term -> term -> Type) f :
  forall Γ,
    inclusion (on_one_decl (fun Γ => on_Trel (P (mapi_context f Γ)) (f #|Γ|)) Γ)
    (on_Trel (on_one_decl P (mapi_context f Γ)) (map_decl (f #|Γ|))).
Proof.
  intros Γ x y.
  destruct x as [na [b|] ty], y as [na' [b'|] ty']; simpl in *; firstorder auto; subst; simpl;
    auto.
Qed.

Lemma on_one_decl_test_impl (P Q : context -> term -> term -> Type) (p : term -> bool) :
  forall Γ d d',
    on_one_decl P Γ d d' ->
    test_decl p d ->
    (forall x y, p x -> P Γ x y -> Q Γ x y) ->
    on_one_decl Q Γ d d'.
Proof.
  intros Γ [na [b|] ty] [na' [b'|] ty'] ond []%andb_and; simpl; firstorder auto.
Qed.

Section OnOne_local_2.
  Context (P : forall (Γ : context), context_decl -> context_decl -> Type).

  Inductive OnOne2_local_env : context -> context -> Type :=
  | onone2_localenv_cons_abs Γ na na' t t' :
      P Γ (vass na t) (vass na' t') ->
      OnOne2_local_env (Γ ,, vass na t) (Γ ,, vass na' t')
  | onone2_localenv_def Γ na na' b b' t t' :
      P Γ (vdef na b t) (vdef na' b' t') ->
      OnOne2_local_env (Γ ,, vdef na b t) (Γ ,, vdef na' b' t')
  | onone2_localenv_cons_tl Γ Γ' d :
      OnOne2_local_env Γ Γ' ->
      OnOne2_local_env (Γ ,, d) (Γ' ,, d).
End OnOne_local_2.

#[global]
Instance OnOne2_local_env_length {P ctx ctx'} :
  HasLen (OnOne2_local_env P ctx ctx') #|ctx| #|ctx'|.
Proof.
  induction 1; simpl; lia.
Qed.

Lemma OnOne2_local_env_impl R S :
  (forall Δ, inclusion (R Δ) (S Δ)) ->
  inclusion (OnOne2_local_env R)
            (OnOne2_local_env S).
Proof.
  intros H x y H'.
  induction H'; try solve [econstructor; firstorder].
Qed.

Lemma OnOne2_local_env_ondecl_impl P Q :
  (forall Γ, inclusion (P Γ) (Q Γ)) ->
  inclusion (OnOne2_local_env (on_one_decl P)) (OnOne2_local_env (on_one_decl P)).
Proof.
  intros HP. now apply OnOne2_local_env_impl, on_one_decl_impl.
Qed.

Lemma OnOne2_local_env_map R Γ Δ (f : aname -> aname) (g : term -> term) :
  OnOne2_local_env (fun Γ => on_Trel (R (map (map_decl_na f g) Γ)) (map_decl_na f g)) Γ Δ ->
  OnOne2_local_env R (map (map_decl_na f g) Γ) (map (map_decl_na f g) Δ).
Proof.
  unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto].
Qed.

Lemma OnOne2_local_env_map_context R Γ Δ (f : term -> term) :
  OnOne2_local_env (fun Γ => on_Trel (R (map (map_decl f) Γ)) (map_decl f)) Γ Δ ->
  OnOne2_local_env R (map_context f Γ) (map_context f Δ).
Proof.
  unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto].
Qed.

Lemma OnOne2_local_env_mapi_context R Γ Δ (f : nat -> term -> term) :
  OnOne2_local_env (fun Γ => on_Trel (R (mapi_context f Γ)) (map_decl (f #|Γ|))) Γ Δ ->
  OnOne2_local_env R (mapi_context f Γ) (mapi_context f Δ).
Proof.
  unfold on_Trel in *; induction 1; simpl; try solve [econstructor; intuition auto].
  rewrite -(length_of X). now constructor.
Qed.

Lemma test_context_k_impl {p q : nat -> term -> bool} {k k'} {ctx} :
  (forall n t, p n t -> q n t) ->
  k = k' ->
  test_context_k p k ctx -> test_context_k q k' ctx.
Proof.
  intros Hfg <-.
  induction ctx as [|[na [b|] ty] ctx]; simpl; auto;
  move/andb_and=> [testp testd]; rewrite (IHctx testp);
  eapply test_decl_impl; tea; eauto.
Qed.

Lemma OnOne2_local_env_test_context_k {P ctx ctx'} {k} {p q : nat -> term -> bool} :
  (forall n t, q n t -> p n t) ->
  OnOne2_local_env P ctx ctx' ->
  (forall Γ d d',
    P Γ d d' ->
    test_context_k q k Γ ->
    test_decl (q (#|Γ| + k)) d ->
    test_decl (p (#|Γ| + k)) d') ->
  test_context_k q k ctx ->
  test_context_k p k ctx'.
Proof.
  intros hq onenv HPq.
  induction onenv.
  * move=> /= /andb_and [testq testd].
    rewrite (test_context_k_impl _ _ testq) //.
    simpl; eauto.
  * move=> /= /andb_and [testq testd].
    rewrite (test_context_k_impl _ _ testq) //.
    simpl; eauto.
  * move=> /= /andb_and [testq testd].
    rewrite (IHonenv testq).
    eapply test_decl_impl; tea.
    intros x Hx. eapply hq.
    now rewrite -(length_of onenv).
Qed.

Lemma on_one_decl_test_decl (P : context -> term -> term -> Type) Γ
  (p q : term -> bool) d d' :
  (forall t, p t -> q t) ->
  (forall t t', P Γ t t' -> p t -> q t') ->
  on_one_decl P Γ d d' ->
  test_decl p d ->
  test_decl q d'.
Proof.
  intros Hp.
  unfold test_decl.
  destruct d as [na [b|] ty], d' as [na' [b'|] ty']; simpl in * => //;
   intuition auto; rtoProp;
    subst; simpl; intuition eauto.
Qed.

Lemma OnOne2_local_env_impl_test {P Q ctx ctx'} {k} {p : nat -> term -> bool} :
  OnOne2_local_env P ctx ctx' ->
  (forall Γ d d',
    P Γ d d' ->
    test_context_k p k Γ ->
    test_decl (p (#|Γ| + k)) d ->
    Q Γ d d') ->
  test_context_k p k ctx ->
  OnOne2_local_env Q ctx ctx'.
Proof.
  intros onenv HPq.
  induction onenv.
  * move=> /= /andb_and [testq testd].
    constructor; auto.
  * move=> /= /andb_and [testq testd].
    constructor; auto.
  * move=> /= /andb_and [testq testd].
    constructor; auto.
Qed.


(** This file provides the unbounded fractional authoritative camera: a version
of the fractional authoritative camera that can be used with fractions [> 1].

Most of the reasoning principles for this version of the fractional
authoritative cameras are the same as for the original version. There are two
difference:

- We get the additional rule that can be used to allocate a "surplus", i.e.
  if we have the authoritative element we can always increase its fraction
  and allocate a new fragment.

  <<<
  ✓ (a ⋅ b) → ●U{p} a ~~> ●U{p + q} (a ⋅ b) ⋅ ◯U{q} b
  >>>

- We no longer have the [◯U{1} a] is the exclusive fragmental element (cf.
  [frac_auth_frag_validN_op_1_l]).
*)
From Coq Require Import QArith Qcanon.
From iris.algebra Require Export auth frac updates local_updates.
From iris.algebra Require Import ufrac proofmode_classes.
From iris Require Import options.

Definition ufrac_authR (A : cmraT) : cmraT :=
  authR (optionUR (prodR ufracR A)).
Definition ufrac_authUR (A : cmraT) : ucmraT :=
  authUR (optionUR (prodR ufracR A)).

(** Note in the signature of [ufrac_auth_auth] and [ufrac_auth_frag] we use
[q : Qp] instead of [q : ufrac]. This way, the API does not expose that [ufrac]
is used internally. This is quite important, as there are two canonical camera
instances with carrier [Qp], namely [fracR] and [ufracR]. When writing things
like [ufrac_auth_auth q a ∧ ✓{q}] we want Coq to infer the type of [q] as [Qp]
such that the [✓] of the default [fracR] camera is used, and not the [✓] of
the [ufracR] camera. *)
Definition ufrac_auth_auth {A : cmraT} (q : Qp) (x : A) : ufrac_authR A :=
  ● (Some (q : ufracR,x)).
Definition ufrac_auth_frag {A : cmraT} (q : Qp) (x : A) : ufrac_authR A :=
  ◯ (Some (q : ufracR,x)).

Typeclasses Opaque ufrac_auth_auth ufrac_auth_frag.

Instance: Params (@ufrac_auth_auth) 2 := {}.
Instance: Params (@ufrac_auth_frag) 2 := {}.

Notation "●U{ q } a" := (ufrac_auth_auth q a) (at level 10, format "●U{ q }  a").
Notation "◯U{ q } a" := (ufrac_auth_frag q a) (at level 10, format "◯U{ q }  a").

Section ufrac_auth.
  Context {A : cmraT}.
  Implicit Types a b : A.

  Global Instance ufrac_auth_auth_ne q : NonExpansive (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_auth_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_auth A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_ne q : NonExpansive (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.
  Global Instance ufrac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@ufrac_auth_frag A q).
  Proof. solve_proper. Qed.

  Global Instance ufrac_auth_auth_discrete q a : Discrete a → Discrete (●U{q} a).
  Proof. intros. apply auth_auth_discrete; [apply Some_discrete|]; apply _. Qed.
  Global Instance ufrac_auth_frag_discrete q a : Discrete a → Discrete (◯U{q} a).
  Proof. intros. apply auth_frag_discrete; apply Some_discrete; apply _. Qed.

  Lemma ufrac_auth_validN n a p : ✓{n} a → ✓{n} (●U{p} a ⋅ ◯U{p} a).
  Proof. by rewrite auth_both_validN. Qed.
  Lemma ufrac_auth_valid p a : ✓ a → ✓ (●U{p} a ⋅ ◯U{p} a).
  Proof. intros. by apply auth_both_valid_2. Qed.

  Lemma ufrac_auth_agreeN n p a b : ✓{n} (●U{p} a ⋅ ◯U{p} b) → a ≡{n}≡ b.
  Proof.
    rewrite auth_both_validN=> -[Hincl Hvalid].
    move: Hincl=> /Some_includedN=> -[[_ ? //]|[[[p' ?] ?] [/=]]].
    rewrite -discrete_iff leibniz_equiv_iff. rewrite ufrac_op'=> [/Qp_eq/=].
    rewrite -{1}(Qcplus_0_r p)=> /(inj (Qcplus p))=> ?; by subst.
  Qed.
  Lemma ufrac_auth_agree p a b : ✓ (●U{p} a ⋅ ◯U{p} b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=> n. by eapply ufrac_auth_agreeN, cmra_valid_validN.
  Qed.
  Lemma ufrac_auth_agree_L `{!LeibnizEquiv A} p a b : ✓ (●U{p} a ⋅ ◯U{p} b) → a = b.
  Proof. intros. by eapply leibniz_equiv, ufrac_auth_agree. Qed.

  Lemma ufrac_auth_includedN n p q a b : ✓{n} (●U{p} a ⋅ ◯U{q} b) → Some b ≼{n} Some a.
  Proof. by rewrite auth_both_validN=> -[/Some_pair_includedN [_ ?] _]. Qed.
  Lemma ufrac_auth_included `{CmraDiscrete A} q p a b :
    ✓ (●U{p} a ⋅ ◯U{q} b) → Some b ≼ Some a.
  Proof. rewrite auth_both_valid_discrete=> -[/Some_pair_included [_ ?] _] //. Qed.
  Lemma ufrac_auth_includedN_total `{CmraTotal A} n q p a b :
    ✓{n} (●U{p} a ⋅ ◯U{q} b) → b ≼{n} a.
  Proof. intros. by eapply Some_includedN_total, ufrac_auth_includedN. Qed.
  Lemma ufrac_auth_included_total `{CmraDiscrete A, CmraTotal A} q p a b :
    ✓ (●U{p} a ⋅ ◯U{q} b) → b ≼ a.
  Proof. intros. by eapply Some_included_total, ufrac_auth_included. Qed.

  Lemma ufrac_auth_auth_validN n q a : ✓{n} (●U{q} a) ↔ ✓{n} a.
  Proof.
    rewrite auth_auth_frac_validN Some_validN. split.
    by intros [?[]]. intros. by split.
  Qed.
  Lemma ufrac_auth_auth_valid q a : ✓ (●U{q} a) ↔ ✓ a.
  Proof. rewrite !cmra_valid_validN. by setoid_rewrite ufrac_auth_auth_validN. Qed.

  Lemma ufrac_auth_frag_validN n q a : ✓{n} (◯U{q} a) ↔ ✓{n} a.
  Proof. rewrite auth_frag_validN. split. by intros [??]. by split. Qed.
  Lemma ufrac_auth_frag_valid q a : ✓ (◯U{q} a) ↔ ✓ a.
  Proof. rewrite auth_frag_valid. split. by intros [??]. by split. Qed.

  Lemma ufrac_auth_frag_op q1 q2 a1 a2 : ◯U{q1+q2} (a1 ⋅ a2) ≡ ◯U{q1} a1 ⋅ ◯U{q2} a2.
  Proof. done. Qed.

  Global Instance ufrac_auth_is_op q q1 q2 a a1 a2 :
    IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯U{q} a) (◯U{q1} a1) (◯U{q2} a2).
  Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.

  Global Instance ufrac_auth_is_op_core_id q q1 q2 a :
    CoreId a → IsOp q q1 q2 → IsOp' (◯U{q} a) (◯U{q1} a) (◯U{q2} a).
  Proof.
    rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
    by rewrite -ufrac_auth_frag_op -core_id_dup.
  Qed.

  Lemma ufrac_auth_update p q a b a' b' :
    (a,b) ~l~> (a',b') → ●U{p} a ⋅ ◯U{q} b ~~> ●U{p} a' ⋅ ◯U{q} b'.
  Proof.
    intros. apply: auth_update.
    apply: option_local_update. by apply: prod_local_update_2.
  Qed.

  Lemma ufrac_auth_update_surplus p q a b :
   ✓ (a ⋅ b) → ●U{p} a ~~> ●U{p + q} (a ⋅ b) ⋅ ◯U{q} b.
  Proof.
    intros Hconsistent. apply: auth_update_alloc.
    intros n m; simpl; intros [Hvalid1 Hvalid2] Heq.
    split.
    - split; by apply cmra_valid_validN.
    - rewrite pair_op Some_op Heq comm.
      destruct m; simpl; [rewrite left_id | rewrite right_id]; done.
  Qed.
End ufrac_auth.


Require Import Stlc.CanForm.
Require Import Stlc.LemmasTyping.
Require Import Utlc.LemmasScoping.
Require Export LogRel.PseudoType.
Require Import UVal.UVal.

Section RepEmul.
  Lemma repEmul_embed_leftinv τ :
    repEmul (embed τ) = τ.
  Proof.
    induction τ; simpl; try f_equal; intuition.
  Qed.

  Lemma repEmulCtx_embedCtx_leftinv Γ :
    repEmulCtx (embedCtx Γ) = Γ.
  Proof.
    induction Γ; simpl; try f_equal; eauto using repEmul_embed_leftinv.
  Qed.

End RepEmul.

Ltac crushRepEmulEmbed :=
  match goal with
      [ |- context[ repEmul( embed ?τ) ] ] => rewrite -> (repEmul_embed_leftinv τ)
    | [ |- context[ repEmulCtx( embedCtx ?Γ) ] ] => rewrite -> (repEmulCtx_embedCtx_leftinv Γ)
  end.

Lemma getevar_repEmulCtx {i τ Γ} :
  ⟪ i : τ ∈ repEmulCtx Γ ⟫ →
  exists τ', ⟪ i : τ' p∈ Γ ⟫ ∧ τ = repEmul τ'.
Proof.
  revert i. induction Γ as [|Γ IHΓ τ''];
  inversion 1; [idtac| destruct (IHΓ _ H4) as [? [? ?]]];
  eauto using GetEvarP.
Qed.

Section OfType.

  Local Ltac crush :=
    unfold OfType, OfTypeStlc, OfTypeUtlc, OfTypeUtlc'; intros;
    repeat
      (subst;
       stlcCanForm;
       crushTyping;
       crushUtlcScoping;
       destruct_conjs;
       repeat
         match goal with
           | H: False |- _ => elim H
           | H: True  |- _ => clear H
           | H: _ ∧ _ |- _ => destruct  H
           | H: match ?tu with _ => _ end |- _ =>
             destruct tu eqn: ?; cbn in H
           | H: _ ∨ _ |- _ => destruct  H
           | [ |- _ ∧ _ ] => split
         end); eauto 20.

  Lemma OfType_unit : OfType ptunit S.unit U.unit.
  Proof. crush. Qed.

  Lemma OfType_true : OfType ptbool S.true U.true.
  Proof. crush. Qed.

  Lemma OfType_false : OfType ptbool S.false U.false.
  Proof. crush. Qed.

  Lemma OfType_inl {τ₁ τ₂ ts tu} :
    OfType τ₁ ts tu →
    OfType (ptsum τ₁ τ₂) (S.inl ts) (U.inl tu).
  Proof. crush. Qed.

  Lemma OfType_inr {τ₁ τ₂ ts tu} :
    OfType τ₂ ts tu →
    OfType (ptsum τ₁ τ₂) (S.inr ts) (U.inr tu).
  Proof. crush. Qed.

  Lemma OfType_pair {τ₁ τ₂ ts₁ ts₂ tu₁ tu₂} :
    OfType τ₁ ts₁ tu₁ →
    OfType τ₂ ts₂ tu₂ →
    OfType (ptprod τ₁ τ₂) (S.pair ts₁ ts₂) (U.pair tu₁ tu₂).
  Proof. crush. Qed.

  Lemma OfType_lambda {τ₁ τ₂ τ₁' tsb tub} :
    τ₁' = repEmul τ₁ →
    ⟨ 1 ⊢ tub ⟩ →
    ⟪ empty ⊢ S.abs (repEmul τ₁) tsb : repEmul τ₁ ⇒ repEmul τ₂ ⟫ →
    OfType (ptarr τ₁ τ₂) (S.abs τ₁' tsb) (U.abs tub).
  Proof. crush. Qed.

  Lemma OfType_inversion_ptunit {ts tu} :
    OfType ptunit ts tu →
    ts = S.unit ∧ tu = U.unit.
  Proof. crush. Qed.

  Lemma OfType_inversion_ptbool {ts tu} :
    OfType ptbool ts tu →
    ts = S.true ∧ tu = U.true ∨
    ts = S.true ∧ tu = U.false ∨
    ts = S.false ∧ tu = U.true ∨
    ts = S.false ∧ tu = U.false.
  Proof. crush. Qed.

  Lemma OfType_inversion_ptsum {τ₁ τ₂ ts tu} :
    OfType (ptsum τ₁ τ₂) ts tu →
    ∃ ts' tu',
      ts = S.inl ts' ∧ tu = U.inl tu' ∧ OfType τ₁ ts' tu' ∨
      ts = S.inl ts' ∧ tu = U.inr tu' ∨
      ts = S.inr ts' ∧ tu = U.inl tu' ∨
      ts = S.inr ts' ∧ tu = U.inr tu' ∧ OfType τ₂ ts' tu'.
  Proof. crush. Qed.

  Lemma OfType_inversion_ptprod {τ₁ τ₂ ts tu} :
    OfType (ptprod τ₁ τ₂) ts tu →
    ∃ ts₁ tu₁ ts₂ tu₂,
      ts = S.pair ts₁ ts₂ ∧
      tu = U.pair tu₁ tu₂ ∧
      OfType τ₁ ts₁ tu₁ ∧
      OfType τ₂ ts₂ tu₂.
  Proof. crush. Qed.

  Lemma OfTypeUtlc_inversion_ptarr {τ₁ τ₂ tu} :
    OfTypeUtlc (ptarr τ₁ τ₂) tu →
    ∃ tu', tu = U.abs tu' ∧ ⟨ 1 ⊢ tu' ⟩.
  Proof. crush. Qed.

  Lemma OfTypeUtlc_inversion_ptprod {τ₁ τ₂ tu} :
    OfTypeUtlc (ptprod τ₁ τ₂) tu →
    ∃ tu₁ tu₂, tu = U.pair tu₁ tu₂ ∧ OfTypeUtlc τ₁ tu₁ ∧ OfTypeUtlc τ₂ tu₂.
  Proof. crush. Qed.

  Lemma OfTypeUtlc_inversion_ptsum {τ₁ τ₂ tu} :
    OfTypeUtlc (ptsum τ₁ τ₂) tu →
    ∃ tu', (tu = U.inl tu' ∧ OfTypeUtlc τ₁ tu') ∨
           (tu = U.inr tu' ∧ OfTypeUtlc τ₂ tu').
  Proof. crush. Qed.

  Lemma OfType_inversion_ptarr {τ₁ τ₂ ts tu} :
    OfType (ptarr τ₁ τ₂) ts tu →
    ∃ ts' tu',
      ts = S.abs (repEmul τ₁) ts' ∧
      tu = U.abs tu' ∧
      ⟪ empty ▻ repEmul τ₁ ⊢ ts' : repEmul τ₂ ⟫ ∧
      ⟨ 1 ⊢ tu' ⟩.
  Proof. crush. Qed.

  Lemma OfType_inversion_pEmulDV {n p ts tu} :
    OfType (pEmulDV n p) ts tu →
    S.Value ts ∧ U.Value tu ∧
    ⟪ empty ⊢ ts : UVal n ⟫ ∧
    ⟨ 0 ⊢ tu ⟩.
  Proof. crush. Qed.

  Lemma OfTypeUtlc'_implies_Value {τ tu} :
    OfTypeUtlc' τ tu →
    U.Value tu.
  Proof.
    revert tu.
    induction τ; crush.
  Qed.

  Lemma OfTypeUtlc_implies_Value {τ tu} :
    OfTypeUtlc τ tu →
    U.Value tu.
  Proof.
    destruct 1 as (ctu & otu).
    eauto using OfTypeUtlc'_implies_Value.
  Qed.

  Lemma OfType_implies_Value {τ ts tu} :
    OfType τ ts tu →
    S.Value ts ∧ U.Value tu.
  Proof.
    unfold OfType, OfTypeStlc.
    intros ot; destruct_conjs;
    eauto using OfTypeUtlc_implies_Value.
  Qed.

  Lemma OfType_pEmulDV {n p ts tu} :
    S.Value ts ∧ U.Value tu ∧
    ⟪ empty ⊢ ts : UVal n ⟫ →
    ⟨ 0 ⊢ tu ⟩ →
    OfType (pEmulDV n p) ts tu.
  Proof. crush. Qed.

End OfType.

Ltac crushOfType :=
  repeat
    match goal with
      | [ H: OfType ptunit _ _ |- _ ] => apply OfType_inversion_ptunit in H
      | [ H: OfType ptbool _ _ |- _ ] => apply OfType_inversion_ptbool in H
      | [ H: OfType (ptsum _ _) _ _ |- _ ] => apply OfType_inversion_ptsum in H
      | [ H: OfType (ptprod _ _) _ _ |- _ ] => apply OfType_inversion_ptprod in H
      | [ H: OfType (ptarr _ _) _ _ |- _ ] => apply OfType_inversion_ptarr in H
      | [ H: OfTypeUtlc _ ?t |- ⟨ 0 ⊢ ?t ⟩ ] => exact (proj1 H)
      | [ H: OfTypeUtlc ?τ ?t |- OfTypeUtlc' ?τ ?t ] => exact (proj2 H)
      | [ H: OfTypeUtlc (ptarr _ _) _ |- _ ] => apply OfTypeUtlc_inversion_ptarr in H
      | [ H: OfTypeUtlc (ptprod _ _) _ |- _ ] => apply OfTypeUtlc_inversion_ptprod in H
      | [ H: OfTypeUtlc (ptsum _ _) _ |- _ ] => apply OfTypeUtlc_inversion_ptsum in H
      | [ H: OfType (pEmulDV _ _) _ _ |- _ ] => apply OfType_inversion_pEmulDV in H
      (* | [ H: OfTypeUtlc ptbool ?t  |- _ ] =>  change (OfTypeUtlc ptbool t) with (t = U.true ∨ t = U.false) in H *)
      (* | [ H: OfTypeUtlc ptunit ?t  |- _ ] => change (OfTypeUtlc ptunit t) with (t = U.unit) in H; subst t *)
      | [ |- OfType ptunit S.unit U.unit ] => apply OfType_unit
      | [ |- OfType ptbool S.true U.true ] => apply OfType_true
      | [ |- OfType ptbool S.false U.false ] => apply OfType_false
      | [ |- OfType (ptsum _ _) (S.inl _) (U.inl _)] => apply OfType_inl
      | [ |- OfType (ptsum _ _) (S.inr _) (U.inr _)] => apply OfType_inr
      | [ |- OfType (ptprod _ _) (S.pair _ _) (U.pair _ _) ] => apply OfType_pair
      | [ |- OfType (ptarr _ _) (S.abs _ _) (U.abs _) ] => apply OfType_lambda
      | [ |- OfTypeUtlc _ _ ] => split
      | [ |- OfType (pEmulDV _ _) _ _ ] => apply OfType_pEmulDV
    end.


Require Import Bool Arith List.
Require Import Coq.Program.Equality.
Require Import Program.
Require Import Coq.Logic.Eqdep.
Require Import Coq.Logic.Eqdep_dec.
Set Implicit Arguments.
Set Asymmetric Patterns.

Load hlist.
Load ling_syntax.
Load ling_semantics.

(* Some quick examples of expressions *)

Example inc : exp nil (TList TNat) :=
  emap (esucc (evar HFirst)) (econs (econst 4) (econs (econst 5) enil)).

Check emap (esucc (evar HFirst)) (econs (econst 4) (econs (econst 5) enil)).
Check (evar (HNext HFirst)).

Example let_ex : exp nil TNat :=
  elet (econst 42) (esucc (evar HFirst)).

Example app_prog : exp nil (TList TNat) := eappend (econs (econst 0) enil) (econs (econst 1) enil).

Example nested_map : exp nil (TList TNat) :=
  emap (esucc (evar HFirst))
  (emap (esucc (evar HFirst)) [| econst 1 ; econst 2 ; econst 3 |]).

Example flat_map : exp nil (TList TNat) :=
  emap (esucc (esucc (evar HFirst)))
       [| econst 1 ; econst 2 ; econst 3 |].

Eval compute in (expDenote app_prog) HNil.
Eval compute in (expDenote let_ex) HNil.
Eval compute in (expDenote inc) HNil.

(* Transformations *)

Definition Sub G G' := forall t, member t G -> exp G' t.

Definition idSub {G} : Sub G G := @evar G.

Program Definition consSub {G G' t} (e:exp G' t) (s:Sub G G') : Sub (t::G) G' :=
  fun t' (v: member t' (t::G)) =>
    match v with
    | HFirst _ => e
    | HNext _ _ v' => s _ v'
    end.

Notation "{| e ; .. ; f |}" := (consSub e .. (consSub f idSub) ..).

(* A renaming of environments are where all variables a members of both *)

Definition Ren G G' := forall t, @member ty t G -> @member ty t G'.

Program Definition renameLift {G G' t}
        (r : Ren G G') : Ren (t :: G) (t :: G') :=
  fun t' v =>
    match v with
    | HFirst _ => @HFirst ty t _
    | HNext _ _ v' => HNext (r _ v')
    end.

Fixpoint renameExp G G' t (r : Ren G G') (e : exp G t) :=
  match e with
  | evar _ x => evar (r _ x)
  | etrue => etrue
  | efalse => efalse
  | econst n => econst n
  | esucc e => esucc (renameExp r e)
  | eand e1 e2 => eand (renameExp r e1) (renameExp r e2)
  | enil _ => enil
  | econs _ e1 e2 => econs (renameExp r e1) (renameExp r e2)
  | elet _ _ e1 e2 => elet (renameExp r e1) (renameExp (renameLift r) e2)
  | eappend _ e1 e2 => eappend (renameExp r e1) (renameExp r e2)
  | emap _ _ e1 e2 => emap (renameExp (renameLift r) e1) (renameExp r e2)
  | efilter _ e1 e2 => efilter (renameExp (renameLift r) e1) (renameExp r e2)
  end.

Definition shiftExp G t t' : exp G t -> exp (t' :: G) t :=
  renameExp (fun _ v => HNext v).

Definition shift2Exp G t1 t2 t3 : exp (t2 :: G) t3 -> exp (t2 :: t1 :: G) t3.
  refine (renameExp
            (fun t' v =>
               (match v in (member _ l)
                      return (l = t2 :: G -> member t' (t2 :: t1 :: G)) with
                | HFirst _ => fun Heq => _
                | HNext _ _ v' => fun Heq => @HNext _ _ _ _
                                                    (@HNext _ _ _ _ _)
                end) eq_refl));
    injection Heq; intros; subst; repeat constructor.
  assumption.
Defined.

Program Definition
        subShift {G G'} t (s : Sub G G') : Sub (t :: G) (t :: G') :=
  fun t' v =>
    match v with
    | HFirst _ => evar HFirst
    | HNext _ _ v' => shiftExp t (s _ v')
    end.

Fixpoint subExp G G' t (s : Sub G G') (e : exp G t) :=
  match e with
  | evar _ x => s _ x
  | etrue => etrue
  | efalse => efalse
  | econst n => econst n
  | esucc e => esucc (subExp s e)
  | eand e1 e2 => eand (subExp s e1) (subExp s e2)
  | enil _ => enil
  | econs _ e1 e2 => econs (subExp s e1) (subExp s e2)
  | elet _ _ e1 e2 => elet (subExp s e1) (subExp (subShift s) e2)
  | eappend _ e1 e2 => eappend (subExp s e1) (subExp s e2)
  | emap _ _ e1 e2 => emap (subExp (subShift s) e1) (subExp s e2)
  | efilter _ e1 e2 => efilter (subExp (subShift s) e1) (subExp s e2)
  end.

Check subExp.
Check renameExp.
Check Sub.

Definition compose t1 t2 t3 G (f : exp (t1 :: G) t2) (g : exp (t2 :: G) t3) : exp (t1 :: G) t3 :=
  subExp {| f |} (shift2Exp _ g).

Definition tlSub {G G' t} (s : Sub (t :: G) G') : Sub G G' :=
  fun t' v => s t' (HNext v).

Definition hdSub {G G' t} (s : Sub (t :: G) G') : exp G' t :=
  s t HFirst.

Ltac Rewrites E :=
  (intros; simpl; try rewrite E;
   repeat (match goal with | [H : context[_ = _] |- _] => rewrite H end);
   auto).

Ltac ExtVar :=
  match goal with
    [ |- ?X = ?Y ] =>
    (apply (@functional_extensionality_dep _ _ X Y) ;
     let t := fresh "t" in
     intro t;
     apply functional_extensionality;
     let v := fresh "v" in
     intro v;
     dependent destruction v; auto)
  end.

Lemma LiftIdSub : forall G t, subShift (@idSub G) = @idSub (t::G).
Proof. intros.
       ExtVar.
       Qed.

Lemma ActIdSub : forall G t (e : exp G t), subExp idSub e = e.
Proof. induction e; Rewrites LiftIdSub. Qed.

Eval compute in compose (econst 10) (elet (econst 10) (evar (HFirst))).

Definition filter_fusion t G (e : exp G t) : exp G t.
  refine
    (match e in exp _ t' return exp G t' -> exp G t' with
     | efilter te p em => (fun lt (em' : exp G lt) =>
                             match em' in exp _ lt return (TList te = lt -> _) with
                             | efilter t' q eb => fun Heq _ => efilter (eand _ q) eb
                             | _ => fun _ e => e
                             end) (TList te) em _
     | _ => fun e => e
     end e).
  injection Heq. intros. rewrite <- H. exact p.
  trivial.
Defined.

Definition map_fusion t G (e : exp G t) : exp G t.
  refine (match e in exp _ t' return exp G t' -> exp G t' with
          | emap t2 t3 g em => (fun lt2 (em' : exp G lt2) =>
                                  match em' in exp _ lt2 return (TList t2 = lt2 -> _) with
                                  | emap t3 t2' f eb => fun Heq _ => emap (compose f _) eb
                                  | _ => fun _ e => e
                                  end) (TList t2) em _
          |  _ => fun e => e
          end e).
  injection Heq. intros. subst. exact g.
  trivial.
Defined.

Definition map_fusion2 t G (e : exp G t) : exp G t.
  refine (match e in exp _ t' return exp G t' -> exp G t' with
          | emap t2 t3 g em => (fun lt2 (em' : exp G lt2) =>
                                  match em' in exp _ lt2 return (TList t2 = lt2 -> _) with
                                  | emap t3 t2' f eb => fun Heq _ =>
                                                          emap (elet f (shift2Exp _ _)) eb
                                  | _ => fun _ e => e
                                  end) (TList t2) em _
          |  _ => fun e => e
          end e).
  injection Heq. intros. subst. exact g.
  trivial.
Defined.

Definition nest : exp nil (TList TNat) := (emap (esucc (evar HFirst)) (emap (esucc (esucc (evar HFirst))) [| econst 10; econst 20; econst 30 |])).

Eval compute in map_fusion nest.
Eval compute in map_fusion2 nest.
Eval compute in expDenote nest HNil.
Eval compute in expDenote (map_fusion nest) HNil.
Eval compute in expDenote (map_fusion2 nest) HNil.

Lemma let_id : forall G t (e : exp G t) s,
    expDenote (elet e (evar HFirst)) s = expDenote e s.
Proof.
  intros. simpl. reflexivity.
Qed.

Lemma append_assoc : forall G t (e1 e2 e3: exp G (TList t)) s,
    expDenote (eappend (eappend e1 e2) e3) s =
    expDenote (eappend e1 (eappend e2 e3)) s.
Proof.
  intros.
  simpl.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Lemma compose_sound : forall t1 t2 t3 G R (f : exp (t1 :: G) t2) (g : exp (t2 :: G) t3) v1,
    expDenote g (HCons (expDenote f (HCons v1 R)) R) =
    expDenote (compose f g) (HCons v1 R).
Proof.
  intros.
  generalize dependent f.
  generalize dependent v1.
  dependent induction g; intros; try reflexivity.
  - dependent destruction m; try reflexivity.
  - simpl. rewrite IHg; try reflexivity.
  - simpl.
    rewrite IHg1; try reflexivity.
    rewrite IHg2; try reflexivity.
  - simpl.
    rewrite IHg1; try reflexivity.
    rewrite IHg2; try reflexivity.
  - unfold compose.
    admit. (* let case *)
  - simpl.
    rewrite IHg1; try reflexivity.
    rewrite IHg2; try reflexivity.
  - admit. (* map case *)
  - admit. (* filter case *)
Admitted.

Theorem map_fusion_sound t G (e : exp G t) s : expDenote e s = expDenote (map_fusion e) s.
Proof.
  (* Eliminate all the trivial cases *)
  dependent destruction e;
    try (simpl; reflexivity).
  dependent destruction e2;
    try (simpl; reflexivity).
  simpl.
  (* Now do induction over what the list evaluates to *)
  induction (expDenote e2_2 s).
  - reflexivity.
  - simpl.
    rewrite compose_sound.
    rewrite IHt.
    reflexivity.
Qed.

Theorem filter_fusion_sound t G (e : exp G t) s : expDenote e s = expDenote (filter_fusion e) s.
  Proof.
    (* Eliminate all the trivial cases *)
    dependent destruction e;
      try (simpl; reflexivity).
    dependent destruction e2;
      try (simpl; reflexivity).
    simpl.
    (* Now do induction over what the list evaluates to *)
    induction (expDenote e2_2 s).
    - reflexivity.
    - simpl.
      destruct (expDenote e2_1 (HCons a s)); simpl.
      destruct (expDenote e1 (HCons a s)); simpl;
        try rewrite <- IHt;
        reflexivity.
      rewrite -> andb_b_false.
      rewrite <- IHt.
      reflexivity.
Qed.

Lemma capp_total : forall t (v1 v2 : val (TList t)),
    exists v, CApp v1 v2 v.
Proof.
  intros.
  dependent induction v1.
  - exists v2.
    constructor.
  - destruct (IHv1_2 t v1_2) with (v2 := v2).
    reflexivity.
    reflexivity.
    exists (vcons v1_1 x).
    econstructor.
    assumption.
Qed.

Ltac rewriter H :=
  erewrite H; try reflexivity; try eassumption; clear H.

(* CApp is deterministic *)
Lemma capp_determ : forall t (v1 v2 v3 v4 : val (TList t)),
    CApp v1 v2 v3 -> CApp v1 v2 v4 -> v3 = v4.
Proof.
  intros t v1 v2 v3 v4 H H'.
  dependent induction H; dependent destruction H'.
  - reflexivity.
  - rewriter IHCApp.
Qed.

Example ev_example :
  Ev (HCons (vconst 1) HNil) (evar HFirst) (vconst 1).
apply EvVar.
Qed.

Example ev_let :
  Ev HNil (elet (econst 10) (esucc (evar HFirst))) (vconst 11).
repeat econstructor.
Qed.

Example ev_map :
  Ev HNil (emap (esucc (evar HFirst)) [| econst 10 ; econst 11 |])
     (vcons (vconst 11) (vcons (vconst 12) vnil)).
repeat econstructor.
Qed.

Lemma vconst_congS : forall n n0, vconst n = vconst n0 -> vconst (S n) = vconst (S n0).
Proof.
  intros.
  congruence.
Qed.

Ltac exister v := exists v; econstructor; eassumption.

Lemma cmap_total : forall G t t' (R : ev_ctx G) (e : exp (t :: G) t') (vs : val (TList t)),
      (forall v, exists v', Ev (HCons v R) e v') -> exists vl, CMap R vs e vl.
Proof.
  dependent induction vs; intros.
  - exister (@vnil t').
  - assert (exists vb, Ev (HCons vs1 R) e vb).
    apply H.
    destruct H0.
    edestruct IHvs2; try eassumption; try reflexivity.
    exister (vcons x x0).
Qed.

Lemma cfilter_total : forall G t (R : ev_ctx G) (e : exp (t :: G) TBool) (vs : val (TList t)),
    (forall v, exists vb, Ev (HCons v R) e vb) -> exists vl, CFilter R vs e vl.
Proof.
  dependent induction vs; intros.
  - exister (@vnil t).
  - assert (exists vb, Ev (HCons vs1 R) e vb).
    apply H.
    destruct H0.
    dependent destruction x;
      edestruct IHvs2; try eassumption; try reflexivity.
    exister (vcons vs1 x).
    exister x.
Qed.

Theorem ev_total : forall G t (R : ev_ctx G) (e : exp G t),
    exists v, Ev R e v.
Proof.
  intros.
  dependent induction e.
  - (eexists; constructor).
  - (eexists; constructor).
  - (eexists; constructor).
  - (eexists; constructor).
  - destruct (IHe R).
    dependent destruction x.
    exister (vconst (S n)).
  - destruct (IHe1 R).
    destruct (IHe2 R).
    dependent destruction x;
      dependent destruction x0.
    exister vtrue.
    exister vfalse.
    exister vfalse.
    exister vfalse.
  - (eexists; constructor).
  - destruct (IHe1 R).
    destruct (IHe2 R).
    exister (vcons x x0).
  - destruct (IHe1 R).
    destruct (IHe2 (HCons x R)).
    exister x0.
  - destruct (IHe1 R).
    destruct (IHe2 R).
    assert (exists v, CApp x x0 v).
    apply capp_total with (v1 := x) (v2 := x0).
    destruct H1.
    exister x1.
  - destruct (IHe2 R).
    assert (exists v, CMap R x e1 v).
    apply cmap_total.
    intros.
    edestruct IHe1.
    exists x0.
    eassumption.
    destruct H0.
    exister x0.
  - destruct (IHe2 R).
    assert (exists v, CFilter R x e1 v).
    apply cfilter_total.
    intros.
    edestruct IHe1.
    exists x0.
    eassumption.
    destruct H0.
    exister x0.
Qed.

Ltac ev_destructor :=
  match goal with
  | [ H : Ev _ _ ?v |- _ = ?v ] => dependent destruction H; try reflexivity
  end.

Theorem ev_determ : forall G t (R : ev_ctx G) (e: exp G t) v1 v2,
      Ev R e v1 -> Ev R e v2 -> v1 = v2.
Proof.
  intros.
  generalize dependent v2.
  induction H using Ev_mut with
      (P := fun (G : list ty) (t : ty) (R : ev_ctx G) (e : exp G t) (v : val t) (ev : Ev R e v) => forall v2, Ev R e v2 -> v = v2)
      (P0 := fun (G : list ty) (t1 t2 : ty) (R : ev_ctx G)
                 (v : val (TList t1)) (e : exp (t1 :: G) t2) (v0 : val (TList t2))
                 (ev : CMap R v e v0) => forall v2, CMap R v e v2 -> v0 = v2)
      (P1 := fun (G : list ty) (t : ty) (R : ev_ctx G)
                 (v : val (TList t)) (e : exp (t :: G) TBool) (v0 : val (TList t))
                 (ev : CFilter R v e v0) => forall v2, CFilter R v e v2 -> v0 = v2);
    intros; try ev_destructor.
  - rewriter IHEv1.
    rewriter IHEv2.
  - eapply capp_determ.
    eassumption.
    rewriter IHEv1.
    rewriter IHEv2.
  - apply IHEv in H0.
    apply vconst_congS.
    assumption.
  - rewriter IHEv2.
  - apply IHEv1 in H1.
    inversion H1.
  - apply IHEv in H0_.
    inversion H0_.
  - rewriter IHEv2.
    rewriter IHEv1.
  - rewriter IHEv0.
    rewriter IHEv.
  - rewriter IHEv0.
    rewriter IHEv.
  - dependent destruction H.
    reflexivity.
  - dependent destruction H0.
    rewriter IHEv0.
    rewriter IHEv.
  - dependent destruction H.
    reflexivity.
  - dependent destruction H0.
    rewriter IHEv0.
    apply IHEv in H0.
    inversion H0.
  - dependent destruction H0.
    apply IHEv in H0.
    inversion H0.
    rewriter IHEv0.
Qed.

Lemma let_id_sound2 : forall t G (R : ev_ctx G) (e : exp G t) (v1 v2 : val t),
    Ev R e v1 -> Ev R (elet e (evar HFirst)) v2 -> v1 = v2.
Proof. intros.
       apply EvLet with (e2 := (evar HFirst)) (v2 := v1) in H.
       apply (ev_determ H) in H0.
       exact H0. constructor. Qed.

Lemma and_r_false : forall G (R : ev_ctx G) (e1 e2 : exp G TBool),
    Ev R e2 vfalse -> Ev R (eand e1 e2) vfalse.
Proof.
  intros.
  assert (exists v, Ev R e1 v).
  apply ev_total.
  destruct H0.
  dependent induction x.
  apply EvAndTrue; auto.
  apply EvAndFalse; auto.
Qed.

Lemma cfilter_fusion : forall t G (R : ev_ctx G) (e1 e2 : exp (t :: G) TBool) (v1 v2 v3 : val (TList t)),
  CFilter R v1 e1 v2 -> CFilter R v2 e2 v3 -> CFilter R v1 (eand e2 e1) v3.
  intros.
  dependent induction H.
  dependent destruction H0.
  apply CFilterNil.
  dependent destruction H1.
  apply CFilterTrue.
  apply EvAndTrue; assumption.
  apply IHCFilter.
  assumption.
  apply CFilterFalse.
  apply EvAndFalse; assumption.
  apply IHCFilter.
  assumption.
  apply CFilterFalse.
  apply and_r_false; assumption.
  apply IHCFilter; assumption.
Qed.

Check EvConst.
Check EvNil.
Check TNat.

Example ex1 : Ev HNil (emap (esucc (evar HFirst)) (econs (econst 4) enil)) (vcons (vconst 5) vnil).
eapply EvMap.
eapply EvCons.
eapply EvConst.
eapply EvNil.
eapply CMapCons.
eapply EvSucc.
eapply EvVar.
eapply CMapNil.
Defined.

Print ex1.

Check (EvMap (EvCons (EvConst HNil 4) (EvNil HNil TNat))
             (CMapCons (EvSucc (EvVar (HCons (vconst 4) HNil) HFirst)) (CMapNil HNil _))).

Theorem filter_fusion_sound2 : forall t G (R : ev_ctx G) (e : exp G t) (v : val t),
        Ev R e v -> Ev R (filter_fusion e) v.
Proof.
  intros.
  dependent destruction e;
    try (unfold filter_fusion;
         assumption).
  dependent destruction e2;
    try (unfold filter_fusion;
         assumption).
  simpl.
  dependent destruction H.
  dependent destruction H.
  eapply EvFilter.
  eassumption.
  eapply cfilter_fusion; eassumption.
Qed.

Lemma subst_sound : forall t t' G (R : ev_ctx G) (e : exp (t' :: G) t) (f : exp G t')
                           (v : val t) (v' : val t'),
    Ev (HCons v' R) e v -> Ev R f v' -> Ev R (subExp {| f |} e) v.
Proof.
  intros.
  dependent induction H; simpl. try constructor.
  dependent destruction m. auto. simpl. constructor.
  constructor.
  constructor.
  constructor.
  constructor.
  constructor.
  eapply IHEv1; try reflexivity; assumption.
  eapply IHEv2; try reflexivity; assumption.
  econstructor.
  eapply IHEv1; try reflexivity; assumption.
  eapply IHEv2; try reflexivity; assumption.
  assumption.
  constructor.
  eapply IHEv; try reflexivity; assumption.
  apply EvAndTrue.
  eapply IHEv1; try reflexivity; assumption.
  eapply IHEv2; try reflexivity; assumption.
  apply EvAndFalse.
  eapply IHEv; try reflexivity; assumption.
  econstructor.
  eapply IHEv1; try reflexivity; assumption.
Admitted.

Lemma shift2_sound : forall t1 t2 t3 G (R : ev_ctx G) (e : exp (t2 :: G) t3)
                            (v1 : val t1) (v2 : val t2) (v3 : val t3),
    Ev (HCons v2 R) e v3 -> Ev (HCons v2 (HCons v1 R)) (shift2Exp t1 e) v3.
Proof.
  intros.
  dependent induction H.
  dependent destruction m.
  simpl.
  constructor.
  dependent destruction m.
  simpl.
Admitted.

Lemma compose_sound2 : forall t1 t2 t3 G (R : ev_ctx G) (e1 : exp (t1 :: G) t2) (e2 : exp (t2 :: G) t3)
                              (v1 : val t1) (v2 : val t2) (v3 : val t3),
    Ev (HCons v1 R) e1 v2 -> Ev (HCons v2 R) e2 v3 -> Ev (HCons v1 R) (compose e1 e2) v3.
Proof.
  intros.
  unfold compose.
  eapply subst_sound.
  apply shift2_sound.
  eassumption.
  assumption.
Qed.

Lemma cmap_fusion : forall t1 t2 t3 G (R : ev_ctx G) (e1 : exp (t1 :: G) t2) (e2 : exp (t2 :: G) t3)
                           (v1 : val (TList t1)) (v2 : val (TList t2)) (v3 : val (TList t3)),
  CMap R v1 e1 v2 -> CMap R v2 e2 v3 -> CMap R v1 (compose e1 e2) v3.
  intros.
  generalize dependent v3.
  dependent induction H.
  intros.
  dependent destruction H0.
  apply CMapNil.
  intros.
  dependent destruction H1.
  apply CMapCons.
  eapply compose_sound2; eassumption.
  apply IHCMap.
  assumption.
Qed.

Theorem map_fusion_sound2 : forall t G (R : ev_ctx G) (e : exp G t) (v : val t),
        Ev R e v -> Ev R (map_fusion e) v.
Proof.
  intros.
  dependent destruction e;
  try (unfold map_fusion in *;
       assumption).
  dependent destruction e2;
  try (unfold map_fusion in *;
       assumption).
  simpl.
  dependent destruction H.
  dependent destruction H.
  eapply EvMap.
  eassumption.
  eapply cmap_fusion.
  eassumption.
  simpl_eq.
  assumption.
Qed.

Check EvMap.


Require Import StMonad_Coq AM_St BS Maps Term_Defs_Core Term_Defs Cvm_Run.

Require Import List.
Import ListNotations.

Definition AM := St AM_St.

Definition fromSome{A:Type} (default:A) (opt:option A): A :=
  match opt with
  | Some x => x
  | _ => default
  end.

Definition run_am_app_comp{A:Type} (am_comp:AM A) (default_A:A) : A :=
  let optRes := evalSt am_comp empty_amst in
  fromSome default_A optRes.

Definition am_newNonce (bs:BS) : AM nat :=
  oldSt <- get ;;
  let oldMap := am_nonceMap oldSt in
  let oldId := am_nonceId oldSt in
  let newMap := map_set oldMap oldId bs in
  let newId := oldId + 1 in
  put (mkAM_St newMap newId) ;;
  ret oldId.

Check map_get.

Definition am_getNonce (nid:nat) : AM BS :=
  oldSt <- get ;;
  let oldMap := am_nonceMap oldSt in
  let resopt := map_get oldMap nid in
  match resopt with
  | Some res => ret res
  | None => failm
  end.

Definition am_runCvm_nonce (t:Term) (p:Plc) (bs:BS) : AM (nat * RawEv) :=
  nid <- am_newNonce bs ;;
  ret (nid, run_cvm_rawEv t p [bs]).


From caml5 Require Import
  prelude.
From caml5.lang Require Import
  notations
  proofmode.

Record typed_prophet := {
  typed_prophet_type : Type ;
  typed_prophet_of_val : val → val → option typed_prophet_type ;
  typed_prophet_to_val : typed_prophet_type → val * val ;

  typed_prophet_of_to_val proph w v :
    (w, v) = typed_prophet_to_val proph →
    typed_prophet_of_val w v = Some proph ;
}.
#[global] Arguments Build_typed_prophet {_ _ _} _.

Section typed_prophet.
  Context `{!heapGS Σ} (prophet : typed_prophet).

  #[local] Fixpoint typed_prophet_process prophs :=
    match prophs with
    | [] =>
        []
    | (w, v) :: prophs =>
        match prophet.(typed_prophet_of_val) w v with
        | None =>
            []
        | Some proph =>
            proph :: typed_prophet_process prophs
        end
    end.
  Definition typed_prophet_model p prophs : iProp Σ :=
    ∃ pvs,
    ⌜prophs = typed_prophet_process pvs⌝ ∗ proph p pvs.

  #[global] Instance typed_prophet_model_timeless p prophs :
    Timeless (typed_prophet_model p prophs).
  Proof.
    apply _.
  Qed.

  Lemma typed_prophet_model_exclusive p prophs1 prophs2 :
    typed_prophet_model p prophs1 -∗
    typed_prophet_model p prophs2 -∗
    False.
  Proof.
    iIntros "* (%pvs1 & _ & Hp1) (%pvs2 & _ & Hp2)".
    iApply (proph_exclusive with "Hp1 Hp2").
  Qed.

  Lemma typed_prophet_new_proph_spec E :
    {{{ True }}}
      NewProph @ E
    {{{ p prophs, RET #p; typed_prophet_model p prophs }}}.
  Proof.
    iIntros "%Φ _ HΦ".
    wp_apply (wp_new_proph with "[//]"). iIntros "%pvs %p Hp".
    iApply "HΦ". iExists pvs. auto with iFrame.
  Qed.

  Lemma typed_prophet_resolve_spec e v E p prophs Φ :
    Atomic StronglyAtomic e →
    to_val e = None →
    typed_prophet_model p prophs -∗
    WP e @ E {{ w,
      ∃ proph,
      ⌜(w, v) = prophet.(typed_prophet_to_val) proph⌝ ∗
        ∀ prophs',
        ⌜prophs = proph :: prophs'⌝ -∗
        typed_prophet_model p prophs' -∗
        Φ w
    }} -∗
    WP Resolve e #p v @ E {{ Φ }}.
  Proof.
    iIntros "% % (%pvs & %Hprophs & Hp) HΦ".
    wp_apply (wp_resolve with "Hp"); first done.
    wp_apply (wp_wand with "HΦ"). iIntros "%w (%proph & % & HΦ) %pvs' -> Hp".
    rewrite /= (typed_prophet_of_to_val _ proph) in Hprophs; last done.
    iApply "HΦ"; first done. iExists pvs'. auto with iFrame.
  Qed.
End typed_prophet.

#[global] Opaque typed_prophet_model.